X-Git-Url: http://www.lcore.org/git/lcore.git/blobdiff_plain/4782a5c5afee47721cc617daa40dd29828342c2b..6cb6b7ede2d178e03fa817bc28474c175f5a93b9:/btime.pas

diff --git a/btime.pas b/btime.pas
index 3d672c4..4636a9b 100755
--- a/btime.pas
+++ b/btime.pas
@@ -7,6 +7,7 @@ this unit returns unix timestamp with seconds and microseconds (as float)
 works on windows/delphi, and on freepascal on unix.
 }
 
+
 unit btime;
 
 interface
@@ -14,13 +15,15 @@ interface
 type
   float=extended;
 
+const
+  colorburst=39375000/11;  {3579545.4545....}
+
 var
   timezone:integer;
   timezonestr:string;
   irctime,unixtime:integer;
   tickcount:integer;
   settimebias:integer;
-  qpcjump:float; {can be read out and reset for debug purpose}
   performancecountfreq:extended;
 
 function irctimefloat:float;
@@ -39,13 +42,48 @@ procedure init;
 function timestring(i:integer):string;
 function timestrshort(i:integer):string;
 
+{$ifdef win32}
+function unixtimefloat_systemtime:float;
+{$endif}
+
 function oletounixfloat(t:float):float;
 function oletounix(t:tdatetime):integer;
 function unixtoole(i:integer):tdatetime;
 
+{$ifdef win32}
+function mmtimefloat:float;
+function qpctimefloat:float;
+{$endif}
+
+const
+  mmtime_driftavgsize=32;
+  mmtime_warmupnum=4;
+  mmtime_warmupcyclelength=15;
 var
+  //this flag is to be set when btime has been running long enough to stabilise
+  warmup_finished:boolean;
+
   timefloatbias:float;
+  ticks_freq:float=0;
+  ticks_freq2:float=0;
+  ticks_freq_known:boolean=false;
   lastunixtimefloat:float=0;
+  lastsynctime:float=0;
+  lastsyncbias:float=0;
+
+  mmtime_last:integer=0;
+  mmtime_wrapadd:float;
+  mmtime_lastsyncmm:float=0;
+  mmtime_lastsyncqpc:float=0;
+  mmtime_drift:float=1;
+  mmtime_lastresult:float;
+  mmtime_nextdriftcorrection:float;
+  mmtime_driftavg:array[0..mmtime_driftavgsize] of float;
+  mmtime_synchedqpc:boolean;
+
+  mmtime_prev_drift:float;
+  mmtime_prev_lastsyncmm:float;
+  mmtime_prev_lastsyncqpc:float;
 
 implementation
 
@@ -58,10 +96,10 @@ uses
     {$ifdef VER1_0}
       linux,
     {$else}
-      baseunix,unix,unixutil,{needed for 2.0.2}
+      baseunix,unix,unixutil, {needed for 2.0.2}
     {$endif}
   {$else}
-    windows,
+    windows,unitsettc,mmsystem,
   {$endif}
   sysutils;
 
@@ -87,6 +125,23 @@ begin
   result := ((i)/86400)+daysdifference;
 end;
 
+const
+  highdwordconst=65536.0 * 65536.0;
+
+function utrunc(f:float):integer;
+{converts float to integer, in 32 bits unsigned range}
+begin
+  if f >= (highdwordconst/2) then f := f - highdwordconst;
+  result := trunc(f);
+end;
+
+function uinttofloat(i:integer):float;
+{converts 32 bits unsigned integer to float}
+begin
+  result := i;
+  if result < 0 then result := result + highdwordconst;
+end;
+
 {$ifdef unix}
 {-----------------------------------------*nix/freepascal code to read time }
 
@@ -114,6 +169,224 @@ end;
 {$else} {delphi 3}
 {------------------------------ windows/delphi code to read time}
 
