X-Git-Url: http://www.lcore.org/git/lcore.git/blobdiff_plain/4782a5c5afee47721cc617daa40dd29828342c2b..3dd5a60c6c89a29781e099a9e204b09ffbb2e317:/btime.pas?ds=sidebyside diff --git a/btime.pas b/btime.pas old mode 100755 new mode 100644 index 3d672c4..46cdf48 --- a/btime.pas +++ b/btime.pas @@ -7,61 +7,127 @@ this unit returns unix timestamp with seconds and microseconds (as float) works on windows/delphi, and on freepascal on unix. } + unit btime; +{$ifdef fpc} + {$mode delphi} +{$endif} + +{$include lcoreconfig.inc} interface +{$ifdef mswindows} +uses + ltimevalstuff; +{$endif} + type float=extended; + tunixtimeint={$ifdef ver100}longint;{$else}int64;{$endif} + +const + colorburst=39375000/11; {3579545.4545....} var timezone:integer; timezonestr:string; - irctime,unixtime:integer; + irctime,unixtime:tunixtimeint; tickcount:integer; - settimebias:integer; - qpcjump:float; {can be read out and reset for debug purpose} + settimebias:tunixtimeint; performancecountfreq:extended; + btimenowin8:boolean; function irctimefloat:float; -function irctimeint:integer; +function irctimeint:tunixtimeint; +//unix timestamp (UTC) float seconds function unixtimefloat:float; -function unixtimeint:integer; +function unixtimeint:tunixtimeint; +//monotonic float seconds +function monotimefloat:float; + +//monotonic (alias, old function name) function wintimefloat:float; -procedure settime(newtime:integer); +procedure settime(newtime:tunixtimeint); procedure gettimezone; procedure timehandler; procedure init; -function timestring(i:integer):string; -function timestrshort(i:integer):string; +function timestring(i:tunixtimeint):string; // Wednesday August 15 2012 -- 16:21:09 +02:00 +function timestrshort(i:tunixtimeint):string; // Wed Aug 15 16:21:09 2012 +function timestriso(i:tunixtimeint):string; // 2012-08-15 16:21:09 +function timestrisoutc(i:float):string; // 2012-08-15T14:21:09.255553Z + +procedure beginhightimerrate; +procedure endhightimerrate; + +{$ifdef mswindows} +function unixtimefloat_systemtime:float; +{$endif} function oletounixfloat(t:float):float; -function oletounix(t:tdatetime):integer; -function unixtoole(i:integer):tdatetime; +function oletounix(t:tdatetime):tunixtimeint; +function unixtoole(i:float):tdatetime; + +{$ifdef mswindows} +function mmtimefloat:float; +function qpctimefloat:float; +{$endif} + +{$ifdef mswindows} +procedure gettimeofday(var tv:ttimeval); +{$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 -{$ifdef fpc} - {$mode delphi} -{$endif} + uses {$ifdef UNIX} {$ifdef VER1_0} linux, {$else} - baseunix,unix,unixutil,{needed for 2.0.2} + baseunix,unix,unixutil,sockets, {unixutil and sockets needed by unixstuff.inc on some compiler versions} + {$endif} + {$ifdef linux} + dl, {$endif} {$else} - windows, + windows,unitsettc,mmsystem, {$endif} sysutils; @@ -77,16 +143,33 @@ begin result := t; end; -function oletounix(t:tdatetime):integer; +function oletounix(t:tdatetime):tunixtimeint; begin - result := trunc(oletounixfloat(t)); + result := round(oletounixfloat(t)); end; -function unixtoole(i:integer):tdatetime; +function unixtoole(i:float):tdatetime; 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 } @@ -98,12 +181,86 @@ begin result := tv.tv_sec+(tv.tv_usec/1000000); end; -function wintimefloat:extended; -begin - result := unixtimefloat; -end; +{$ifdef linux} + {$define monotimefloat_implemented} + const + CLOCK_MONOTONIC = 1; + type + ptimeval = ^ttimeval; + tclock_gettime = function(clk_id: integer; tp: ptimeval): integer; cdecl; + + var + librt_handle:pointer; + librt_inited:boolean; + clock_gettime: tclock_gettime; + + function monotimefloat:float; + var + ts: ttimeval; + begin + if not librt_inited then begin + librt_inited := true; + clock_gettime := nil; + librt_handle := dlopen('librt.so', RTLD_LAZY); + if assigned(librt_handle) then begin + clock_gettime := dlsym(librt_handle, 'clock_gettime'); + end; + end; + if assigned(clock_gettime) then begin + if clock_gettime(CLOCK_MONOTONIC, @ts) = 0 then begin + //note this really returns nanoseconds + result := ts.tv_sec + ts.tv_usec / 1000000000.0; + exit; + end; + end; + //fallback + result := unixtimefloat; + end; + -function unixtimeint:integer; +{$endif} {linux} + +{$ifdef darwin} {mac OS X} +{$define monotimefloat_implemented} + + type + tmach_timebase_info = packed record + numer: longint; + denom: longint; + end; + pmach_timebase_info = ^tmach_timebase_info; + + function mach_absolute_time: int64; cdecl; external; + function mach_timebase_info(info: pmach_timebase_info): integer; cdecl; external; + + var + timebase_info: tmach_timebase_info; + + function monotimefloat:float; + var + i:int64; + begin + if timebase_info.denom = 0 then begin + mach_timebase_info(@timebase_info); + end; + i := mach_absolute_time; + result := (i * timebase_info.numer div timebase_info.denom) / 1000000000.0; + end; + +{$endif} {darwin, mac OS X} + + +{$ifndef monotimefloat_implemented} {fallback} + + function monotimefloat:extended; + begin + result := unixtimefloat; + end; + +{$endif} {monotimefloat fallback} + + +function unixtimeint:tunixtimeint; var tv:ttimeval; begin @@ -111,10 +268,240 @@ begin result := tv.tv_sec; end; +{------------------------------ end of *nix/freepascal section} + {$else} {delphi 3} {------------------------------ windows/delphi code to read time} -{ free pascals tsystemtime is incomaptible with windows api calls + +{simulate gettimeofday on windows so one can always use gettimeofday if preferred} + +procedure gettimeofday(var tv:ttimeval); +var + e:extended; +begin + e := unixtimefloat; + tv.tv_sec := round(int(e)); + tv.tv_usec := trunc(frac(e)*1000000); + {just in case} + if (tv.tv_usec < 0) then tv.tv_usec := 0; + if (tv.tv_usec > 999999) then tv.tv_usec := 999999; +end; + + +{ +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; + temp:float; +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 begin + {the value we get is rounded to 1 ms, but the ticks are not a multiple of 1 ms + this makes the value noisy. use the known ticks frequency to restore the original value} + temp := int((result / ticks_freq)+0.5) * ticks_freq; + + {if the known ticks freq is wrong (can happen), disable the un-rounding behavior + this will be a bit less accurate but it prevents problems} + if abs(temp - result) > 0.002 then begin + ticks_freq := 0; + end else result := temp; + end; +end; + +procedure measure_ticks_freq; +var + f,g:float; + o:tosversioninfo; + isnt:boolean; +{ is9x:boolean;} + adjust1,adjust2:cardinal; + adjustbool:longbool; +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; + + if (isnt and (o.dwMajorVersion >= 5)) then begin + {windows 2000 and later: query tick rate from OS in 100 ns units + typical rates: XP: 156250 or 100144, windows 7: 156001} + if GetSystemTimeAdjustment(adjust1,adjust2,adjustbool) then begin + ticks_freq := adjust1 / 10000000.0; + ticks_freq_known := true; + mmtime_synchedqpc := false; + end; + end; + + {9x} + if (performancecountfreq = 1193182) and (f >= 0.050) and (f <= 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:float; + qpcjumped:boolean; + a,b: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;} + a := 5; + 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; + mmtime_lastresult := result; +end; + +{ free pascals tsystemtime is incompatible with windows api calls so we declare it ourselves - plugwash } {$ifdef fpc} @@ -160,88 +547,84 @@ begin Result := round(Date_utc) + Time_utc; end; -const - highdwordconst=4294967296.0; +function unixtimefloat_systemtime:float; +begin + {result := oletounixfloat(now_utc);} -function wintimefloat:extended; -var - p:packed record - lowpart:longint; - highpart:longint - end; - p2:tlargeinteger absolute p; - e:extended; + {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; + +function monotimefloat: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; + result := mmqpctimefloat; end; -var - classpriority,threadpriority:integer; -procedure settc; + var - hprocess,hthread:integer; -begin - hProcess := GetCurrentProcess; - hThread := GetCurrentThread; + GetSystemTimePreciseAsFileTime:procedure(var v:tfiletime); stdcall; + win8inited:boolean; - ClassPriority := GetPriorityClass(hProcess); - ThreadPriority := GetThreadPriority(hThread); +procedure initwin8; +var + dllhandle:thandle; - SetPriorityClass(hProcess, REALTIME_PRIORITY_CLASS); - SetThreadPriority(hThread, THREAD_PRIORITY_TIME_CRITICAL); +begin + win8inited := true; + dllhandle := loadlibrary('kernel32.dll'); + if (dllhandle <> 0) then begin + GetSystemTimePreciseAsFileTime := getprocaddress(dllhandle,'GetSystemTimePreciseAsFileTime'); + end; end; -procedure unsettc; + +function unixtimefloat_win8:float; var - hprocess,hthread:integer; + ft:tfiletime; + i:int64 absolute ft; begin - hProcess := GetCurrentProcess; - hThread := GetCurrentThread; - - SetPriorityClass(hProcess, ClassPriority); - SetThreadPriority(hThread, ThreadPriority); + GetSystemTimePreciseAsFileTime(ft); + {change from windows 1601-01-01 to unix 1970-01-01. + use integer math for this, to preserve precision} + dec(i, 116444736000000000); + result := (i / 10000000); end; + + function unixtimefloat:float; +const + margin = 0.0012; var f,g,h:float; begin - if timefloatbias = 0 then begin + if not btimenowin8 then begin + if not win8inited then initwin8; + if assigned(@GetSystemTimePreciseAsFileTime) then begin + result := unixtimefloat_win8; + exit; + end; + end; + + result := monotimefloat+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 := monotimefloat 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; -function unixtimeint:integer; +function unixtimeint:tunixtimeint; begin result := trunc(unixtimefloat); end; @@ -249,20 +632,25 @@ end; {$endif} {-----------------------------------------------end of platform specific} +function wintimefloat:float; +begin + result := monotimefloat; +end; + function irctimefloat:float; begin result := unixtimefloat+settimebias; end; -function irctimeint:integer; +function irctimeint:tunixtimeint; begin result := unixtimeint+settimebias; end; -procedure settime(newtime:integer); +procedure settime(newtime:tunixtimeint); var - a:integer; + a:tunixtimeint; begin a := irctimeint-settimebias; if newtime = 0 then settimebias := 0 else settimebias := newtime-a; @@ -318,7 +706,7 @@ begin timezonestr := timezonestr + char(l div 600 mod 10+48)+char(l div 60 mod 10+48)+':'+char(l div 10 mod 6+48)+char(l mod 10+48); end; -function timestrshort(i:integer):string; +function timestrshort(i:tunixtimeint):string; const weekday:array[0..6] of string[4]=('Thu','Fri','Sat','Sun','Mon','Tue','Wed'); month:array[0..11] of string[4]=('Jan','Feb','Mar','Apr','May','Jun','Jul','Aug','Sep','Oct','Nov','Dec'); @@ -334,7 +722,7 @@ begin inttostr(y); end; -function timestring(i:integer):string; +function timestring(i:tunixtimeint):string; const weekday:array[0..6] of string[10]=('Thursday','Friday','Saturday','Sunday','Monday','Tuesday','Wednesday'); month:array[0..11] of string[10]=('January','February','March','April','May','June','July','August','September','October','November','December'); @@ -350,13 +738,59 @@ begin timezonestr; end; +function timestriso(i:tunixtimeint):string; +var + y,m,d,h,min,sec,ms:word; + t:tdatetime; +begin + t := unixtoole(i+timezone); + decodedate(t,y,m,d); + decodetime(t,h,min,sec,ms); + result := inttostr(y)+'-'+inttostr(m div 10)+inttostr(m mod 10)+'-'+inttostr(d div 10)+inttostr(d mod 10)+' '+inttostr(h div 10)+inttostr(h mod 10)+':'+inttostr(min div 10)+inttostr(min mod 10)+':'+inttostr(sec div 10)+inttostr(sec mod 10); +end; + +function timestrisoutc(i:float):string; +var + y,m,d,h,min,sec,ms:word; + t:tdatetime; + fr:float; +begin + t := unixtoole(i); + decodedate(t,y,m,d); + decodetime(t,h,min,sec,ms); + result := inttostr(y)+'-'+inttostr(m div 10)+inttostr(m mod 10)+'-'+inttostr(d div 10)+inttostr(d mod 10)+'T'+inttostr(h div 10)+inttostr(h mod 10)+':'+inttostr(min div 10)+inttostr(min mod 10)+':'+inttostr(sec div 10)+inttostr(sec mod 10); + fr := frac(i); + + result := result + '.'+ + inttostr(trunc(fr*10) mod 10)+ + inttostr(trunc(fr*100) mod 10)+ + inttostr(trunc(fr*1000) mod 10)+ + inttostr(trunc(fr*10000) mod 10)+ + inttostr(trunc(fr*100000) mod 10)+ + inttostr(trunc(fr*1000000) mod 10)+'Z'; + +end; + +procedure beginhightimerrate; +begin + {$ifdef mswindows}timebeginperiod(1);{$endif} +end; + +procedure endhightimerrate; +begin + {$ifdef mswindows}timeendperiod(1);{$endif} +end; + procedure init; begin - qpcjump := 0; + {$ifdef btimehighrate}beginhightimerrate;{$endif} + fillchar(mmtime_driftavg,sizeof(mmtime_driftavg),0); settimebias := 0; gettimezone; unixtime := unixtimeint; irctime := irctimeint; end; +initialization init; + end.