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