+{
+time float: gettickcount
+resolution: 9x: ~55 ms NT: 1/64th of a second
+guarantees: continuous without any jumps
+frequency base: same as system clock.
+epoch: system boot
+note: if called more than once per 49.7 days, 32 bits wrapping is compensated for and it keeps going on.
+note: i handle the timestamp as signed integer, but with the wrap compensation that works as well, and is faster
+}
+
+function mmtimefloat:float;
+const
+  wrapduration=highdwordconst * 0.001;
+var
+  i:integer;
+begin
+  i := gettickcount; {timegettime}
+  if i < mmtime_last then begin
+    mmtime_wrapadd := mmtime_wrapadd + wrapduration;
+  end;
+  mmtime_last := i;
+  result := mmtime_wrapadd + i * 0.001;
+
+  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
+end;
+
+procedure measure_ticks_freq;
+var
+  f,g:float;
+  o:tosversioninfo;
+  isnt:boolean;
+  is9x:boolean;
+begin
+  if (performancecountfreq = 0) then qpctimefloat;
+  ticks_freq_known := false;
+  settc;
+  f := mmtimefloat;
+  repeat g := mmtimefloat until g > f;
+  unsettc;
+  f := g - f;
+  fillchar(o,sizeof(o),0);
+  o.dwOSVersionInfoSize := sizeof(o);
+  getversionex(o);
+  isnt := o.dwPlatformId = VER_PLATFORM_WIN32_NT;
+  is9x := o.dwPlatformId = VER_PLATFORM_WIN32_WINDOWS;
+
+  ticks_freq2 := f;
+  mmtime_synchedqpc := false;
+  {
+  NT 64 Hz
+  identify mode as: nt64
+  QPC rate: either 3579545 or TSC freq
+  QPC synched to gettickcount: no
+  duration between 2 ticks is constant: yes
+  gettickcount tick duration: 64 Hz
+  }
+  if (f >= 0.014) and (f <= 0.018) and isnt then begin
+    ticks_freq_known := true;
+    ticks_freq := 1/64;
+    mmtime_synchedqpc := false;
+  end;
+
+  {
+  NT 100 Hz
+  identify mode as: nt100
+  QPC rate: 1193182
+  QPC synched to gettickcount: yes
+  duration between 2 ticks is constant: no?
+  gettickcount tick duration: ~99.85 Hz
+  }
+  if (performancecountfreq = 1193182) and (f >= 0.008) and (f <= 0.012) and isnt then begin
+    ticks_freq_known := true;
+    ticks_freq2 := 11949 / (colorburst / 3);
+   //  ticks_freq2 := 11949 / 1193182;
+    ticks_freq := 0;
+    {the ticks freq should be very close to the real one but if it's not exact, it will cause drift and correction jumps}
+    mmtime_synchedqpc := true;
+  end;
+
+  {9x}
+  if (performancecountfreq = 1193182) and (g >= 0.050) and (g <= 0.060) then begin
+    ticks_freq_known := true;
+    ticks_freq := 65536 / (colorburst / 3);
+    mmtime_synchedqpc := true;
+  end;
+  ticks_freq_known := true;
+  if ticks_freq <> 0 then ticks_freq2 := ticks_freq;
+//  writeln(formatfloat('0.000000',ticks_freq));
+end;
+
+{
+time float: QueryPerformanceCounter
+resolution: <1us
+guarantees: can have forward jumps depending on hardware. can have forward and backwards jitter on dual core.
+frequency base: on NT, not the system clock, drifts compared to it.
+epoch: system boot
+}
+function qpctimefloat: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;
+
+{
+time float: QPC locked to gettickcount
+resolution: <1us
+guarantees: continuous without any jumps
+frequency base: same as system clock.
+epoch: system boot
+}
+
+function mmqpctimefloat:float;
+const
+  maxretries=5;
+  margin=0.002;
+var
+  jump:float;
+  mm,f,qpc,newdrift,f1,f2:float;
+  qpcjumped:boolean;
+  a,b,c:integer;
+  retrycount:integer;
+begin
+  if not ticks_freq_known then measure_ticks_freq;
+  retrycount := maxretries;
+
+  qpc := qpctimefloat;
+  mm := mmtimefloat;
+  f := (qpc - mmtime_lastsyncqpc) * mmtime_drift + mmtime_lastsyncmm;
+  //writeln('XXXX ',formatfloat('0.000000',qpc-mm));
+  qpcjumped := ((f-mm) > ticks_freq2+margin) or ((f-mm) < -margin);
+//  if qpcjumped then writeln('qpc jumped ',(f-mm));
+  if ((qpc > mmtime_nextdriftcorrection) and not mmtime_synchedqpc) or qpcjumped then begin
+
+    mmtime_nextdriftcorrection := qpc + 1;
+    repeat
+      mmtime_prev_drift := mmtime_drift;
+      mmtime_prev_lastsyncmm := mmtime_lastsyncmm;
+      mmtime_prev_lastsyncqpc := mmtime_lastsyncqpc;
+
+      mm := mmtimefloat;
+      dec(retrycount);
+      settc;
+      result := qpctimefloat;
+      f := mmtimefloat;
+      repeat
+        if f = mm then result := qpctimefloat;
+        f := mmtimefloat
+      until f > mm;
+      qpc := qpctimefloat;
+
+      unsettc;
+      if (qpc > result + 0.0001) then begin
+        continue;
+      end;
+      mm := f;
+
+      if (mmtime_lastsyncqpc <> 0) and not qpcjumped then begin
+        newdrift := (mm - mmtime_lastsyncmm) / (qpc - mmtime_lastsyncqpc);
+        mmtime_drift := newdrift;
+     {   writeln('raw drift: ',formatfloat('0.00000000',mmtime_drift));}
+        move(mmtime_driftavg[0],mmtime_driftavg[1],sizeof(mmtime_driftavg[0])*high(mmtime_driftavg));
+        mmtime_driftavg[0] := mmtime_drift;
+
+{        write('averaging drift ',formatfloat('0.00000000',mmtime_drift),' -> ');}
+{        mmtime_drift := 0;}
+        b := 0;
+        for a := 0 to high(mmtime_driftavg) do begin
+          if mmtime_driftavg[a] <> 0 then inc(b);
+{          mmtime_drift := mmtime_drift + mmtime_driftavg[a];}
+        end;
+{        mmtime_drift := mmtime_drift / b;}
+        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;
+        mmtime_nextdriftcorrection := qpc + a;
+        if (b >= 2) then warmup_finished := true;
+{        writeln(formatfloat('0.00000000',mmtime_drift));}
+       if mmtime_synchedqpc then mmtime_drift := 1;
+      end;
+
+      mmtime_lastsyncqpc := qpc;
+      mmtime_lastsyncmm := mm;
+  {   writeln(formatfloat('0.00000000',mmtime_drift));}
+      break;
+    until false;
+
+
+    qpc := qpctimefloat;
+
+    result := (qpc - mmtime_lastsyncqpc) * mmtime_drift + mmtime_lastsyncmm;
+    f := (qpc - mmtime_prev_lastsyncqpc) * mmtime_prev_drift + mmtime_prev_lastsyncmm;
+
+    jump := result-f;
+    {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)));}
+
+    f := result;
+  end;
+
+  result := f;
+
+  if (result < mmtime_lastresult) then result := mmtime_lastresult + 0.000001;
+  mmtime_lastresult := result;
+end;
+
 { free pascals tsystemtime is incomaptible with windows api calls
  so we declare it ourselves - plugwash
 }
