+ Add Simple MonitorSupport implementation

packages/rtl-objpas/examples/monex.pp

@@ -0,0 +1,145 @@
+program TMonitorTest;
+ 
+{$APPTYPE CONSOLE}
+{$mode objfpc} 
+{$h+}
+uses
+{$ifdef unix}
+  cthreads,
+{$endif}  
+ 
+  SysUtils, Classes, fpMonitor;
+ 
+type
+  Drop = class(TObject)
+  private
+    // Message sent from producer to consumer.
+    Msg: string;
+    // True if consumer should wait for producer to send message, false
+    // if producer should wait for consumer to retrieve message.
+    Empty: Boolean;
+  public
+    constructor Create;
+    function Take: string;
+    procedure Put(AMessage: string);
+  end;
+ 
+  Producer = class(TThread)
+  private
+    FDrop: Drop;
+  public
+    constructor Create(ADrop: Drop);
+    procedure Execute; override;
+  end;
+ 
+  Consumer = class(TThread)
+  private
+    FDrop: Drop;
+  public
+    constructor Create(ADrop: Drop);
+    procedure Execute; override;
+  end;
+ 
+{ Drop }
+ 
+constructor Drop.Create;
+begin
+  Empty := True;
+end;
+ 
+function Drop.Take: string;
+begin
+  TMonitor.Enter(Self);
+  try
+    // Wait until message is available.
+    while Empty do
+    begin
+      TMonitor.Wait(Self, INFINITE);
+    end;
+    // Toggle status.
+    Empty := True;
+    // Notify producer that status has changed.
+    TMonitor.PulseAll(Self);
+    Result := Msg;
+  finally
+     TMonitor.Exit(Self);
+  end;
+end;
+ 
+procedure Drop.Put(AMessage: string);
+begin
+  TMonitor.Enter(Self);
+  try
+    // Wait until message has been retrieved.
+    while not Empty do
+    begin
+      TMonitor.Wait(Self, INFINITE);
+    end;
+    // Toggle status.
+    Empty := False;
+    // Store message.
+    Msg := AMessage;
+    // Notify consumer that status has changed.
+    TMonitor.PulseAll(Self);
+  finally
+    TMonitor.Exit(Self);
+  end;
+end;
+ 
+{ Producer }
+ 
+constructor Producer.Create(ADrop: Drop);
+begin
+  FDrop := ADrop;
+  inherited Create(False);
+end;
+ 
+procedure Producer.Execute;
+var
+  Msgs: array of string;
+  I: Integer;
+begin
+  SetLength(Msgs, 4);
+  Msgs[0] := 'Mares eat oats';
+  Msgs[1] := 'Does eat oats';
+  Msgs[2] := 'Little lambs eat ivy';
+  Msgs[3] := 'A kid will eat ivy too';
+  for I := 0 to Length(Msgs) - 1 do
+  begin
+    FDrop.Put(Msgs[I]);
+    Sleep(Random(50{00}));
+  end;
+  FDrop.Put('DONE');
+end;
+ 
+{ Consumer }
+ 
+constructor Consumer.Create(ADrop: Drop);
+begin
+  FDrop := ADrop;
+  inherited Create(False);
+end;
+ 
+procedure Consumer.Execute;
+var
+  Msg: string;
+begin
+  repeat
+    Msg := FDrop.Take;
+    WriteLn('Received: ' + Msg);
+    Sleep(Random(50{00}));
+  until Msg = 'DONE';
+end;
+ 
+var
+  ADrop: Drop;
+ 
+begin
+  Randomize;
+  ADrop := Drop.Create;
+  Producer.Create(ADrop);
+  Consumer.Create(ADrop).WaitFor;
+{$IFDEF WINDOWS}  
+  ReadLn;
+{$ENDIF}
+end.

packages/rtl-objpas/fpmake.pp

@@ -29,7 +29,7 @@ Const
   AllTargetsObjPas = DateUtilsOses +DateUtilOSes+
                   VarutilsOses + ConvutilsOSes + ConvutilOSes + StdConvsOSes+
                   FmtBCDOSes + StrUtilsOSes + UITypesOSes;
-
+  MonitorOSes   = [Win32,win64]+UnixLikes-[BeOS];
   CommonSrcOSes = [atari,emx,gba,go32v2,msdos,nds,netware,wince,nativent,os2,netwlibc,sinclairql,human68k,symbian,watcom,wii,freertos,wasi]+UnixLikes+AllAmigaLikeOSes;
 
 Var
@@ -142,6 +142,7 @@ begin
          AddInclude('invoke.inc',[x86_64],RttiOSes);
        end;
     T.ResourceStrings:=true;
+    T:=P.Targets.AddUnit('fpmonitor.pp',MonitorOSes);
 
     P.NamespaceMap:='namespaces.lst';
     

packages/rtl-objpas/namespaced/System.MonitorSupport.pp

@@ -0,0 +1,3 @@
+unit System.MonitorSupport;
+{$DEFINE FPC_DOTTEDUNITS}
+{$i fpmonitor.pp}

packages/rtl-objpas/namespaces.lst

@@ -14,3 +14,4 @@ src/inc/rtti.pp=namespaced/System.Rtti.pp
 src/inc/widestrutils.pp=namespaced/System.WideStrUtils.pp
 src/inc/syshelpers.pp=namespaced/System.Syshelpers.pp
 src/inc/fmtbcd.pp=namespaced/Data.FMTBcd.pp
+src/inc/fpmonitor.pp=namespaced/System.MonitorSupport.pp

packages/rtl-objpas/src/inc/fpmonitor.pp

