/[lcore]/trunk/btime.pas
ViewVC logotype

Diff of /trunk/btime.pas

Parent Directory Parent Directory | Revision Log Revision Log | View Patch Patch

revision 1 by plugwash, Fri Mar 28 02:26:58 2008 UTC revision 2 by beware, Sun Mar 30 00:16:07 2008 UTC
# Line 7  Line 7 
7  works on windows/delphi, and on freepascal on unix.  works on windows/delphi, and on freepascal on unix.
8  }  }
9    
10    
11  unit btime;  unit btime;
12    
13  interface  interface
# Line 14  Line 15 
15  type  type
16    float=extended;    float=extended;
17    
18    const
19      colorburst=39375000/11;  {3579545.4545....}
20    
21  var  var
22    timezone:integer;    timezone:integer;
23    timezonestr:string;    timezonestr:string;
24    irctime,unixtime:integer;    irctime,unixtime:integer;
25    tickcount:integer;    tickcount:integer;
26    settimebias:integer;    settimebias:integer;
   qpcjump:float; {can be read out and reset for debug purpose}  
27    performancecountfreq:extended;    performancecountfreq:extended;
28    
29  function irctimefloat:float;  function irctimefloat:float;
# Line 39  Line 42 
42  function timestring(i:integer):string;  function timestring(i:integer):string;
43  function timestrshort(i:integer):string;  function timestrshort(i:integer):string;
44    
45    {$ifdef win32}
46    function unixtimefloat_systemtime:float;
47    {$endif}
48    
49  function oletounixfloat(t:float):float;  function oletounixfloat(t:float):float;
50  function oletounix(t:tdatetime):integer;  function oletounix(t:tdatetime):integer;
51  function unixtoole(i:integer):tdatetime;  function unixtoole(i:integer):tdatetime;
52    
53    {$ifdef win32}
54    function mmtimefloat:float;
55    function qpctimefloat:float;
56    {$endif}
57    
58    const
59      mmtime_driftavgsize=32;
60      mmtime_warmupnum=4;
61      mmtime_warmupcyclelength=15;
62  var  var
63      //this flag is to be set when btime has been running long enough to stabilise
64      warmup_finished:boolean;
65    
66    timefloatbias:float;    timefloatbias:float;
67      ticks_freq:float=0;
68      ticks_freq2:float=0;
69      ticks_freq_known:boolean=false;
70    lastunixtimefloat:float=0;    lastunixtimefloat:float=0;
71      lastsynctime:float=0;
72      lastsyncbias:float=0;
73    
74      mmtime_last:integer=0;
75      mmtime_wrapadd:float;
76      mmtime_lastsyncmm:float=0;
77      mmtime_lastsyncqpc:float=0;
78      mmtime_drift:float=1;
79      mmtime_lastresult:float;
80      mmtime_nextdriftcorrection:float;
81      mmtime_driftavg:array[0..mmtime_driftavgsize] of float;
82      mmtime_synchedqpc:boolean;
83    
84      mmtime_prev_drift:float;
85      mmtime_prev_lastsyncmm:float;
86      mmtime_prev_lastsyncqpc:float;
87    
88  implementation  implementation
89    
# Line 61  Line 99 
99        baseunix,unix,unixutil,{needed for 2.0.2}        baseunix,unix,unixutil,{needed for 2.0.2}
100      {$endif}      {$endif}
101    {$else}    {$else}
102      windows,      windows,unitsettc,mmsystem,
103    {$endif}    {$endif}
104    sysutils;    sysutils;
105    
# Line 87  Line 125 
125    result := ((i)/86400)+daysdifference;    result := ((i)/86400)+daysdifference;
126  end;  end;
127    
128    const
129      highdwordconst=65536.0 * 65536.0;
130    
131    function utrunc(f:float):integer;
132    {converts float to integer, in 32 bits unsigned range}
133    begin
134      if f >= (highdwordconst/2) then f := f - highdwordconst;
135      result := trunc(f);
136    end;
137    
138    function uinttofloat(i:integer):float;
139    {converts 32 bits unsigned integer to float}
140    begin
141      result := i;
142      if result < 0 then result := result + highdwordconst;
143    end;
144    
145  {$ifdef unix}  {$ifdef unix}
146  {-----------------------------------------*nix/freepascal code to read time }  {-----------------------------------------*nix/freepascal code to read time }
147    
# Line 114  Line 169 
169  {$else} {delphi 3}  {$else} {delphi 3}
170  {------------------------------ windows/delphi code to read time}  {------------------------------ windows/delphi code to read time}
171    
172    {
173    time float: gettickcount
174    resolution: 9x: ~55 ms NT: 1/64th of a second
175    guarantees: continuous without any jumps
176    frequency base: same as system clock.
177    epoch: system boot
178    note: if called more than once per 49.7 days, 32 bits wrapping is compensated for and it keeps going on.
179    note: i handle the timestamp as signed integer, but with the wrap compensation that works as well, and is faster
180    }
181    
182    function mmtimefloat:float;
183    const
184      wrapduration=highdwordconst * 0.001;
185    var
186      i:integer;
187    begin
188      i := gettickcount; {timegettime}
189      if i < mmtime_last then begin
190        mmtime_wrapadd := mmtime_wrapadd + wrapduration;
191      end;
192      mmtime_last := i;
193      result := mmtime_wrapadd + i * 0.001;
194    
195      if (ticks_freq <> 0) and ticks_freq_known then result := int((result / ticks_freq)+0.5) * ticks_freq; //turn the float into an exact multiple of 1/64th sec to improve accuracy of things using this
196    end;
197    
198    procedure measure_ticks_freq;
199    var
200      f,g:float;
201      o:tosversioninfo;
202      isnt:boolean;
203      is9x:boolean;
204    begin
205      if (performancecountfreq = 0) then qpctimefloat;
206      ticks_freq_known := false;
207      settc;
208      f := mmtimefloat;
209      repeat g := mmtimefloat until g > f;
210      unsettc;
211      f := g - f;
212      fillchar(o,sizeof(o),0);
213      o.dwOSVersionInfoSize := sizeof(o);
214      getversionex(o);
215      isnt := o.dwPlatformId = VER_PLATFORM_WIN32_NT;
216      is9x := o.dwPlatformId = VER_PLATFORM_WIN32_WINDOWS;
217    
218      ticks_freq2 := f;
219      mmtime_synchedqpc := false;
220      {
221      NT 64 Hz
222      identify mode as: nt64
223      QPC rate: either 3579545 or TSC freq
224      QPC synched to gettickcount: no
225      duration between 2 ticks is constant: yes
226      gettickcount tick duration: 64 Hz
227      }
228      if (f >= 0.014) and (f <= 0.018) and isnt then begin
229        ticks_freq_known := true;
230        ticks_freq := 1/64;
231        mmtime_synchedqpc := false;
232      end;
233    
234      {
235      NT 100 Hz
236      identify mode as: nt100
237      QPC rate: 1193182
238      QPC synched to gettickcount: yes
239      duration between 2 ticks is constant: no?
240      gettickcount tick duration: ~99.85 Hz
241      }
242      if (performancecountfreq = 1193182) and (f >= 0.008) and (f <= 0.012) and isnt then begin
243        ticks_freq_known := true;
244        ticks_freq2 := 11949 / (colorburst / 3);
245       //  ticks_freq2 := 11949 / 1193182;
246        ticks_freq := 0;
247        {the ticks freq should be very close to the real one but if it's not exact, it will cause drift and correction jumps}
248        mmtime_synchedqpc := true;
249      end;
250    
251      {9x}
252      if (performancecountfreq = 1193182) and (g >= 0.050) and (g <= 0.060) then begin
253        ticks_freq_known := true;
254        ticks_freq := 65536 / (colorburst / 3);
255        mmtime_synchedqpc := true;
256      end;
257      ticks_freq_known := true;
258      if ticks_freq <> 0 then ticks_freq2 := ticks_freq;
259    //  writeln(formatfloat('0.000000',ticks_freq));
260    end;
261    
262    {
263    time float: QueryPerformanceCounter
264    resolution: <1us
265    guarantees: can have forward jumps depending on hardware. can have forward and backwards jitter on dual core.
266    frequency base: on NT, not the system clock, drifts compared to it.
267    epoch: system boot
268    }
269    function qpctimefloat:extended;
270    var
271      p:packed record
272        lowpart:longint;
273        highpart:longint
274      end;
275      p2:tlargeinteger absolute p;
276      e:extended;
277    begin
278      if performancecountfreq = 0 then begin
279        QueryPerformancefrequency(p2);
280        e := p.lowpart;
281        if e < 0 then e := e + highdwordconst;
282        performancecountfreq := ((p.highpart*highdwordconst)+e);
283      end;
284      queryperformancecounter(p2);
285      e := p.lowpart;
286      if e < 0 then e := e + highdwordconst;
287    
288      result := ((p.highpart*highdwordconst)+e)/performancecountfreq;
289    end;
290    
291    {
292    time float: QPC locked to gettickcount
293    resolution: <1us
294    guarantees: continuous without any jumps
295    frequency base: same as system clock.
296    epoch: system boot
297    }
298    
299    function mmqpctimefloat:float;
300    const
301      maxretries=5;
302      margin=0.002;
303    var
304      jump:float;
305      mm,f,qpc,newdrift,f1,f2:float;
306      qpcjumped:boolean;
307      a,b,c:integer;
308      retrycount:integer;
309    begin
310      if not ticks_freq_known then measure_ticks_freq;
311      retrycount := maxretries;
312    
313      qpc := qpctimefloat;
314      mm := mmtimefloat;
315      f := (qpc - mmtime_lastsyncqpc) * mmtime_drift + mmtime_lastsyncmm;
316      //writeln('XXXX ',formatfloat('0.000000',qpc-mm));
317      qpcjumped := ((f-mm) > ticks_freq2+margin) or ((f-mm) < -margin);
318    //  if qpcjumped then writeln('qpc jumped ',(f-mm));
319      if ((qpc > mmtime_nextdriftcorrection) and not mmtime_synchedqpc) or qpcjumped then begin
320    
321        mmtime_nextdriftcorrection := qpc + 1;
322        repeat
323          mmtime_prev_drift := mmtime_drift;
324          mmtime_prev_lastsyncmm := mmtime_lastsyncmm;
325          mmtime_prev_lastsyncqpc := mmtime_lastsyncqpc;
326    
327          mm := mmtimefloat;
328          dec(retrycount);
329          settc;
330          result := qpctimefloat;
331          f := mmtimefloat;
332          repeat
333            if f = mm then result := qpctimefloat;
334            f := mmtimefloat
335          until f > mm;
336          qpc := qpctimefloat;
337    
338          unsettc;
339          if (qpc > result + 0.0001) then begin
340            continue;
341          end;
342          mm := f;
343    
344          if (mmtime_lastsyncqpc <> 0) and not qpcjumped then begin
345            newdrift := (mm - mmtime_lastsyncmm) / (qpc - mmtime_lastsyncqpc);
346            mmtime_drift := newdrift;
347         {   writeln('raw drift: ',formatfloat('0.00000000',mmtime_drift));}
348            move(mmtime_driftavg[0],mmtime_driftavg[1],sizeof(mmtime_driftavg[0])*high(mmtime_driftavg));
349            mmtime_driftavg[0] := mmtime_drift;
350    
351    {        write('averaging drift ',formatfloat('0.00000000',mmtime_drift),' -> ');}
352    {        mmtime_drift := 0;}
353            b := 0;
354            for a := 0 to high(mmtime_driftavg) do begin
355              if mmtime_driftavg[a] <> 0 then inc(b);
356    {          mmtime_drift := mmtime_drift + mmtime_driftavg[a];}
357            end;
358    {        mmtime_drift := mmtime_drift / b;}
359            if (b = 1) then a := 5 else if (b = 2) then a := 15 else if (b = 3) then a := 30 else if (b = 4) then a := 60 else if (b = 5) then a := 120 else if (b >= 5) then a := 120;
360            mmtime_nextdriftcorrection := qpc + a;
361            if (b >= 2) then warmup_finished := true;
362    {        writeln(formatfloat('0.00000000',mmtime_drift));}
363           if mmtime_synchedqpc then mmtime_drift := 1;
364          end;
365    
366          mmtime_lastsyncqpc := qpc;
367          mmtime_lastsyncmm := mm;
368      {   writeln(formatfloat('0.00000000',mmtime_drift));}
369          break;
370        until false;
371    
372    
373        qpc := qpctimefloat;
374    
375        result := (qpc - mmtime_lastsyncqpc) * mmtime_drift + mmtime_lastsyncmm;
376        f := (qpc - mmtime_prev_lastsyncqpc) * mmtime_prev_drift + mmtime_prev_lastsyncmm;
377    
378        jump := result-f;
379        {writeln('jump ',formatfloat('0.000000',jump),'   drift ',formatfloat('0.00000000',mmtime_drift),' duration ',formatfloat('0.000',(mmtime_lastsyncqpc-mmtime_prev_lastsyncqpc)),' ',formatfloat('0.00000000',jump/(mmtime_lastsyncqpc-mmtime_prev_lastsyncqpc)));}
380    
381        f := result;
382      end;
383    
384      result := f;
385    
386      if (result < mmtime_lastresult) then result := mmtime_lastresult + 0.000001;
387      mmtime_lastresult := result;
388    end;
389    
390  { free pascals tsystemtime is incomaptible with windows api calls  { free pascals tsystemtime is incomaptible with windows api calls
391   so we declare it ourselves - plugwash   so we declare it ourselves - plugwash
392  }  }
# Line 160  Line 433 
433    Result := round(Date_utc) + Time_utc;    Result := round(Date_utc) + Time_utc;
434  end;  end;
435    
436  const  function unixtimefloat_systemtime:float;
   highdwordconst=4294967296.0;  
   
 function wintimefloat:extended;  
 var  
   p:packed record  
     lowpart:longint;  
     highpart:longint  
   end;  
   p2:tlargeinteger absolute p;  
   e:extended;  
 begin  
   if performancecountfreq = 0 then begin  
     QueryPerformancefrequency(p2);  
     e := p.lowpart;  
     if e < 0 then e := e + highdwordconst;  
     performancecountfreq := ((p.highpart*highdwordconst)+e);  
   end;  
   queryperformancecounter(p2);  
   e := p.lowpart;  
   if e < 0 then e := e + highdwordconst;  
   result := ((p.highpart*highdwordconst)+e)/performancecountfreq;  
 end;  
   
 var  
   classpriority,threadpriority:integer;  
   
 procedure settc;  
 var  
   hprocess,hthread:integer;  
437  begin  begin
438    hProcess := GetCurrentProcess;    {result := oletounixfloat(now_utc);}
   hThread := GetCurrentThread;  
   
   ClassPriority := GetPriorityClass(hProcess);  
   ThreadPriority := GetThreadPriority(hThread);  
439    
440    SetPriorityClass(hProcess, REALTIME_PRIORITY_CLASS);    {this method gives exactly the same result with extended precision, but is less sensitive to float rounding in theory}
441    SetThreadPriority(hThread, THREAD_PRIORITY_TIME_CRITICAL);    result := oletounixfloat(int(date_utc+0.5))+time_utc*86400;
442  end;  end;
443    
444  procedure unsettc;  function wintimefloat:extended;
 var  
   hprocess,hthread:integer;  
445  begin  begin
446    hProcess := GetCurrentProcess;    result := mmqpctimefloat;
   hThread := GetCurrentThread;  
   
   SetPriorityClass(hProcess, ClassPriority);  
   SetThreadPriority(hThread,  ThreadPriority);  
447  end;  end;
448    
449  function unixtimefloat:float;  function unixtimefloat:float;
450    const
451      margin = 0.0012;
452  var  var
453    f,g,h:float;    f,g,h:float;
454  begin  begin
455    if timefloatbias = 0 then begin    result := wintimefloat+timefloatbias;
456      f := result-unixtimefloat_systemtime;
457      if ((f > ticks_freq2+margin) or (f < -margin)) or (timefloatbias = 0) then begin
458    //    writeln('unixtimefloat init');
459        f := unixtimefloat_systemtime;
460      settc;      settc;
461      f := now_utc;      repeat g := unixtimefloat_systemtime; h := wintimefloat until g > f;
     repeat g := now_utc; h := wintimefloat until g > f;  
     timefloatbias := oletounixfloat(g)-h;  
462      unsettc;      unsettc;
463    end;      timefloatbias := g-h;
   result := wintimefloat+timefloatbias;  
   
   {  
   workaround for QPC jumps  
   (approach 2: always check "hi res" QPC unixtime against the "guaranteed" systemtime one)  
   }  
   f := result-(oletounixfloat(now_utc));  
   if abs(f) > 0.02 then begin  
     f := timefloatbias;  
     timefloatbias := 0;  
464      result := unixtimefloat;      result := unixtimefloat;
     qpcjump := qpcjump + f - timefloatbias;  
465    end;    end;
466    
467    if (result <= lastunixtimefloat) then result := lastunixtimefloat + 0.0000001;    {for small changes backwards, guarantee no steps backwards}
468      if (result <= lastunixtimefloat) and (result > lastunixtimefloat-1.5) then result := lastunixtimefloat + 0.0000001;
469    lastunixtimefloat := result;    lastunixtimefloat := result;
470  end;  end;
471    
# Line 352  Line 580 
580    
581  procedure init;  procedure init;
582  begin  begin
583    qpcjump := 0;    {$ifdef win32}timebeginperiod(1);{$endif} //ensure stable unchanging clock
584      fillchar(mmtime_driftavg,sizeof(mmtime_driftavg),0);
585    settimebias := 0;    settimebias := 0;
586    gettimezone;    gettimezone;
587    unixtime := unixtimeint;    unixtime := unixtimeint;
588    irctime := irctimeint;    irctime := irctimeint;
589  end;  end;
590    
591    initialization init;
592    
593  end.  end.

Legend:
Removed from v.1  
changed lines
  Added in v.2

No admin address has been configured">No admin address has been configured
ViewVC Help
Powered by ViewVC 1.1.22