@@ -160,84 +433,39 @@ begin
   Result := round(Date_utc) + Time_utc;
 end;
 
-const
-  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;
+function unixtimefloat_systemtime:float;
 begin
-  hProcess := GetCurrentProcess;
-  hThread := GetCurrentThread;
-
-  ClassPriority := GetPriorityClass(hProcess);
-  ThreadPriority := GetThreadPriority(hThread);
+  {result := oletounixfloat(now_utc);}
 
-  SetPriorityClass(hProcess, REALTIME_PRIORITY_CLASS);
-  SetThreadPriority(hThread, THREAD_PRIORITY_TIME_CRITICAL);
+  {this method gives exactly the same result with extended precision, but is less sensitive to float rounding in theory}
+  result := oletounixfloat(int(date_utc+0.5))+time_utc*86400;
 end;
 
-procedure unsettc;
-var
-  hprocess,hthread:integer;
+function wintimefloat:extended;
 begin
-  hProcess := GetCurrentProcess;
-  hThread := GetCurrentThread;
-
-  SetPriorityClass(hProcess, ClassPriority);
-  SetThreadPriority(hThread,  ThreadPriority);
+  result := mmqpctimefloat;
 end;
 
 function unixtimefloat:float;
+const
+  margin = 0.0012;
 var
   f,g,h:float;
 begin
-  if timefloatbias = 0 then begin
+  result := wintimefloat+timefloatbias;
+  f := result-unixtimefloat_systemtime;
+  if ((f > ticks_freq2+margin) or (f < -margin)) or (timefloatbias = 0) then begin
+//    writeln('unixtimefloat init');
+    f := unixtimefloat_systemtime;
     settc;
-    f := now_utc;
-    repeat g := now_utc; h := wintimefloat until g > f;
-    timefloatbias := oletounixfloat(g)-h;
+    repeat g := unixtimefloat_systemtime; h := wintimefloat until g > f;
     unsettc;
-  end;
-  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;
+    timefloatbias := g-h;
     result := unixtimefloat;
-    qpcjump := qpcjump + f - timefloatbias;
   end;
 
-  if (result <= lastunixtimefloat) then result := lastunixtimefloat + 0.0000001;
+  {for small changes backwards, guarantee no steps backwards}
+  if (result <= lastunixtimefloat) and (result > lastunixtimefloat-1.5) then result := lastunixtimefloat + 0.0000001;
   lastunixtimefloat := result;
 end;
 
@@ -352,11 +580,14 @@ end;
 
 procedure init;
 begin
-  qpcjump := 0;
+  {$ifdef win32}timebeginperiod(1);{$endif} //ensure stable unchanging clock
+  fillchar(mmtime_driftavg,sizeof(mmtime_driftavg),0);
   settimebias := 0;
   gettimezone;
   unixtime := unixtimeint;
   irctime := irctimeint;
 end;
 
+initialization init;
+
 end.