* Set monitor structures in place

rtl/inc/monitor.inc

@@ -0,0 +1,238 @@
+{
+    This file is part of the Free Pascal run time library.
+    Copyright (c) 2024 by the Free Pascal development team
+
+    TMonitor support
+
+    See the file COPYING.FPC, included in this distribution,
+    for details about the copyright.
+
+    This program is distributed in the hope that it will be useful,
+    but WITHOUT ANY WARRANTY; without even the implied warranty of
+    MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE.
+
+ **********************************************************************}
+
+{ *********************************************************************
+  TMonitor
+  *********************************************************************}
+
+var
+  _monitormanager : TMonitorManager;
+
+class procedure TMonitor.FreeMonitorData(aData : Pointer);
+begin
+  if Not assigned(aData) then
+    system.exit;
+  _monitormanager.DoFreeMonitorData(aData);
+end;
+
+class procedure TMonitor.SetDefaultSpinCount(const aSpinCount: LongInt);
+
+begin
+  _monitormanager.DoSetDefaultSpinCount(aSpinCount);
+end;
+
+class function TMonitor.GetDefaultSpinCount : LongInt;
+
+begin
+  Result:=_monitormanager.DoGetDefaultSpinCount();
+end;
+
+
+class procedure TMonitor.Enter(Const aObject: TObject);
+begin
+  _monitormanager.DoEnter(aObject);
+end;
+
+class function TMonitor.Enter(Const aObject: TObject; aTimeout: Cardinal): Boolean;
+begin
+  Result:=_monitormanager.DoEnterTimeout(aObject,aTimeout);
+end;
+
+class procedure TMonitor.Exit(Const aObject: TObject);
+begin
+  _monitormanager.DoExit(aObject);
+end;
+
+class function TMonitor.TryEnter(Const aObject: TObject): Boolean;
+begin
+  Result:=_monitormanager.DoTryEnter(aObject);
+end;
+
+class function TMonitor.Wait(Const aObject: TObject; aTimeout: Cardinal): Boolean;
+begin
+  Result:=_monitormanager.DoWait(aObject,aTimeout);
+end;
+
+class function TMonitor.Wait(Const aObject, aLock: TObject; aTimeout: Cardinal): Boolean;
+begin
+  Result:=_monitormanager.DoWaitLock(aObject,aLock,aTimeout);
+end;
+
+class procedure TMonitor.Pulse(Const aObject: TObject);
+begin
+  _monitormanager.DoPulse(aObject);
+end;
+
+class procedure TMonitor.PulseAll(Const aObject: TObject);
+begin
+  _monitormanager.DoPulseAll(aObject);
+end;
+
+
+{ *********************************************************************
+  Monitor manager
+  *********************************************************************}
+
+procedure SysMonitorSetObjectDataProc(const aObject : TObject; aData : Pointer);
+begin
+  aObject.SetMonitorData(aData);
+end;
+
+function SysMonitorGetObjectDataFunc (const aObject : TObject): Pointer;
+begin
+  Result:=aObject.GetMonitorData;
+end;
+
+var
+  MMsys : TMonitorManager;
+
+
+function SetMonitorManager (var aNew : TMonitorManager) : TMonitorManager;
+
+begin
+  Result:=_monitormanager;
+  aNew.DoSetMonitorObjectData:=@SysMonitorSetObjectDataProc;
+  aNew.DoGetMonitorObjectData:=@SysMonitorGetObjectDataFunc;
+  _monitormanager:=aNew;
+end;
+
+function GetMonitorManager : TMonitorManager;
+
+begin
+  Result:=_monitormanager;
+end;
+
+procedure DoNoMonitor;
+begin
+  RunError(235);
+end;
+
+procedure SysFreeMonitorData(aData : Pointer);
+
+begin
+  // Do nothing
+end;
+
+procedure SysNoMonitor(const aObject : TObject);
+
+begin
+  DoNoMonitor;
+end;
+
+function SysNoMonitorFunc(const aObject : TObject) : Boolean;
+
+begin
+  Result:=False;
+  DoNoMonitor;
+end;
+
+function SysNoMonitorTimeout(const aObject : TObject; aTimeout : Cardinal) : Boolean;
+
+begin
+  Result:=False;
+  DoNoMonitor;
+end;
+
+function SysNoMonitorGetDefaultSpinCount : Longint;
+begin
+  Result:=0;
+  DoNoMonitor;
+end;
+
+procedure SysNoMonitorSetDefaultSpinCount(const aValue : Longint);
+begin
+  DoNoMonitor;
+end;
+
+function SysNoMonitorDowaitLock(const aObject,aLock : TObject; aTimeout : Cardinal) : Boolean;
+
+begin
+  Result:=False;
+  DoNoMonitor;
+end;
+
+Procedure InitMonitor;
+
+begin
+  MMsys.DoEnter:=@SysNoMonitor;
+  MMsys.DoExit:=@SysNoMonitor;
+  MMsys.DoPulse:=@SysNoMonitor;
+  MMsys.DoPulseAll:=@SysNoMonitor;
+  MMsys.DoEnterTimeout:=@SysNoMonitorTimeout;
+  MMsys.DoTryEnter:=@SysNoMonitorFunc;
+  MMsys.DoWait:=@SysNoMonitorTimeout;
+  MMsys.DoSetDefaultSpinCount:=@SysNoMonitorSetDefaultSpinCount;
+  MMsys.DoGetDefaultSpinCount:=@SysNoMonitorGetDefaultSpinCount;
+  MMsys.DoWaitLock:=@SysNoMonitorDowaitLock;
+  MMsys.DoFreeMonitorData:=@SysFreeMonitorData;
+  SetMonitorManager(MMsys);
+end;
+
+{ *********************************************************************
+  Shortcuts
+  *********************************************************************}
+
+function MonitorEnter(Const aObject: TObject; aTimeout: Cardinal = INFINITE): Boolean;
+
+begin
+  if atimeout=Infinite then
+    TMonitor.Enter(aObject)
+  else
+    TMonitor.Enter(aObject,aTimeOut);
+end;
+
+
+function MonitorTryEnter(Const aObject: TObject): Boolean;
+
+begin
+  TMonitor.TryEnter(aObject);
+end;
+
+
+procedure MonitorExit(Const aObject: TObject);
+
+begin
+  TMonitor.Exit(aObject);
+end;
+
+
+function MonitorWait(Const aObject: TObject; aTimeout: Cardinal): Boolean;
+
+begin
+  TMonitor.Wait(aObject,aTimeOut);
+end;
+
+
+function MonitorWait(Const aObject, aLock: TObject; aTimeout: Cardinal): Boolean;
+
+begin
+  TMonitor.Wait(aObject,aLock,aTimeOut);
+end;
+
+
+procedure MonitorPulse(Const aObject: TObject);
+
+begin
+  TMonitor.Pulse(aObject);
+end;
+
+
+procedure MonitorPulseAll(Const aObject: TObject);
+
+begin
+  TMonitor.PulseAll(aObject);
+end;
+
+

