|
- unit uutlSyncObjs;
-
- {$mode objfpc}{$H+}
-
- interface
-
- uses
- Classes, SysUtils, syncobjs,
- uutlGenerics, uutlCommon;
-
- type
- ////////////////////////////////////////////////////////////////////////////////////////////////////////////////////////////////////////////////////////////////
- TutlCheckSynchronizeEvent = class(TObject)
- private
- fEvent: TEvent;
-
- function WaitMainThread(const aTimeout: Cardinal): TWaitResult;
-
- public const
- MAIN_WAIT_GRANULARITY = 10;
-
- public
- procedure SetEvent;
- procedure ResetEvent;
- function WaitFor(const aTimeout: Cardinal): TWaitResult;
-
- constructor Create(
- const aEventAttributes: PSecurityAttributes;
- const aManualReset: Boolean;
- const aInitialState: Boolean;
- const aName: string);
- destructor Destroy; override;
- end;
-
- ////////////////////////////////////////////////////////////////////////////////////////////////////////////////////////////////////////////////////////////////
- TutlEventList = class(specialize TutlSimpleList<TutlCheckSynchronizeEvent>)
- public
- function AddEvent(
- const aEventAttributes: PSecurityAttributes;
- const aManualReset: Boolean;
- const aInitialState: Boolean;
- const aName: String): TutlCheckSynchronizeEvent;
- function AddDefaultEvent: TutlCheckSynchronizeEvent;
- function WaitAll(const aTimeout: Cardinal): TWaitResult;
-
- constructor Create;
- end;
-
- ////////////////////////////////////////////////////////////////////////////////////////////////////////////////////////////////////////////////////////////////
- TAutoResetEvent = class(TEvent)
- public
- constructor Create(const aInitial: boolean = false);
- end;
- // aliased to stay in LCL naming scheme for TSimpleEvent
- TutlAutoResetEvent = TAutoResetEvent;
-
- ////////////////////////////////////////////////////////////////////////////////////////////////////////////////////////////////////////////////////////////////
- IutlLockable = interface(IUnknown)
- ['{CF01F747-D6A9-405B-8A8D-AC148FA9DABB}']
- procedure Lock;
- procedure Unlock;
- end;
-
- ////////////////////////////////////////////////////////////////////////////////////////////////////////////////////////////////////////////////////////////////
- TutlSpinLock = class(
- TutlInterfacedObject
- , IutlLockable)
-
- private
- fLock: DWord;
- fLockReused: integer;
-
- public
- procedure Enter;
- procedure Leave;
- procedure Lock; inline;
- procedure Unlock; inline;
-
- constructor Create;
- destructor Destroy; override;
- end;
-
- ////////////////////////////////////////////////////////////////////////////////////////////////////////////////////////////////////////////////////////////////
- TutlCriticalSection = class(
- TCriticalSection
- , IutlLockable)
-
- strict private
- fRefCount: Integer;
- fAutoFree: Boolean;
-
- public
- function QueryInterface({$IFDEF FPC_HAS_CONSTREF}constref{$ELSE}const{$ENDIF} iid : tguid;out obj) : longint;{$IFNDEF WINDOWS}cdecl{$ELSE}stdcall{$ENDIF};
- function _AddRef: longint;{$IFNDEF WINDOWS}cdecl{$ELSE}stdcall{$ENDIF};
- function _Release: longint;{$IFNDEF WINDOWS}cdecl{$ELSE}stdcall{$ENDIF};
-
- public
- property RefCount: Integer read fRefCount;
- property AutoFree: Boolean read fAutoFree write fAutoFree;
-
- procedure Lock; inline;
- procedure Unlock; inline;
- end;
-
- ////////////////////////////////////////////////////////////////////////////////////////////////////////////////////////////////////////////////////////////////
- generic IutlLock<T> = interface(IUnknown)
- function LockedObject: T;
- end;
-
- ////////////////////////////////////////////////////////////////////////////////////////////////////////////////////////////////////////////////////////////////
- generic TutlLock<T> = class(
- TInterfacedObject,
- specialize IutlLock<T>)
-
- public type
- ILock = specialize IutlLock<T>;
-
- protected
- fLock: IutlLockable;
- fObject: T;
-
- public
- function LockedObject: T; inline;
-
- constructor Create(constref aLock: IutlLockable; constref aObject: T);
- destructor Destroy; override;
-
- class function CreateLock(constref aLock: IutlLockable; constref aObject: T): ILock;
- end;
-
- implementation
-
- ////////////////////////////////////////////////////////////////////////////////////////////////////////////////////////////////////////////////////////////////
- //TutlCheckSynchronizeEvent/////////////////////////////////////////////////////////////////////////////////////////////////////////////////////////////////////
- ////////////////////////////////////////////////////////////////////////////////////////////////////////////////////////////////////////////////////////////////
- function TutlCheckSynchronizeEvent.WaitMainThread(const aTimeout: Cardinal): TWaitResult;
- var
- timeout: qword;
- begin
- timeout:= GetTickCount64 + aTimeout;
- repeat
- result := fEvent.WaitFor(TutlCheckSynchronizeEvent.MAIN_WAIT_GRANULARITY);
- CheckSynchronize();
- until (result <> wrTimeout) or ((GetTickCount64 > timeout) and (aTimeout <> INFINITE));
- end;
-
- ////////////////////////////////////////////////////////////////////////////////////////////////////////////////////////////////////////////////////////////////
- procedure TutlCheckSynchronizeEvent.SetEvent;
- begin
- fEvent.SetEvent;
- end;
-
- ////////////////////////////////////////////////////////////////////////////////////////////////////////////////////////////////////////////////////////////////
- procedure TutlCheckSynchronizeEvent.ResetEvent;
- begin
- fEvent.ResetEvent;
- end;
-
- ////////////////////////////////////////////////////////////////////////////////////////////////////////////////////////////////////////////////////////////////
- function TutlCheckSynchronizeEvent.WaitFor(const aTimeout: Cardinal): TWaitResult;
- begin
- if (GetCurrentThreadId = MainThreadID) then
- result := WaitMainThread(aTimeout)
- else
- result := fEvent.WaitFor(aTimeout);
- end;
-
- ////////////////////////////////////////////////////////////////////////////////////////////////////////////////////////////////////////////////////////////////
- constructor TutlCheckSynchronizeEvent.Create(
- const aEventAttributes: PSecurityAttributes;
- const aManualReset: Boolean;
- const aInitialState: Boolean;
- const aName: string);
- begin
- inherited Create;
- fEvent := TEvent.Create(aEventAttributes, aManualReset, aInitialState, aName);
- end;
-
- ////////////////////////////////////////////////////////////////////////////////////////////////////////////////////////////////////////////////////////////////
- destructor TutlCheckSynchronizeEvent.Destroy;
- begin
- FreeAndNil(fEvent);
- inherited Destroy;
- end;
-
- ////////////////////////////////////////////////////////////////////////////////////////////////////////////////////////////////////////////////////////////////
- //TutlEventList/////////////////////////////////////////////////////////////////////////////////////////////////////////////////////////////////////////////////
- ////////////////////////////////////////////////////////////////////////////////////////////////////////////////////////////////////////////////////////////////
- function TutlEventList.AddEvent(
- const aEventAttributes: PSecurityAttributes;
- const aManualReset: Boolean;
- const aInitialState: Boolean;
- const aName: String): TutlCheckSynchronizeEvent;
- begin
- result := TutlCheckSynchronizeEvent.Create(aEventAttributes, aManualReset, aInitialState, aName);
- Add(result);
- end;
-
- ////////////////////////////////////////////////////////////////////////////////////////////////////////////////////////////////////////////////////////////////
- function TutlEventList.AddDefaultEvent: TutlCheckSynchronizeEvent;
- begin
- result := AddEvent(nil, true, false, '');
- result.ResetEvent;
- end;
-
- ////////////////////////////////////////////////////////////////////////////////////////////////////////////////////////////////////////////////////////////////
- function TutlEventList.WaitAll(const aTimeout: Cardinal): TWaitResult;
- var
- i: integer;
- timeout, tick: qword;
- begin
- result := wrError;
- timeout := GetTickCount64 + aTimeout;
- for i := 0 to Count-1 do begin
- if (aTimeout <> INFINITE) then begin
- tick := GetTickCount64;
- if (tick >= timeout) then begin
- result := wrTimeout;
- exit;
- end else
- result := Items[i].WaitFor(timeout - tick);
- end else
- result := Items[i].WaitFor(INFINITE);
- if result <> wrSignaled then
- exit;
- end;
- end;
-
- ////////////////////////////////////////////////////////////////////////////////////////////////////////////////////////////////////////////////////////////////
- constructor TutlEventList.Create;
- begin
- inherited Create(true);
- end;
-
- ////////////////////////////////////////////////////////////////////////////////////////////////////////////////////////////////////////////////////////////////
- //TAutoResetEvent///////////////////////////////////////////////////////////////////////////////////////////////////////////////////////////////////////////////
- ////////////////////////////////////////////////////////////////////////////////////////////////////////////////////////////////////////////////////////////////
- constructor TAutoResetEvent.Create(const aInitial: boolean);
- begin
- inherited Create(Nil, false, aInitial, '');
- end;
-
- ////////////////////////////////////////////////////////////////////////////////////////////////////////////////////////////////////////////////////////////////
- //TutlSpinLock//////////////////////////////////////////////////////////////////////////////////////////////////////////////////////////////////////////////////
- ////////////////////////////////////////////////////////////////////////////////////////////////////////////////////////////////////////////////////////////////
- procedure TutlSpinLock.Enter;
- var
- ti: DWord;
- begin
- ti := ThreadID;
- if (ti = InterlockedCompareExchange(fLock, ti, ti)) then begin
- {
- The lock is already held by this thread. This means it cannot be modified by a concurrent
- operation (assuming Enter/Leave bracket correctly), and we can act non-atomar on other variables.
- }
- inc(fLockReused);
- end else begin
- while InterlockedCompareExchange(fLock, ti, 0) <> 0 do ;
- end;
- end;
-
- ////////////////////////////////////////////////////////////////////////////////////////////////////////////////////////////////////////////////////////////////
- procedure TutlSpinLock.Leave;
- var
- ti: DWord;
- begin
- ti := ThreadID;
- // Unlock only if we hold the lock
- if (ti = InterlockedCompareExchange(fLock, ti, ti)) then begin
- // our lock, but we haven't yet done anything (note the above is essentially a threadsafe CMP if successful)
- if fLockReused = 0 then
- InterLockedExchange(fLock, 0) // normal lock
- else
- dec(fLockReused); // nested locks
- end;
- end;
-
- ////////////////////////////////////////////////////////////////////////////////////////////////////////////////////////////////////////////////////////////////
- procedure TutlSpinLock.Lock;
- begin
- Enter;
- end;
-
- ////////////////////////////////////////////////////////////////////////////////////////////////////////////////////////////////////////////////////////////////
- procedure TutlSpinLock.Unlock;
- begin
- Leave;
- end;
-
- ////////////////////////////////////////////////////////////////////////////////////////////////////////////////////////////////////////////////////////////////
- constructor TutlSpinLock.Create;
- begin
- inherited Create;
- fLock := 0;
- fLockReused := 0;
- end;
-
- ////////////////////////////////////////////////////////////////////////////////////////////////////////////////////////////////////////////////////////////////
- destructor TutlSpinLock.Destroy;
- begin
- Enter;
- inherited Destroy;
- end;
-
- ////////////////////////////////////////////////////////////////////////////////////////////////////////////////////////////////////////////////////////////////
- //TutlCriticalSection///////////////////////////////////////////////////////////////////////////////////////////////////////////////////////////////////////////
- ////////////////////////////////////////////////////////////////////////////////////////////////////////////////////////////////////////////////////////////////
- function TutlCriticalSection.QueryInterface(constref iid: tguid; out obj): longint; stdcall;
- begin
- if GetInterface(iid,obj)
- then result := S_OK
- else result := longint(E_NOINTERFACE);
- end;
-
- ////////////////////////////////////////////////////////////////////////////////////////////////////////////////////////////////////////////////////////////////
- function TutlCriticalSection._AddRef: longint; stdcall;
- begin
- result := InterLockedIncrement(fRefCount);
- end;
-
- ////////////////////////////////////////////////////////////////////////////////////////////////////////////////////////////////////////////////////////////////
- function TutlCriticalSection._Release: longint; stdcall;
- begin
- result := InterLockedDecrement(fRefCount);
- if (result <= 0) and fAutoFree then
- Destroy;
- end;
-
- ////////////////////////////////////////////////////////////////////////////////////////////////////////////////////////////////////////////////////////////////
- procedure TutlCriticalSection.Lock;
- begin
- Enter;
- end;
-
- ////////////////////////////////////////////////////////////////////////////////////////////////////////////////////////////////////////////////////////////////
- procedure TutlCriticalSection.Unlock;
- begin
- Leave;
- end;
-
- ////////////////////////////////////////////////////////////////////////////////////////////////////////////////////////////////////////////////////////////////
- //TutlLock//////////////////////////////////////////////////////////////////////////////////////////////////////////////////////////////////////////////////////
- ////////////////////////////////////////////////////////////////////////////////////////////////////////////////////////////////////////////////////////////////
- function TutlLock.LockedObject: T;
- begin
- result := fObject;
- end;
-
- ////////////////////////////////////////////////////////////////////////////////////////////////////////////////////////////////////////////////////////////////
- constructor TutlLock.Create(constref aLock: IutlLockable; constref aObject: T);
- begin
- inherited Create;
- if not Assigned(aLock) then
- raise EArgumentNilException.Create('aLock');
- fObject := aObject;
- fLock := aLock;
- fLock.Lock;
- end;
-
- ////////////////////////////////////////////////////////////////////////////////////////////////////////////////////////////////////////////////////////////////
- destructor TutlLock.Destroy;
- begin
- fLock.Unlock;
- inherited Destroy;
- end;
-
- ////////////////////////////////////////////////////////////////////////////////////////////////////////////////////////////////////////////////////////////////
- class function TutlLock.CreateLock(constref aLock: IutlLockable; constref aObject: T): ILock;
- begin
- result := TutlLock.Create(aLock, aObject);
- end;
-
- end.
|