+\r
+procedure tzinvalidate;\r
+begin\r
+ gettimezone;\r
+end;\r
+\r
+{simulate gettimeofday on windows so one can always use gettimeofday if preferred}\r
+\r
+procedure gettimeofday(var tv:ttimeval);\r
+var\r
+ e:extended;\r
+begin\r
+ e := unixtimefloat;\r
+ tv.tv_sec := round(int(e));\r
+ tv.tv_usec := trunc(frac(e)*1000000);\r
+ {just in case}\r
+ if (tv.tv_usec < 0) then tv.tv_usec := 0;\r
+ if (tv.tv_usec > 999999) then tv.tv_usec := 999999;\r
+end;\r
+\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
+ temp:float;\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 begin\r
+ {the value we get is rounded to 1 ms, but the ticks are not a multiple of 1 ms\r
+ this makes the value noisy. use the known ticks frequency to restore the original value}\r
+ temp := int((result / ticks_freq)+0.5) * ticks_freq;\r
+\r
+ {if the known ticks freq is wrong (can happen), disable the un-rounding behavior\r
+ this will be a bit less accurate but it prevents problems}\r
+ if abs(temp - result) > 0.002 then begin\r
+ ticks_freq := 0;\r
+ end else result := temp;\r
+ end;\r
+end;\r
+\r
+procedure measure_ticks_freq;\r
+var\r
+ f,g:float;\r
+ o:tosversioninfo;\r
+ isnt:boolean;\r
+{ is9x:boolean;}\r
+ adjust1,adjust2:cardinal;\r
+ adjustbool:longbool;\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
+ if (isnt and (o.dwMajorVersion >= 5)) then begin\r
+ {windows 2000 and later: query tick rate from OS in 100 ns units\r
+ typical rates: XP: 156250 or 100144, windows 7: 156001}\r
+ if GetSystemTimeAdjustment(adjust1,adjust2,adjustbool) then begin\r
+ ticks_freq := adjust1 / 10000000.0;\r
+ ticks_freq_known := true;\r
+ mmtime_synchedqpc := false;\r
+ end;\r
+ end;\r
+\r
+ {9x}\r
+ if (performancecountfreq = 1193182) and (f >= 0.050) and (f <= 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:float;\r
+ qpcjumped:boolean;\r
+ a,b: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
+ a := 5;\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
+\r
+ {f := (qpc - mmtime_prev_lastsyncqpc) * mmtime_prev_drift + mmtime_prev_lastsyncmm;\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;\r
+ mmtime_lastresult := result;\r
+end;\r
+\r
+{ free pascals tsystemtime is incompatible with windows api calls\r
lcore.org gitweb / lcore.git / blobdiff