rtl/inc/objpas.inc

@@ -460,11 +460,23 @@ end;
            i : longint;
 {$endif VER3_0}
         begin
+           I:=instancesize;
            { the size is saved at offset 0 }
            fillchar(instance^, InstanceSize, 0);
            { insert VMT pointer into the new created memory area }
            { (in class methods self contains the VMT!)           }
-           ppointer(instance)^:=pointer(self);
+           {$IFNDEF SYSTEM_HAS_FEATURE_MONITOR}
+             ppointer(instance)^:=pointer(self);
+           {$ELSE}
+             {$IFDEF VER3_2}
+             // In 3.2.x Compiler (used during bootstrap) still inserts VMT at offset...
+             ppointer(PByte(instance)+SizeOf(Pointer))^:=pointer(self);
+             {$ELSE}
+             // As of 3.3.x compiler forces insert of VMT at first pos.
+             ppointer(instance)^:=pointer(self);
+             {$ENDIF}
+          {$ENDIF}
+
            if {$ifdef VER3_0}PVmt(self)^.vIntfTable <> @emptyintf{$else}assigned(PVmt(self)^.vIntfTable){$endif} then
              InitInterfacePointers(self,instance);
 
@@ -852,6 +864,10 @@ end;
 {$endif def FPC_HAS_FEATURE_RTTI}
                vmt:= vmt^.vParent;
              end;
+           {$IFDEF SYSTEM_HAS_FEATURE_MONITOR}
+           if Assigned(_MonitorData) then
+             TMonitor.FreeMonitorData(_MonitorData);
+           {$ENDIF}
         end;
 
       procedure TObject.AfterConstruction;
@@ -1157,6 +1173,20 @@ end;
         // Do nothing since we have no reference count.
       end;
 