@@ -0,0 +1,570 @@
+{$IFNDEF FPC_DOTTEDUNITS}
+unit fpmonitor;
+{$ENDIF}
+
+{$mode objfpc}
+{$modeswitch advancedrecords}
+
+{ $DEFINE MONITOR_STATS}
+{ $DEFINE DEBUG_MONITOR}
+
+interface
+
+{$IFDEF MONITOR_STATS}
+Type
+  TMonitorCall = (mcEnter,mcExit,mcPulse,mcPulseAll,mcEnterTimeout,mcTryEnter,mcWait,mcSetDefaultSpinCount, mcGetDefaultSpinCount, mcWaitLock,mcFreeData);
+
+  TMonitorCallStat = Record
+    CallCount : Integer;
+    LastObject : TObject;
+  end;
+
+  TMonitorCallStatsArray = Array[TMonitorCall] of TMonitorCallStat;
+  TCallStats = record
+    Stats : TMonitorCallStatsArray;
+    Procedure Clear;
+  end;
+
+Procedure GetStats(out aStats : TMonitorCallStatsArray);
+Procedure ClearStats;
+{$ENDIF}
+
+procedure RegisterMonitorSupport;
+procedure UnRegisterMonitorSupport;
+
+implementation
+
+{$IFDEF FPC_DOTTEDUNITS}
+uses System.SysUtils;
+{$ELSE}
+uses sysutils;
+{$ENDIF}
+
+
+Type
+  EMonitor = Class(Exception);
+
+{$IFDEF MONITOR_STATS}
+
+var
+  _Stats : TCallStats;
+
+
+Procedure TCallStats.Clear;
+
+begin
+  Stats:=Default(TMonitorCallStatsArray);
+end;
+
+Procedure SyncStat(aCall : TMonitorCall; aObject : TObject);
+
+begin
+  inc(_stats.Stats[aCall].CallCount);
+  _stats.Stats[aCall].LastObject:=aObject;
+end;
+
+Procedure GetStats(out aStats : TMonitorCallStatsArray);
+
+begin
+  aStats:=_Stats.Stats;
+end;
+
+Procedure ClearStats;
+
+begin
+  _stats.Clear;
+end;
+
+{$ENDIF MONITOR_STATS}
+
+Type
+
+  { TPulseData }
+
+  TPulseData = record
+    Event : PEventState;
+    ThreadID : TThreadID;
+    Class Function Create : TPulseData; static;
+    Procedure Done;
+    function Wait(aTimeout : Cardinal) : boolean;
+    function Match(aPulse : TPulseData) : boolean;
+    Procedure Pulse;
+  end;
+  TPulseDataArray = Array of TPulseData;
+
+  { TMonitorData }
+
+  PMonitorData = ^TMonitorData;
+  TMonitorData = Record
+    LockCount: Integer;
+    LockOwnerThreadID : TThreadID;
+    CriticalSection : TRTLCriticalSection;
+    PulseLock : TRTLCriticalSection;
+    PulseData : TPulseDataArray;
+    PulseCount : Integer;
+    Procedure EnterPulse;
+    Procedure LeavePulse;
+    Procedure Enter;
+    function TryEnter : Boolean;
+    Function Enter(aTimeout : Cardinal) : Boolean;
+    Function Wait(aLock : PMonitorData; aTimeout : Cardinal) : Boolean;
+    Procedure Leave;
+    procedure Init;
+    Procedure Done;
+    Procedure Pulse;
+    Procedure PulseAll;
+  private
+    procedure AddToPulseData(aPulse: TPulseData);
+    function PopPulseData(out aData: TPulseData): Boolean;
+    procedure RemoveFromPulseData(aPulse: TPulseData);
+    procedure ShiftPulseData(Idx: Integer);
+    procedure CheckLockOwner;
+  end;
+
+{ TPulseData }
+
+class function TPulseData.Create: TPulseData;
+begin
+  Result.ThreadID:=GetCurrentThreadId;
+  Result.Event:=RTLEventCreate;
+  if (Result.Event=Nil) then
+    Raise EMonitor.Create('Could not create event');
+end;
+
+procedure TPulseData.Done;
+begin
+  RTLEventDestroy(Event);
+end;
+
+function TPulseData.Wait(aTimeout: Cardinal): boolean;
+
+begin
+  // actually wrSignaled
+  Result:=BasicEventWaitFor(aTimeout,Event,False)=0;
+end;
+
+function TPulseData.Match(aPulse: TPulseData): boolean;
+begin
+  Result:=(aPulse.ThreadID=Self.ThreadID) and (aPulse.Event=Self.Event);
+  {$IFDEF DEBUG_MONITOR}Writeln(StdErr,GetTickCount64,': Thread ',GetCurrentThreadId,' Match ',aPulse.ThreadID,'=',Self.ThreadID,') and (',Ptrint(aPulse.Event),'=',Ptrint(Self.Event),' : ',Result);{$ENDIF}
+end;
+
+procedure TPulseData.Pulse;
+begin
+  BasicEventSetEvent(Event);
+end;
+
+  { TMonitorData }
+
+procedure TMonitorData.EnterPulse;
+begin
+  EnterCriticalSection(PulseLock);
+end;
+
+procedure TMonitorData.LeavePulse;
+begin
+  LeaveCriticalSection(PulseLock);
+end;
+
+procedure TMonitorData.Enter;
+var
+  I : integer;
+  TID : TThreadID;
+  IsOwner : Boolean;
+
+begin
+  TID:=GetCurrentThreadId;
+  IsOwner:=(TID=LockOwnerThreadID);
+  {$IFDEF DEBUG_MONITOR}Writeln(StdErr,GetTickCount64,': Thread ',GetCurrentThreadId,' Begin enter. Is Owner: ',IsOwner);{$ENDIF}
+  if IsOwner then
+    begin
+    I:=AtomicIncrement(LockCount);
+    if I<>1 then
+      begin
+      {$IFDEF DEBUG_MONITOR}Writeln(StdErr,GetTickCount64,': Thread ',GetCurrentThreadId,' Recursive enter detected');{$ENDIF}
+      exit;
+      end;
+    end;
+  {$IFDEF DEBUG_MONITOR}Writeln(StdErr,GetTickCount64,': Thread ',GetCurrentThreadId,' Entering critical section');{$ENDIF}
+  EnterCriticalSection(CriticalSection);
+  LockCount:=1;
+  LockOwnerThreadID:=TID;
+  {$IFDEF DEBUG_MONITOR}Writeln(StdErr,GetTickCount64,': Thread ',GetCurrentThreadId,' Entered critical section');{$ENDIF}
+end;
+
+function TMonitorData.TryEnter: Boolean;
+var
+  TID : TThreadID;
+begin
+  TID:=GetCurrentThreadId;
+  Result:=TID=LockOwnerThreadID;
+  {$IFDEF DEBUG_MONITOR}Writeln(StdErr,GetTickCount64,': Thread ',GetCurrentThreadId,' Begin TryEnter. Is Owner: ',Result);{$ENDIF}
+  if Not Result then
+    begin
+    Result:=TryEnterCriticalSection(CriticalSection)<>0;
+    if Result then
+      begin
+      LockOwnerThreadID:=TID;
+      LockCount:=1;
+      end;
+    end;
+  {$IFDEF DEBUG_MONITOR}Writeln(StdErr,GetTickCount64,': Thread ',GetCurrentThreadId,' End TryEnter. Result: ',Result);{$ENDIF}
+end;
+
+function TMonitorData.Enter(aTimeout: Cardinal): Boolean;
+
+var
+  Start : Int64;
+
+begin
+  {$IFDEF DEBUG_MONITOR}Writeln(StdErr,GetTickCount64,': Thread ',GetCurrentThreadId,' Begin Enter(',aTimeout,')');{$ENDIF}
+  Start:=GetTickCount64;
+  Repeat
+     Result:=TryEnter;
+     if not Result then
+       Sleep(2);
+  until Result or ((GetTickCount64-Start)>aTimeout);
+  {$IFDEF DEBUG_MONITOR}Writeln(StdErr,GetTickCount64,': Thread ',GetCurrentThreadId,' End Enter(',aTimeout,'), Result: ',Result);{$ENDIF}
+end;
+
+procedure TMonitorData.ShiftPulseData(Idx: Integer);
+// Only call this inside EnterPulse/Leavepulse !
+
+begin
+  // Not sure if we need to preserve order. Better assume yes.
+  // shift items. If need be, this can be done with a move.
+  While Idx<PulseCount-1 do
+    begin
+    PulseData[Idx]:=PulseData[Idx+1];
+    Inc(Idx);
+    end;
+  Dec(PulseCount);
+end;
+
+procedure TMonitorData.CheckLockOwner;
+begin
+  if LockOwnerThreadID<>GetCurrentThreadId then
+    Raise EMonitor.CreateFmt('Lock not owned by this thread %d <> %d',[LockOwnerThreadID,GetCurrentThreadId]);
+end;
+
+function TMonitorData.PopPulseData (out aData : TPulseData) : Boolean;
+
+begin
+  {$IFDEF DEBUG_MONITOR}Writeln(StdErr,GetTickCount64,': Thread ',GetCurrentThreadId,' Begin PopPulseData');{$ENDIF}
+  EnterPulse;
+  try
+   Result:=PulseCount>0;
+   if Result then
+     begin
+     aData:=PulseData[0];
+     ShiftPulseData(0);
+     end;
+  finally
+    LeavePulse;
+  end;
+  {$IFDEF DEBUG_MONITOR}Writeln(StdErr,GetTickCount64,': Thread ',GetCurrentThreadId,' End PopPulseData Result: ',Result,', left:',PulseCount);{$ENDIF}
+end;
+
+procedure TMonitorData.RemoveFromPulseData(aPulse: TPulseData);
+
+var
+  Idx : integer;
+
+begin
+  EnterPulse;
+  try
+    {$IFDEF DEBUG_MONITOR}Writeln(StdErr,GetTickCount64,': Thread ',GetCurrentThreadId,' Begin RemoveFromPulseData (Thread: ',aPulse.ThreadID,', count: ',PulseCount,')');{$ENDIF}
+    // Find index
+    Idx:=PulseCount-1;
+    While (Idx>=0) and Not PulseData[Idx].Match(aPulse) do
+      Dec(Idx);
+    if Idx<0 then
+      begin
+      {$IFDEF DEBUG_MONITOR}Writeln(StdErr,GetTickCount64,': Thread ',GetCurrentThreadId,' end RemoveFromPulseData. Count: ',PulseCount);{$ENDIF}
+      exit;
+      end;
+    PulseData[Idx].Done;
+    ShiftPulseData(Idx);
+  finally
+    LeavePulse;
+  end;
+  {$IFDEF DEBUG_MONITOR}Writeln(StdErr,GetTickCount64,': Thread ',GetCurrentThreadId,' end RemoveFromPulseData. Count: ',PulseCount);{$ENDIF}
+end;
+
+procedure TMonitorData.AddToPulseData(aPulse: TPulseData);
+
+var
+  Len : integer;
+
+begin
+  {$IFDEF DEBUG_MONITOR}Writeln(StdErr,GetTickCount64,': Thread ',GetCurrentThreadId,' Begin AddToPulseData (Thread: ',aPulse.ThreadID,')');{$ENDIF}
+  EnterPulse;
+  try
+    Len:=Length(PulseData);
+    If PulseCount=Len then
+      SetLength(PulseData,Len+10);
+    PulseData[PulseCount]:=aPulse;
+    Inc(PulseCount);
+  finally
+    LeavePulse;
+  end;
+  {$IFDEF DEBUG_MONITOR}Writeln(StdErr,GetTickCount64,': Thread ',GetCurrentThreadId,' End AddToPulseData. Count: ',PulseCount);{$ENDIF}
+end;
+
+function TMonitorData.Wait(aLock : PMonitorData; aTimeout: Cardinal): Boolean;
+
+var
+  aPulse : TPulseData;
+
+begin
+  {$IFDEF DEBUG_MONITOR}Writeln(StdErr,GetTickCount64,': Thread ',GetCurrentThreadId,' Begin Wait (aTimeout: ',aTimeOut,')');{$ENDIF}
+  aLock^.CheckLockOwner;
+  aPulse:=TPulseData.Create;
+  AddToPulseData(aPulse);
+  aLock^.Leave;
+  Result:=aPulse.Wait(aTimeOut);
+  Sleep(20);
+  {$IFDEF DEBUG_MONITOR}Writeln(StdErr,GetTickCount64,': Thread ',GetCurrentThreadId,' Wait Removing from Pulse data');{$ENDIF}
+  RemoveFromPulseData(aPulse);
+  aLock^.Enter;
+  {$IFDEF DEBUG_MONITOR}Writeln(StdErr,GetTickCount64,': Thread ',GetCurrentThreadId,' End Wait (aTimeout: ',aTimeOut,')');{$ENDIF}
+end;
+
+procedure TMonitorData.Leave;
+
+var
+  I : integer;
+
+begin
+  {$IFDEF DEBUG_MONITOR}Writeln(StdErr,GetTickCount64,': Thread ',GetCurrentThreadId,' Begin Leave. Is owner: ',GetCurrentThreadID=LockOwnerThreadID);{$ENDIF}
+  CheckLockOwner;
+  I:=AtomicDecrement(LockCount);
+  {$IFDEF DEBUG_MONITOR}if I>0 then Writeln(StdErr,GetTickCount64,': Thread ',GetCurrentThreadId,' Owner holds recursive lock: ',I);{$ENDIF}
+  if I<>0 then
+    Exit;
+  {$IFDEF DEBUG_MONITOR}Writeln(StdErr,GetTickCount64,': Thread ',GetCurrentThreadId,' Leaving critical section');{$ENDIF}
+  LockOwnerThreadID:=TThreadID(0);
+  LockCount:=0;
+  LeaveCriticalSection(CriticalSection);
+  {$IFDEF DEBUG_MONITOR}Writeln(StdErr,GetTickCount64,': Thread ',GetCurrentThreadId,' End Leave. Is owner: ',GetCurrentThreadID=LockOwnerThreadID);{$ENDIF}
+end;
+
+procedure TMonitorData.Init;
+begin
+  LockCount:=0;
+  LockOwnerThreadID:= TThreadID(0);
+  InitCriticalSection(CriticalSection);
+  InitCriticalSection(PulseLock);
+  PulseCount:=0;
+end;
+
+procedure TMonitorData.Done;
+
+var
+  I : integer;
+
+begin
+  {$IFDEF DEBUG_MONITOR}Writeln(StdErr,GetTickCount64,': Thread ',GetCurrentThreadId,' Begin Done monitor data');{$ENDIF}
+  // We don't lock as normally this is only called when object is destroyed.
+  For I:=0 to PulseCount-1 do
+    PulseData[i].Done;
+  SetLength(PulseData,0);
+  DoneCriticalSection(PulseLock);
+  DoneCriticalSection(CriticalSection);
+  {$IFDEF DEBUG_MONITOR}Writeln(StdErr,GetTickCount64,': Thread ',GetCurrentThreadId,' End Done monitor data');{$ENDIF}
+end;
+
+procedure TMonitorData.Pulse;
+
+var
+  aPulse : TPulseData;
+  HavePulse: Boolean;
+begin
+  {$IFDEF DEBUG_MONITOR}Writeln(StdErr,GetTickCount64,': Thread ',GetCurrentThreadId,' Begin Pulse');{$ENDIF}
+  HavePulse:=PopPulseData(aPulse);
+  if HavePulse then
+    aPulse.Pulse;
+  {$IFDEF DEBUG_MONITOR}Writeln(StdErr,GetTickCount64,': Thread ',GetCurrentThreadId,' End Pulse (had pulse: ',HavePulse,')');{$ENDIF}
+end;
+
+procedure TMonitorData.PulseAll;
+
+var
+  aPulse : TPulseData;
+  aCount : Integer;
+begin
+  {$IFDEF DEBUG_MONITOR}Writeln(StdErr,GetTickCount64,': Thread ',GetCurrentThreadId,' Begin PulseAll');{$ENDIF}
+  aCount:=0;
+  While PopPulseData(aPulse) do
+    begin
+    aPulse.Pulse;
+    Inc(aCount);
+    end;
+  {$IFDEF DEBUG_MONITOR}Writeln(StdErr,GetTickCount64,': Thread ',GetCurrentThreadId,' End PulseAll (Pulse count: ',aCount,')');{$ENDIF}
+end;
+
+
+var
+  _oldMonitor,
+  _monitor : TMonitorManager;
+  _DummySpinCount : Integer;
+  _MemLock : TRTLCriticalSection;
+
+function GetMonitorData(aObject : TObject) : PMonitorData; inline;
+
+begin
+  Result:=PMonitorData(_monitor.DoGetMonitorObjectData(aObject));
+end;
+
+procedure SetMonitorData(aObject : TObject; aData : PMonitorData); inline;
+
+begin
+  _monitor.DoSetMonitorObjectData(aObject,aData);
+end;
+
+function SyncEnsureData(aObject : TObject) : PMonitorData;
+
+begin
+  EnterCriticalSection(_MemLock);
+  try
+    Result:=GetMonitorData(aObject);
+    if Result=Nil then
+      begin
+      // At some point we could cache this.
+      GetMem(Result,SizeOf(TMonitorData));
+      Result^:=Default(TMonitorData);
+      Result^.Init;
+      SetMonitorData(aObject,Result);
+      end;
+  finally
+    LeaveCriticalSection(_MemLock);
+  end;
+end;
+
+procedure SyncFreeData(aData : PMonitorData);
+begin
+  aData^.Done;
+  FreeMem(aData);
+end;
+
+
+procedure SyncEnter(const aObject : TObject);
+
+begin
+  {$IFDEF MONITOR_STATS}syncStat(mcEnter,aObject);{$ENDIF}
+  SyncEnsureData(aObject)^.Enter;
+end;
+
+procedure syncLeave(const aObject : TObject);
+
+begin
+  {$IFDEF MONITOR_STATS}syncStat(mcExit,aObject);{$ENDIF}
+  SyncEnsureData(aObject)^.Leave;
+end;
+
+procedure syncPulse(const aObject : TObject);
+
+begin
+  {$IFDEF MONITOR_STATS}syncStat(mcPulse,aObject);{$ENDIF}
+  SyncEnsureData(aObject)^.Pulse;
+end;
+
+procedure syncPulseAll(const aObject : TObject);
+
+begin
+  {$IFDEF MONITOR_STATS}syncStat(mcPulseAll,aObject);{$ENDIF}
+  SyncEnsureData(aObject)^.PulseAll;
+end;
+
+
+function syncTryEnter(const aObject : TObject) : Boolean;
+
+begin
+  {$IFDEF MONITOR_STATS}syncStat(mcTryEnter,aObject);{$ENDIF}
+  Result:=SyncEnsureData(aObject)^.TryEnter;
+end;
+
+function syncEnterTimeout(const aObject : TObject; aTimeout : Cardinal) : Boolean;
+
+begin
+  Result:=False;
+  {$IFDEF MONITOR_STATS}syncStat(mcEnterTimeout,aObject);{$ENDIF}
+  Result:=SyncEnsureData(aObject)^.Enter(aTimeout);
+end;
+
+function syncWaitTimeout(const aObject : TObject; aTimeout : Cardinal) : Boolean;
+
+var
+  aLock : PMonitorData;
+
+begin
+  Result:=False;
+  {$IFDEF MONITOR_STATS}syncStat(mcWait,aObject);{$ENDIF}
+  aLock:=SyncEnsureData(aObject);
+  Result:=aLock^.Wait(aLock,aTimeout);
+end;
+
+function syncDowaitLock(const aObject,aLock : TObject; aTimeout : Cardinal) : Boolean;
+
+begin
+  Result:=False;
+  {$IFDEF MONITOR_STATS}syncStat(mcWaitLock,aObject);{$ENDIF}
+  Result:=SyncEnsureData(aObject)^.Wait(SyncEnsureData(aLock),aTimeout);
+end;
+
+function syncGetDefaultSpinCount : Longint;
+begin
+  Result:=_DummySpinCount;
+  {$IFDEF MONITOR_STATS}syncStat(mcGetDefaultSpinCount,Nil);{$ENDIF}
+end;
+
+procedure syncSetDefaultSpinCount(const aValue : Longint);
+begin
+  {$IFDEF MONITOR_STATS}syncStat(mcSetDefaultSpinCount,Nil);{$ENDIF}
+  _DummySpinCount:=aValue;
+end;
+
+procedure syncFreeMonitorData(aData: Pointer);
+begin
+  {$IFDEF MONITOR_STATS}syncStat(mcFreeData,Nil);{$ENDIF}
+  if Assigned(aData) then
+    SyncFreeData(PMonitorData(aData));
+end;
+
+Procedure InitMonitorSupport;
+
+begin
+  _Monitor.DoEnter:=@syncEnter;
+  _Monitor.DoExit:=@syncLeave;
+  _Monitor.DoPulse:=@syncPulse;
+  _Monitor.DoPulseAll:=@syncPulseAll;
+  _Monitor.DoEnterTimeout:=@syncEnterTimeout;
+  _Monitor.DoTryEnter:=@syncTryEnter;
+  _Monitor.DoWait:=@syncWaitTimeout;
+  _Monitor.DoSetDefaultSpinCount:=@syncSetDefaultSpinCount;
+  _Monitor.DoGetDefaultSpinCount:=@syncGetDefaultSpinCount;
+  _Monitor.DoWaitLock:=@syncDowaitLock;
+  _Monitor.DoFreeMonitorData:=@syncFreeMonitorData;
+end;
+
+procedure RegisterMonitorSupport;
+
+begin
+  InitCriticalSection(_MemLock);
+  InitMonitorSupport;
+  _OldMonitor:=SetMonitorManager(_Monitor);
+end;
+
+procedure UnRegisterMonitorSupport;
+
+begin
+  DoneCriticalSection(_MemLock);
+  SetMonitorManager(_oldMonitor);
+end;
+
+Initialization
+  RegisterMonitorSupport;
+finalization
+  UnRegisterMonitorSupport;
+
+end.

