utils/uutlSyncObjs.pas

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.