+      {$IFDEF SYSTEM_HAS_FEATURE_MONITOR}
+
+       procedure TObject.SetMonitorData(aData : Pointer);
+       begin
+         _MonitorData:=aData;
+       end;
+
+       function TObject.GetMonitorData: Pointer;
+       begin
+         Result:=_MonitorData;
+       end;
+      {$ENDIF}
+
+
 {****************************************************************************
                                TINTERFACEDOBJECT
 ****************************************************************************}
@@ -1898,3 +1928,6 @@ end;
 
 {$ENDIF}
 
+{$IFDEF SYSTEM_HAS_FEATURE_MONITOR}
+{$i monitor.inc}
+{$ENDIF}

rtl/inc/objpash.inc

@@ -241,6 +241,13 @@
        end;  
 
        TObject = class
+       {$IFDEF SYSTEM_HAS_FEATURE_MONITOR}
+       strict private
+          _MonitorData : Pointer;
+       private
+          procedure SetMonitorData(aData : Pointer); inline;
+          function GetMonitorData: Pointer; inline;
+       {$ENDIF}
        protected
           function GetDisposed : Boolean; inline;
        public
@@ -264,7 +271,7 @@
           class function ClassName : shortstring;
           class function ClassNameIs(const name : RTLString) : boolean;
           class function ClassParent : tclass;{$ifdef SYSTEMINLINE}inline;{$endif}
-          class function InstanceSize : SizeInt;{$ifdef SYSTEMINLINE}inline;{$endif}
+          class function InstanceSize : SizeInt;// {$ifdef SYSTEMINLINE}inline;{$endif}
           class function InheritsFrom(aclass : tclass) : boolean;
           class function StringMessageTable : pstringmessagetable;
 
@@ -416,6 +423,10 @@
        PPDispatch = ^PDispatch;
        PInterface = PUnknown;
 
+       {*****************************************************************************
+                                     Exception support
+        *****************************************************************************}
+
 {$ifdef FPC_USE_PSABIEH}
 
 {$if (defined(CPUARMEL) or defined(CPUARMHF)) and not defined(darwin)}
@@ -505,39 +516,6 @@
 {$endif FPC_USE_PSABIEH}
        end;
 
-       {$PUSH}
-       { disable the warning that the constructor should be public }
-       {$WARN 3018 OFF}
-       TCustomAttribute = class(TObject)
-       private
-         { if the user wants to use a parameterless constructor they need to
-           explicitely declare it in their type }
-         constructor Create;
-       end;
-       {$POP}
-
-       TUnimplementedAttribute = class(TCustomAttribute)
-       public
-         constructor Create; unimplemented;
-       end;
-
-       WeakAttribute = class(TUnimplementedAttribute);
-       UnsafeAttribute = class(TUnimplementedAttribute);
-       RefAttribute = class(TUnimplementedAttribute);
-       VolatileAttribute = class(TUnimplementedAttribute);
-
-       StoredAttribute = Class(TCustomAttribute)
-       Private
-          FFlag : Boolean;
-          FName : ShortString;
-       Public
-         Constructor Create;
-         Constructor Create(Const aFlag : Boolean);
-         Constructor Create(Const aName : ShortString);
-         Property Flag : Boolean Read FFlag;
-         Property Name : ShortString Read FName;
-       end;
-
 
     Const
        ExceptProc : TExceptProc = Nil;
@@ -570,6 +548,114 @@
   const
     { for safe as operator support }
     IObjectInstance: TGuid = '{D91C9AF4-3C93-420F-A303-BF5BA82BFD23}';