packages/rtl-objpas/tests/testrunner.rtlobjpas.lpi

@@ -0,0 +1,63 @@
+<?xml version="1.0" encoding="UTF-8"?>
+<CONFIG>
+  <ProjectOptions>
+    <Version Value="12"/>
+    <General>
+      <Flags>
+        <MainUnitHasCreateFormStatements Value="False"/>
+        <MainUnitHasTitleStatement Value="False"/>
+        <MainUnitHasScaledStatement Value="False"/>
+        <UseDefaultCompilerOptions Value="True"/>
+      </Flags>
+      <SessionStorage Value="InProjectDir"/>
+      <Title Value="testrunner.rtlobjpas"/>
+      <UseAppBundle Value="False"/>
+      <ResourceType Value="res"/>
+    </General>
+    <BuildModes>
+      <Item Name="Default" Default="True"/>
+    </BuildModes>
+    <PublishOptions>
+      <Version Value="2"/>
+      <UseFileFilters Value="True"/>
+    </PublishOptions>
+    <RunParams>
+      <FormatVersion Value="2"/>
+    </RunParams>
+    <Units>
+      <Unit>
+        <Filename Value="testrunner.rtlobjpas.pp"/>
+        <IsPartOfProject Value="True"/>
+      </Unit>
+    </Units>
+  </ProjectOptions>
+  <CompilerOptions>
+    <Version Value="11"/>
+    <Target>
+      <Filename Value="testrunner.rtlobjpas"/>
+    </Target>
+    <SearchPaths>
+      <IncludeFiles Value="$(ProjOutDir)"/>
+      <OtherUnitFiles Value="../src/inc"/>
+      <UnitOutputDirectory Value="lib/$(TargetCPU)-$(TargetOS)"/>
+    </SearchPaths>
+    <Other>
+      <ConfigFile>
+        <WriteConfigFilePath Value=""/>
+      </ConfigFile>
+    </Other>
+  </CompilerOptions>
+  <Debugging>
+    <Exceptions>
+      <Item>
+        <Name Value="EAbort"/>
+      </Item>
+      <Item>
+        <Name Value="ECodetoolError"/>
+      </Item>
+      <Item>
+        <Name Value="EFOpenError"/>
+      </Item>
+    </Exceptions>
+  </Debugging>
+</CONFIG>

