Skip to content
Permalink
Browse files

ensure our faster GetTickCount64 using CLOCK_MONOTONIC_COARSE is called

  • Loading branch information...
Arnaud Bouchez
Arnaud Bouchez committed Feb 22, 2019
1 parent 8971bc0 commit faab82ca27349f4636ad0b06eeb1d368db96c30e
Showing with 59 additions and 53 deletions.
  1. +7 −7 SQLite3/mORMot.pas
  2. +11 −10 SynBidirSock.pas
  3. +19 −15 SynCommons.pas
  4. +12 −13 SynFPCLinux.pas
  5. +1 −1 SynFPCSock.pas
  6. +4 −5 SynKylix.pas
  7. +1 −1 SynProtoRTSPHTTP.pas
  8. +3 −0 Synopse.inc
  9. +1 −1 SynopseCommit.inc
var endtix: Int64;
begin
if fExecuting then begin
endtix := GetTickCount64+maxMS;
endtix := SynCommons.GetTickCount64+maxMS;
repeat
Sleep(1); // wait for InternalExecute to finish
until not fExecuting or (GetTickCount64>=endtix);
until not fExecuting or (SynCommons.GetTickCount64>=endtix);
end;
end;

result := true; // notify Terminated
if (self = nil) or Terminated then
exit;
endtix := GetTickCount64+MS;
endtix := SynCommons.GetTickCount64+MS;
repeat
FixedWaitFor(fEvent,MS);
if Terminated then
exit;
until (MS<32) or (GetTickCount64>=endtix);
until (MS<32) or (SynCommons.GetTickCount64>=endtix);
result := false; // normal delay expiration
end;