+
+    {*****************************************************************************
+                                  Attribute support
+     *****************************************************************************}
+  Type
+  {$PUSH}
+  { disable the warning that the constructor should be public }
+  {$WARN 3018 OFF}
+  TCustomAttribute = class(TObject)
+  private
+    { if the user wants to use a parameterless constructor they need to
+      explicitely declare it in their type }
+    constructor Create;
+  end;
+  {$POP}
+
+  TUnimplementedAttribute = class(TCustomAttribute)
+  public
+    constructor Create; unimplemented;
+  end;
+
+  WeakAttribute = class(TUnimplementedAttribute);
+  UnsafeAttribute = class(TUnimplementedAttribute);
+  RefAttribute = class(TUnimplementedAttribute);
+  VolatileAttribute = class(TUnimplementedAttribute);
+
+  StoredAttribute = Class(TCustomAttribute)
+  Private
+     FFlag : Boolean;
+     FName : ShortString;
+  Public
+    Constructor Create;
+    Constructor Create(Const aFlag : Boolean);
+    Constructor Create(Const aName : ShortString);
+    Property Flag : Boolean Read FFlag;
+    Property Name : ShortString Read FName;
+  end;
+
+  {*****************************************************************************
+                                TMonitor support
+   *****************************************************************************}
+  {$IFDEF SYSTEM_HAS_FEATURE_MONITOR}
+  Type
+
+  PPMonitor = ^PMonitor;
+  PMonitor = ^TMonitor;
+  TMonitor = record
+  Private
+    class procedure FreeMonitorData(aData : Pointer); static;
+  public
+    class procedure SetDefaultSpinCount(const aSpinCount: Longint); static;
+    class function GetDefaultSpinCount : Longint; static;
+    class procedure Enter(Const aObject: TObject); overload; static; inline;
+    class function Enter(Const aObject: TObject; aTimeout: Cardinal): Boolean; overload; static;
+    class procedure Exit(Const aObject: TObject); overload; static;
+    class function TryEnter(Const aObject: TObject): Boolean; overload; static;
+    class function Wait(Const aObject: TObject; aTimeout: Cardinal): Boolean; overload; static;
+    class function Wait(Const aObject, aLock: TObject; aTimeout: Cardinal): Boolean; overload; static;
+    class procedure Pulse(Const aObject: TObject); overload; static;
+    class procedure PulseAll(Const aObject: TObject); overload; static;
+    class property DefaultSpinCount: Longint read GetDefaultSpinCount write SetDefaultSpinCount;
+  end;
+
+
+  TMonitorManager = record
+  Public type
+    TMonitorSetSpinCountProc = Procedure(const aSpinCount : LongInt);
+    TMonitorGetSpinCountProc = Function : LongInt;
+    TMonitorProc = Procedure(const aObject : TObject);
+    TMonitorFunc = function(const aObject : TObject) : Boolean;
+    TMonitorTimeoutFunc = function(const aObject : TObject; aTimeout : Cardinal) : Boolean;
+    TMonitorLockTimeoutFunc = function(const aObject,aLock : TObject; aTimeout : Cardinal) : Boolean;
+    TMonitorSetObjectDataProc = procedure (const aObject : TObject; aData : Pointer);
+    TMonitorGetObjectDataFunc = function (const aObject : TObject): Pointer;
+    TMonitorFreeDataProc = procedure (aData : Pointer);
+  Public
+    DoSetDefaultSpinCount : TMonitorSetSpinCountProc;
+    DoGetDefaultSpinCount : TMonitorGetSpinCountProc;
+    DoEnter : TMonitorProc;
+    DoEnterTimeout : TMonitorTimeoutFunc;
+    DoExit : TMonitorProc;
+    DoTryEnter : TMonitorFunc;
+    DoWait : TMonitorTimeoutFunc;
+    DoWaitLock : TMonitorLockTimeoutFunc;
+    DoPulse : TMonitorProc;
+    DoPulseAll : TMonitorProc;
+    DoFreeMonitorData : TMonitorFreeDataProc;
+    // Will be set by SetMonitorManager
+    DoGetMonitorObjectData : TMonitorGetObjectDataFunc;
+    DoSetMonitorObjectData : TMonitorSetObjectDataProc;
+  end;
+
+  const
+    INFINITE = Cardinal($FFFFFFFF);
+
+  function MonitorEnter(Const aObject: TObject; aTimeout: Cardinal = INFINITE): Boolean; inline;
+  function MonitorTryEnter(Const aObject: TObject): Boolean; inline;
+  procedure MonitorExit(Const aObject: TObject); inline;
+  function MonitorWait(Const aObject: TObject; aTimeout: Cardinal): Boolean; inline; overload;
+  function MonitorWait(Const aObject, ALock: TObject; aTimeout: Cardinal): Boolean; inline; overload;
+  procedure MonitorPulse(Const aObject: TObject); inline;
+  procedure MonitorPulseAll(Const aObject: TObject); inline;
+
+  // Will set Do(S|G)etMonitorObjectData fields on aNew, and returns the old manager
+  function SetMonitorManager (var aNew : TMonitorManager) : TMonitorManager;
+  function GetMonitorManager : TMonitorManager;
+  {$ENDIF}
+
 {$endif FPC_HAS_FEATURE_CLASSES}
 
 {*****************************************************************************

rtl/linux/system.pp

@@ -25,6 +25,7 @@ Unit System;
                                     interface
 {*****************************************************************************}
 
+{$DEFINE SYSTEM_HAS_FEATURE_MONITOR}
 {$define FPC_IS_SYSTEM}
 {$define HAS_CMDLINE}
 {$define USE_NOTHREADMANAGER}