packages/rtl-objpas/tests/testrunner.rtlobjpas.pp

@@ -19,8 +19,13 @@ program testrunner.rtlobjpas;
 {$endif}
 {$endif}
 
+{$IF DEFINED(WINDOWS) or DEFINED(UNIX)}
+{$DEFINE HAS_MONITOR}
+{$ENDIF}
+
 uses
-{$ifdef unix} 
+{$ifdef unix}
+  cthreads,
   cwstring,
 {$endif}
 {$ifdef useffi}
@@ -41,7 +46,13 @@ uses
   utcmatrix,
   utcpoint,
   utcvector,
-  utcquaternion;
+  utcquaternion,
+{$IFDEF HAS_MONITOR}
+  utcfpmonitor
+{$ENDIF}
+
+;
+
 
 var
   Application: TTestRunner;

packages/rtl-objpas/tests/utcfpmonitor.pas

@@ -0,0 +1,362 @@
+unit utcfpmonitor;
+
+{$mode ObjFPC}{$H+}
+{ $DEFINE DEBUG_MONITOR}
+
+interface
+
+uses
+  Classes, SysUtils, fpcunit, testregistry, fpmonitor;
+
+const
+  WaitPeriod = 10;
+  WaitTimeout = 2000;
+  MaxObjCount = 2;
+  MaxThrdCount = 5;
+
+Type
+  TThreadOperation = (toNone,toEnter,toTryEnter,toExit,toPulse,toWait,toPulseAll);
+  TOperationResult = Record
+    Op : TThreadOperation;
+    Tick : Int64;
+    Res : Boolean;
+  end;
+
+  TTestObject = Class(TObject)
+    // Operation/Timestamp when a thread performed a task
+    Res : Array[1..MaxThrdCount] of TOperationResult;
+  end;
+
+  { TTestThread }
+  TTestThread = Class(TThread)
+  Private
+    FObj : TTestObject;
+    FOperation : TThreadOperation;
+    FTimeout : Integer;
+    FID : Integer;
+    Constructor Create(aObj : TTestObject; aOperation : TThreadOperation; aId,aTimeout : Integer; aOnFree : TNotifyEvent);
+  Public
+    Procedure Execute; override;
+  end;
+  { TTestMonitorSupport }
+
+  TTestMonitorSupport = Class(TTestCase)
+  private
+    FThrdCount : Integer;
+    FObj : Array[1..MaxObjCount] of  TTestObject;
+    FThrd : Array[1..MaxThrdCount] of TThread;
+    function DoCreateThread(aObj: TTestObject; aOperation: TThreadOperation; aId, aTimeout: Integer): TTestThread;
+    class procedure AssertEquals(Msg: String; aExpected, aActual: TThreadOperation); overload;
+    function GetObj(AIndex: Integer): TTestObject;
+    procedure ThreadDone(Sender : TObject);
+    procedure WaitForAllThreads(aTimeOut: Integer=0);
+  public
+    Procedure Setup; override;
+    Procedure TearDown; override;
+    Property Obj1 : TTestObject Index 1 Read GetObj;
+    Property Obj2 : TTestObject Index 2 Read GetObj;
+  Published
+    Procedure TestHookup;
+    Procedure TestLock;
+    Procedure TestLockMulti;
+    Procedure TestTryLock;
+    Procedure TestPulse;
+    Procedure TestPulseAll;
+    procedure TestWait;
+  end;
+
+implementation
+
+Uses TypInfo;
+
+{ TTestThread }
+
+constructor TTestThread.Create(aObj: TTestObject; aOperation: TThreadOperation; aId,aTimeout: Integer; aOnFree : TNotifyEvent);
+begin
+  FObj:=aObj;
+  FOperation:=aOperation;
+  FTimeout:=aTimeout;
+  FID:=aID;
+  FreeOnTerminate:=True;
+  OnTerminate:=aOnfree;
+  Inherited Create(false);
+end;
+
+procedure TTestThread.Execute;
+
+var
+  OpRes : TOperationResult;
+
+begin
+  {$IFDEF DEBUG_MONITOR}  Writeln(StdErr,GetTickCount64,': Thread ',GetCurrentThreadID,' Begin executing operation ',FOperation);{$ENDIF}
+  try
+    OpRes.Res:=True;
+    Case FOperation of
+      toEnter : TMonitor.Enter(Fobj);
+      toTryEnter : OpRes.Res:=TMonitor.TryEnter(Fobj);
+      toExit  : TMonitor.Exit(Fobj);
+      toPulse  : begin
+                 Sleep(WaitPeriod * 2);
+                 TMonitor.Pulse(Fobj);
+                 end;
+      toPulseAll  :
+                 begin
+                 TMonitor.Enter(Fobj);
+                 OpRes.Res:=TMonitor.Wait(FObj,FTimeout);
+                 end;
+       toWait :
+         begin
+         TMonitor.Enter(Fobj);
+         OpRes.Res:=TMonitor.Wait(FObj,FTimeout);
+         end;
+    end;
+    OpRes.Tick:=GetTickCount64;
+    OpRes.Op:=FOperation;
+    FObj.Res[FID]:=OpRes;
+    // We need to clean up !
+    Case FOperation of
+      toEnter,
+      toWait,
+      toPulseAll,
+      toTryEnter:
+        begin
+        if OpRes.Res then
+          begin
+          TMonitor.Exit(Fobj);
+            {$IFDEF DEBUG_MONITOR}  Writeln(StdErr,GetTickCount64,': Thread ',GetCurrentThreadID,' Unlocking previously locked object ',FOperation);{$ENDIF}
+          end;
+        end;
+    else
+      //
+    end;
+
+  except
+    On E : Exception do
+      Writeln(StdErr,GetTickCount64,': Thread ',GetCurrentThreadID,' exception ',E.ClassName,' during operation ',FOperation,' : ',E.Message);
+  end;
+  {$IFDEF DEBUG_MONITOR}Writeln(StdErr,GetTickCount64,': Thread ',GetCurrentThreadID,' End executing operation ',FOperation);{$ENDIF}
+end;
+
+{ TTestMonitorSupport }
+
+function TTestMonitorSupport.GetObj(AIndex: Integer): TTestObject;
+begin
+  Result:=FObj[aIndex];
+end;
+
+procedure TTestMonitorSupport.ThreadDone(Sender: TObject);
+
+var
+  aCount,I : Integer;
+
+begin
+  aCount:=0;
+  {$IFDEF DEBUG_MONITOR}Writeln(StdErr,GetTickCount64,': Thread ',GetCurrentThreadID,' Begin done executing');{$ENDIF}
+  For I:=1 to MaxThrdCount do
+    begin
+    if FThrd[i]=Sender then
+      begin
+      {$IFDEF DEBUG_MONITOR}Writeln(StdErr,GetTickCount64,': Thread ',GetCurrentThreadID,' Done executing: found thread at ',I){$ENDIF};
+      FThrd[i]:=Nil;
+      end
+    else if assigned(FThrd[I]) then
+      inc(aCount);
+    end;
+  {$IFDEF DEBUG_MONITOR}Writeln(StdErr,GetTickCount64,': Thread ',GetCurrentThreadID,' End done executing. Threads still active: ',aCount);{$ENDIF}
+end;
+
+procedure TTestMonitorSupport.WaitForAllThreads(aTimeOut : Integer = 0);
+
+var
+  I : Integer;
+  Last,Start : Int64;
+  TimeOut,OK : Boolean;
+
+begin
+  If aTimeOut=0 then
+    aTimeout:=WaitTimeout;
+  Start:=GetTickCount64;
+  {$IFDEF DEBUG_MONITOR}  Writeln(StdErr,Start,': Thread ',GetCurrentThreadID,' Waiting for ', FThrdCount,' threads to stop');{$ENDIF}
+  Timeout:=False;
+  Repeat
+    OK:=True;
+    CheckSynchronize(5);
+    For I:=1 to MaxThrdCount do
+      OK:=OK and (FThrd[i]=Nil);
+    if not Ok then
+      begin
+      sleep(10);
+      Last:=GetTickCount64;
+      TimeOut:=(Last-Start)>aTimeout;
+      end;
+  Until OK or TimeOut;
+  {$IFDEF DEBUG_MONITOR}
+  if not OK then
+    Writeln(StdErr,Last,': Thread ',GetCurrentThreadId,' Not all threads stopped');
+  {$ENDIF}
+end;
+
+
+procedure TTestMonitorSupport.Setup;
+
+var
+  I : Integer;
+
+begin
+  inherited Setup;
+  FThrdCount:=0;
+  For I:=1 to MaxObjCount do
+    FObj[i]:=TTestObject.Create;
+  For I:=1 to MaxThrdCount do
+    FThrd[i]:=Nil;
+end;
+
+procedure TTestMonitorSupport.TearDown;
+
+var
+  I : Integer;
+
+begin
+  FThrdCount:=0;
+  For I:=1 to MaxObjCount do
+    FreeAndNil(FObj[i]);
+  For I:=1 to MaxThrdCount do
+    FThrd[i]:=Nil;
+  inherited TearDown;
+end;
+
+procedure TTestMonitorSupport.TestHookup;
+
+var
+  I : integer;
+
+begin
+  For I:=1 to MaxObjCount do
+    AssertNotNull('Obj '+IntToStr(i),FObj[I]);
+  For I:=1 to MaxThrdCount do
+    AssertNull('Thrd '+IntToStr(i),FThrd[I]);
+end;
+
+function TTestMonitorSupport.DoCreateThread(aObj: TTestObject; aOperation: TThreadOperation; aId, aTimeout: Integer): TTestThread;
+
+begin
+  Inc(FThrdCount);
+  FThrd[FThrdCount]:=TTestThread.Create(aObj,aOperation,Aid,aTimeout,@ThreadDone);
+  Result:=TTestThread(FThrd[FThrdCount]);
+end;
+
+class procedure TTestMonitorSupport.AssertEquals(Msg: String; aExpected, aActual: TThreadOperation);
+begin
+  AssertEquals(Msg,GetEnumName(TypeInfo(TOperationResult),Ord(aExpected)),
+                   GetEnumName(TypeInfo(TOperationResult),Ord(aActual)));
+end;
+
+procedure TTestMonitorSupport.TestLock;
+
+var
+  N : Int64;
+
+begin
+  TMonitor.Enter(Obj1);
+  DoCreateThread(Obj1,toEnter,1,0);
+  Sleep(WaitPeriod);
+  N:=GetTickCount64;
+  TMonitor.Exit(Obj1);
+  WaitForAllThreads;
+  AssertTrue('Thread lock timestamp ',N<=FObj[1].Res[1].Tick);
+  AssertEquals('Thread did a lock ',toEnter,Obj1.Res[1].Op);
+end;
+
+procedure TTestMonitorSupport.TestLockMulti;
+
+var
+  N : Int64;
+  I : integer;
+
+begin
+  TMonitor.Enter(Obj1);
+  For I:=1 to MaxThrdCount do
+    DoCreateThread(Obj1,toEnter,I,0);
+  Sleep(WaitPeriod);
+  N:=GetTickCount64;
+  TMonitor.Exit(Obj1);
+  WaitForAllThreads;
+  AssertTrue('Thread lock timestamp ',N<=FObj[1].Res[1].Tick);
+  AssertEquals('Thread did a lock ',toEnter,Obj1.Res[1].Op);
+end;
+
+procedure TTestMonitorSupport.TestTryLock;
+
+begin
+  TMonitor.Enter(Obj1);
+  DoCreateThread(Obj1,toTryEnter,1,0);
+  Sleep(WaitPeriod);
+  TMonitor.Exit(Obj1);
+  Writeln(GetTickCount64,': Thread ',GetCurrentThreadID,' Released lock');
+  WaitForAllThreads;
+  AssertEquals('Thread tried a lock ',toTryEnter,Obj1.Res[1].Op);
+  AssertFalse('Thread lock failed ',Obj1.Res[1].Res);
+end;
+
+procedure TTestMonitorSupport.TestPulse;
+
+var
+  N : Int64;
+
+begin
+  // Acquire the lock
+  TMonitor.Enter(Obj1);
+  DoCreateThread(Obj1,toPulse,1,INFINITE);
+  Sleep(WaitPeriod);
+  N:=GetTickCount64;
+  TMonitor.Wait(Obj1,500);
+  TMonitor.Exit(Obj1);
+  WaitForAllThreads;
+  AssertTrue('Thread pulse timestamp ',N<=FObj[1].Res[1].Tick);
+  AssertEquals('Thread did a pulse',toPulse,Obj1.Res[1].Op);
+  AssertTrue('Thread Wait was successful',Obj1.Res[1].Res);
+end;
+
+procedure TTestMonitorSupport.TestPulseAll;
+
+var
+  N : Int64;
+  i : integer;
+
+begin
+   // Acquire the lock
+  For I:=1 to MaxThrdCount do
+    DoCreateThread(Obj1,toPulseAll,I,INFINITE);
+  Sleep(WaitPeriod*MaxThrdCount);
+  N:=GetTickCount64;
+  TMonitor.PulseAll(Obj1);
+  WaitForAllThreads(WaitTimeOut*MaxThrdCount);
+  For I:=0 to MaxThrdCount do
+    begin
+    AssertEquals('Thread '+IntToStr(i)+' did a Wait',toPulseAll,Obj1.Res[1].Op);
+    AssertTrue('Thread '+IntToStr(i)+' Wait was successful',Obj1.Res[1].Res);
+    AssertTrue('Thread '+IntToStr(i)+' pulse timestamp ',N<=FObj[1].Res[1].Tick);
+    end;
+end;
+
+procedure TTestMonitorSupport.TestWait;
+
+var
+  N : Int64;
+
+begin
+  // Acquire the lock
+  DoCreateThread(Obj1,toWait,1,INFINITE);
+  Sleep(WaitPeriod*4);
+  N:=GetTickCount64;
+  TMonitor.Pulse(Obj1);
+  WaitForAllThreads;
+  AssertEquals('Thread did a Wait',toWait,Obj1.Res[1].Op);
+  AssertTrue('Thread Wait was successful',Obj1.Res[1].Res);
+  AssertTrue('Thread pulse timestamp ',N<=FObj[1].Res[1].Tick);
+end;
+
+initialization
+  RegisterTest(TTestMonitorSupport);
+end.
+