{$ifdef WITHLOG}
log := fRest.LogClass.Enter('AsynchBatchStop(%)',[Table],self);
{$endif}
timeout := GetTickCount64+5000;
timeout := SynCommons.GetTickCount64+5000;
if Table=nil then begin // e.g. from TSQLRest.Destroy
if not EnQueue(AsynchBatchExecute,'free@',true) then
exit;
repeat
sleep(1); // wait for all batchs to be released
until (fBackgroundBatch=nil) or (GetTickCount64>timeout);
until (fBackgroundBatch=nil) or (SynCommons.GetTickCount64>timeout);
result := Disable(AsynchBatchExecute);
end else begin
b := AsynchBatchIndex(Table);
if (b<0) or not EnQueue(AsynchBatchExecute,'free@'+Table.SQLTableName,true) then
exit;
repeat
sleep(1); // wait for all pending rows to be sent
until (fBackgroundBatch[b]=nil) or (GetTickCount64>timeout);
until (fBackgroundBatch[b]=nil) or (SynCommons.GetTickCount64>timeout);
if ObjArrayCount(fBackgroundBatch)>0 then
result := true else begin
result := Disable(AsynchBatchExecute);
@@ -1488,7 +1488,7 @@ function TWebSocketFrameList.Pop(protocol: TWebSocketProtocol; const head: RawUT
exit;
if fTimeoutSec=0 then
tix := 0 else
tix := GetTickCount64 shr 10;
tix := {$ifdef FPCLINUX}SynFPCLinux.{$endif}GetTickCount64 shr 10;
Safe.Enter;
try
for i := Count-1 downto 0 do begin
@@ -1517,7 +1517,8 @@ procedure TWebSocketFrameList.Push(const frame: TWebSocketFrame);
SetLength(List,Count+Count shr 3+8);
List[Count] := frame;
if fTimeoutSec>0 then
List[Count].tix := fTimeoutSec+(GetTickCount64 shr 10);
List[Count].tix := fTimeoutSec+
({$ifdef FPCLINUX}SynFPCLinux.{$endif}GetTickCount64 shr 10);
inc(Count);
finally
Safe.Leave;
@@ -2360,7 +2361,7 @@ procedure TWebSocketProcess.ProcessStop;
procedure TWebSocketProcess.HiResDelay(const start: Int64);
var delay: cardinal;
begin
case GetTickCount64-start of
case {$ifdef FPCLINUX}SynFPCLinux.{$endif}GetTickCount64-start of
0..50: delay := 0;
51..200: delay := 1;
201..500: delay := 5;
@@ -2440,7 +2441,7 @@ function TWebSocketProcess.NotifyCallback(aRequest: THttpServerRequest;
result := STATUS_SUCCESS;
exit;
end;
start := GetTickCount64;
start := {$ifdef FPCLINUX}SynFPCLinux.{$endif}GetTickCount64;
if fSettings.CallbackAnswerTimeOutMS=0 then
max := start+30000 else // never wait for ever
if fSettings.CallbackAnswerTimeOutMS<2000 then
@@ -2451,7 +2452,7 @@ function TWebSocketProcess.NotifyCallback(aRequest: THttpServerRequest;
result := STATUS_WEBSOCKETCLOSED;
exit;
end else
if GetTickCount64>max then begin
if {$ifdef FPCLINUX}SynFPCLinux.{$endif}GetTickCount64>max then begin
WebSocketLog.Add.Log(sllWarning,'NotifyCallback TIMEOUT %',[head],self);
if head='answer' then
fIncoming.AnswerToIgnore(1); // ignore next 'answer'
@@ -2775,7 +2776,7 @@ procedure TWebCrtSocketProcess.ProcessLoop;
procedure TWebCrtSocketProcess.SetLastPingTicks(invalidPing: boolean);
begin
fSafePing.Enter;
fLastSocketTicks := GetTickCount64;
fLastSocketTicks := {$ifdef FPCLINUX}SynFPCLinux.{$endif}GetTickCount64;
if invalidPing then begin
inc(fInvalidPingSendCount);
fNoConnectionCloseAtDestroy := true;
@@ -2787,7 +2788,7 @@ procedure TWebCrtSocketProcess.SetLastPingTicks(invalidPing: boolean);
function TWebCrtSocketProcess.LastPingDelay: Int64;
begin
fSafePing.Enter;
result := GetTickCount64-fLastSocketTicks;
result := {$ifdef FPCLINUX}SynFPCLinux.{$endif}GetTickCount64-fLastSocketTicks;
fSafePing.Leave;
end;

@@ -3408,7 +3409,7 @@ procedure TAsynchConnectionsThread.Execute;
SetCurrentThreadName('% % %',[self,fOwner.fProcessName,ToText(fProcess)^]);
fOwner.NotifyThreadStart(self);
try
idletix := GetTickCount64+1000;
idletix := {$ifdef FPCLINUX}SynFPCLinux.{$endif}GetTickCount64+1000;
while not Terminated and (fOwner.fClients<>nil) do begin
// implement parallel client connections for TAsynchClient
if (fOwner.fThreadClients.Count>0) and
@@ -3420,9 +3421,9 @@ procedure TAsynchConnectionsThread.Execute;
fOwner.fClients.ProcessRead(30000);
pseWrite: begin
fOwner.fClients.ProcessWrite(30000);
if GetTickCount64>=idletix then begin
if {$ifdef FPCLINUX}SynFPCLinux.{$endif}GetTickCount64>=idletix then begin
fOwner.IdleEverySecond;
idletix := GetTickCount64+1000;
idletix := {$ifdef FPCLINUX}SynFPCLinux.{$endif}GetTickCount64+1000;
end;
end;
else
begin
if Interval<=0 then
result := false else begin
now := GetTickCount64;
now := {$ifdef FPCLINUX}SynFPCLinux.{$endif}GetTickCount64;
if now-PreviousTix>Interval then begin
PreviousTix := now;
result := true;

function UnixTimeToDateTime(const UnixTime: TUnixTime): TDateTime;
begin
result := (UnixTime / SecsPerDay + UnixDateDelta);
result := UnixTime / SecsPerDay + UnixDateDelta;
end;

function DateTimeToUnixTime(const AValue: TDateTime): TUnixTime;

function UnixMSTimeToDateTime(const UnixMSTime: TUnixMSTime): TDateTime;
begin
result := (UnixMSTime/MSecsPerDay + UnixDateDelta);
result := UnixMSTime/MSecsPerDay + UnixDateDelta;
end;

function UnixMSTimePeriodToString(const UnixTime: TUnixTime; FirstTimeChar: AnsiChar): RawUTF8;
newtimesys: TSystemTime absolute NewTime;
begin
with GlobalTime[LocalTime] do begin
tix := GetTickCount64 {$ifndef MSWINDOWS}shr 3{$endif}; // Linux: 8ms refresh
tix := {$ifdef FPCLINUX}SynFPCLinux.{$endif}GetTickCount64
{$ifndef MSWINDOWS}shr 3{$endif}; // Linux: 8ms refresh
if clock<>tix then begin // Windows: typically in range of 10-16 ms
clock := tix;
NewTime.Clear;
if fRamUsed>fMaxRamUsed then
Reset;
if fTimeoutSeconds>0 then begin
tix := GetTickCount64 shr 10;
tix := {$ifdef FPCLINUX}SynFPCLinux.{$endif}GetTickCount64 shr 10;
if fTimeoutTix>tix then
Reset;
fTimeoutTix := tix+fTimeoutSeconds;
begin
result := fSafe.Padding[DIC_TIMESEC].VInteger;
if result<>0 then
result := cardinal(GetTickCount64 shr 10)+result;
result := cardinal({$ifdef FPCLINUX}SynFPCLinux.{$endif}GetTickCount64 shr 10)+result;
end;

function TSynDictionary.GetCapacity: integer;
if (self=nil) or (fSafe.Padding[DIC_TIMECOUNT].VInteger=0) or // no entry
(fSafe.Padding[DIC_TIMESEC].VInteger=0) then // nothing in fTimeOut[]
exit;
now := GetTickCount64 shr 10;
now := {$ifdef FPCLINUX}SynFPCLinux.{$endif}GetTickCount64 shr 10;
if fSafe.Padding[DIC_TIMETIX].VInteger=integer(now) then
exit; // no need to search more often than every second
fSafe.Lock;
if aUpdateTimeOut and (result>=0) then begin
tim := fSafe.Padding[DIC_TIMESEC].VInteger;
if tim>0 then // inlined fTimeout[result] := GetTimeout
fTimeout[result] := cardinal(GetTickCount64 shr 10)+tim;
fTimeout[result] := cardinal({$ifdef FPCLINUX}SynFPCLinux.{$endif}GetTickCount64 shr 10)+tim;
end;
end;

begin
tim := fSafe.Padding[DIC_TIMESEC].VInteger; // inlined tim := GetTimeout
if tim<>0 then
tim := cardinal(GetTickCount64 shr 10)+tim;
tim := cardinal({$ifdef FPCLINUX}SynFPCLinux.{$endif}GetTickCount64 shr 10)+tim;
ndx := fKeys.FindHashedForAdding(aKey,added);
if added then begin
with fKeys{$ifdef UNDIRECTDYNARRAY}.InternalDynArray{$endif} do
exit;
tim := fSafe.Padding[DIC_TIMESEC].VInteger;
if tim > 0 then
fTimeOut[aIndex] := cardinal(GetTickCount64 shr 10)+tim;
fTimeOut[aIndex] := cardinal({$ifdef FPCLINUX}SynFPCLinux.{$endif}GetTickCount64 shr 10)+tim;
end;

function TSynDictionary.Count: integer;

function TPendingTaskList.GetTimestamp: Int64;
begin
result := GetTickCount64;
result := {$ifdef FPCLINUX}SynFPCLinux.{$endif}GetTickCount64;
end;

procedure TPendingTaskList.AddTask(aMilliSecondsDelayFromNow: integer;

function TSynBackgroundThreadMethodAbstract.OnIdleProcessNotify(start: Int64): integer;
begin
result := GetTickCount64-start;
result := {$ifdef FPCLINUX}SynFPCLinux.{$endif}GetTickCount64-start;
if result<0 then
result := MaxInt; // should happen only under XP -> ignore
if Assigned(fOnIdle) then
// 1. wait for any previous request to be finished (should not happen often)
if Assigned(fOnIdle) then
fOnIdle(self,0); // notify started
start := GetTickCount64;
start := {$ifdef FPCLINUX}SynFPCLinux.{$endif}GetTickCount64;
repeat
case AcquireThread of
flagDestroying:
begin
if (fTask=nil) or Terminated then
exit;
tix := GetTickCount64;
tix := {$ifdef FPCLINUX}SynFPCLinux.{$endif}GetTickCount64;
n := 0;
fTaskLock.Lock;
try
procedure TSynBackgroundTimer.WaitUntilNotProcessing(timeoutsecs: integer);
var timeout: Int64;
begin
if not Processing then
exit;
timeout := GetTickCount64+timeoutsecs*1000;
while Processing and (GetTickcount64<timeout) do
repeat
SleepHiRes(1);
until not Processing or (GetTickcount64>timeout);
end;

function TSynBackgroundTimer.ExecuteNow(aOnProcess: TOnSynBackgroundTimerProcess): boolean;
@@ -98,7 +98,7 @@ function getpagesize: Integer; cdecl; external 'c';
/// compatibility function, wrapping Win32 API high resolution timer
procedure QueryPerformanceCounter(out Value: Int64);

/// compatibility function, wrapping Win32 API high resolution timer
/// slightly faster than QueryPerformanceCounter() div 1000 - but not for Windows
procedure QueryPerformanceCounterMicroSeconds(out Value: Int64);

/// compatibility function, wrapping Win32 API high resolution timer
@@ -198,6 +198,7 @@ procedure DeleteCriticalSection(var cs : TRTLCriticalSection);
D0 = 1461;
D1 = 146097;
D2 = 1721119;
UnixDelta = 25569;

procedure JulianToGregorian(JulianDN: PtrUInt; out result: TSystemTime);
var YYear,XYear,Temp,TempMonth: PtrUInt;
@@ -220,7 +221,7 @@ procedure JulianToGregorian(JulianDN: PtrUInt; out result: TSystemTime);
result.DayOfWeek := 0;
end;

procedure EpochToLocal(epoch: PtrUInt; out result: TSystemTime);
procedure EpochToSystemTime(epoch: PtrUInt; out result: TSystemTime);
var t: PtrUInt;
begin
t := epoch div SecsPerDay;
@@ -234,19 +235,12 @@ procedure EpochToLocal(epoch: PtrUInt; out result: TSystemTime);
result.Second := epoch-t*SecsPerMin;
end;

function GetNowUTC: TDateTime;
var SystemTime: TSystemTime;
begin
GetNowUTCSystem(SystemTime);
result := SystemTimeToDateTime(SystemTime);
end;

procedure GetNowUTCSystem(out result: TSystemTime);
var tz: timeval;
var r: timespec;
begin
fpgettimeofday(@tz,nil);
EpochToLocal(tz.tv_sec,result);
result.MilliSecond := tz.tv_usec div 1000;
clock_gettime(CLOCK_REALTIME_TICKCOUNT,@r); // faster than fpgettimeofday()
EpochToSystemTime(r.tv_sec,result);
result.MilliSecond := r.tv_nsec div 1000000;
end;

function GetTickCount: cardinal;
@@ -373,6 +367,11 @@ procedure QueryPerformanceCounterMicroSeconds(out Value: Int64);

{$endif DARWIN}

function GetNowUTC: TDateTime;
begin
result := GetUnixMSUTC / MSecsPerDay + UnixDelta;
end;

function QueryPerformanceFrequency(out Value: Int64): boolean;
begin
Value := C_BILLION; // 1 second = 1e9 nanoseconds
@@ -90,6 +90,7 @@
interface

uses
SysUtils,
{$ifdef FPC}
BaseUnix,
Unix,
@@ -109,7 +110,6 @@ interface
{$endif}
{$endif}
SyncObjs,
SysUtils,
Classes;

const
@@ -105,6 +105,7 @@ TSystemTime = record
// - this version will return the CLOCK_MONOTONIC value, with a 1 ns resolution
procedure QueryPerformanceCounter(var Value: Int64);

/// slightly faster than QueryPerformanceCounter() div 1000 - but not for Windows
procedure QueryPerformanceCounterMicroSeconds(out Value: Int64);

/// compatibility function, wrapping Win32 API high resolution timer
@@ -194,16 +195,14 @@ procedure QueryPerformanceCounter(var Value: Int64);
procedure QueryPerformanceCounterMicroSeconds(out Value: Int64);
var r : TTimeSpec;
begin
clock_gettime(CLOCK_MONOTONIC,@r);
clock_gettime(CLOCK_MONOTONIC,r);
value := r.tv_nsec div 1000+r.tv_sec*C_MILLION;
end;

function QueryPerformanceFrequency(var Value: Int64): boolean;
var r: TTimeSpec;
begin
result := (clock_getres(CLOCK_MONOTONIC,r)=0) and (r.tv_nsec<>0);
if result then
value := C_BILLION div (r.tv_nsec+(r.tv_sec*C_BILLION));
Value := C_BILLION; // 1 second = 1e9 nanoseconds
result := true;
end;

function SetFilePointer(hFile: THandle; lDistanceToMove: integer;
@@ -277,7 +277,7 @@ function TRTSPOverHTTPServer.ConnectionCreate(aSocket: TSocket;
exit;
fPendingGet.Safe.Lock;
try
now := GetTickCount64 shr 10;
now := SynCommons.GetTickCount64 shr 10;
for i := fPendingGet.Count - 1 downto 0 do begin
old := fPendingGet.ObjectPtr[i];
if now > old.fExpires then begin
Oops, something went wrong.

0 comments on commit faab82c

Please sign in to comment.
You can’t perform that action at this time.