{******************************************************************************}
{                                                                              }
{ Project JEDI Code Library (JCL)                                              }
{                                                                              }
{ The contents of this file are subject to the Mozilla Public License Version  }
{ 1.1 (the "License"); you may not use this file except in compliance with the }
{ License. You may obtain a copy of the License at http://www.mozilla.org/MPL/ }
{                                                                              }
{ Software distributed under the License is distributed on an "AS IS" basis,   }
{ WITHOUT WARRANTY OF ANY KIND, either express or implied. See the License for }
{ the specific language governing rights and limitations under the License.    }
{                                                                              }
{ The Original Code is JclSynch.pas.                                           }
{                                                                              }
{ The Initial Developer of the Original Code is documented in the accompanying }
{ help file JCL.chm. Portions created by these individuals are Copyright (C)   }
{ 2000 of these individuals.                                                   }
{                                                                              }
{******************************************************************************}
{                                                                              }
{ This unit contains various classes and support routines for implementing     }
{ synchronisation in multithreaded applications. This ranges from interlocked  }
{ access to simple typed variables to wrapper classes for synchronisation      }
{ primitives provided by the operating system (critical section, semaphore,    }
{ mutex etc). It also includes three user defined classes to complement these. }
{                                                                              }
{ Unit owner: Marcel van Brakel                                                }
{ Last modified: January 30, 2001                                              }
{                                                                              }
{******************************************************************************}

unit JclSynch;

{$I jcl.inc}

{$WEAKPACKAGEUNIT ON}

interface

uses
  {$IFDEF WIN32}
  Windows,
  {$ENDIF WIN32}
  JclBase;

//------------------------------------------------------------------------------
// Locked Integer manipulation
//
// Routines to manipulate simple typed variables in a thread safe manner 
//------------------------------------------------------------------------------

function LockedAdd(var Target: Integer; Value: Integer): Integer;
function LockedCompareExchange(var Target: Integer; Exch, Comp: Integer): Integer; overload;
function LockedCompareExchange(var Target: Pointer; Exch, Comp: Pointer): Pointer; overload;
function LockedDec(var Target: Integer): Integer;
function LockedExchange(var Target: Integer; Value: Integer): Integer;
function LockedExchangeAdd(var Target: Integer; Value: Integer): Integer;
function LockedExchangeDec(var Target: Integer): Integer;
function LockedExchangeInc(var Target: Integer): Integer;
function LockedExchangeSub(var Target: Integer; Value: Integer): Integer;
function LockedInc(var Target: Integer): Integer;
function LockedSub(var Target: Integer; Value: Integer): Integer;

//------------------------------------------------------------------------------
// TJclDispatcherObject
//
// Base class for operating system provided synchronisation primitives
//------------------------------------------------------------------------------

type
  TJclWaitResult = (wrAbandoned, wrError, wrIoCompletion, wrSignaled, wrTimeout);

  TJclDispatcherObject = class (TObject)
  private
    FExisted: Boolean;
    FHandle: THandle;
    FName: string;
  public
    constructor Attach(Handle: THandle);
    destructor Destroy; override;
    //function MsgWaitFor(const TimeOut: Cardinal): TJclWaitResult; Mask: DWORD): TJclWaitResult;
    //function MsgWaitForEx(const TimeOut: Cardinal): TJclWaitResult; Mask: DWORD): TJclWaitResult;
    function SignalAndWait(const Obj: TJclDispatcherObject; TimeOut: Cardinal;
      Alertable: Boolean): TJclWaitResult;
    function WaitAlertable(const TimeOut: Cardinal): TJclWaitResult;
    function WaitFor(const TimeOut: Cardinal): TJclWaitResult;
    function WaitForever: TJclWaitResult;
    property Existed: Boolean read FExisted;
    property Handle: THandle read FHandle;
    property Name: string read FName;
  end;

//------------------------------------------------------------------------------
// Wait functions
//
// Object enabled Wait functions (takes TJclDispatcher objects as parameter as
// opposed to handles) mostly for convenience
//------------------------------------------------------------------------------

function WaitForMultipleObjects(const Objects: array of TJclDispatcherObject;
  WaitAll: Boolean; TimeOut: Cardinal): Cardinal;
function WaitAlertableForMultipleObjects(const Objects: array of TJclDispatcherObject;
  WaitAll: Boolean; TimeOut: Cardinal): Cardinal;

//------------------------------------------------------------------------------
// TJclCriticalSection
//------------------------------------------------------------------------------

type
  TJclCriticalSection = class (TObject)
  private
    FCriticalSection: TRTLCriticalSection;
  public
    constructor Create; virtual;
    destructor Destroy; override;
    class procedure CreateAndEnter(var CS: TJclCriticalSection);
    procedure Enter;
    procedure Leave;
  end;

//------------------------------------------------------------------------------
// TJclCriticalSectionEx
//------------------------------------------------------------------------------

type
  TJclCriticalSectionEx = class (TJclCriticalSection)
  private
    FSpinCount: Cardinal;
    function GetSpinCount: Cardinal;
    procedure SetSpinCount(const Value: Cardinal);
  public
    constructor Create; override;
    constructor CreateEx(SpinCount: Cardinal; NoFailEnter: Boolean); virtual;
    class function GetSpinTimeOut: Cardinal;
    class procedure SetSpinTimeOut(const Value: Cardinal);
    function TryEnter: Boolean;
    property SpinCount: Cardinal read GetSpinCount write SetSpinCount;
  end;

//------------------------------------------------------------------------------
// TJclEvent
//------------------------------------------------------------------------------

type
  TJclEvent = class (TJclDispatcherObject)
  public
    constructor Create(SecAttr: PSecurityAttributes; Manual, Signaled: Boolean; const Name: string);
    constructor Open(Access: Cardinal; Inheritable: Boolean; const Name: string);
    function Pulse: Boolean;
    function ResetEvent: Boolean;
    function SetEvent: Boolean;
  end;

//------------------------------------------------------------------------------
// TJclWaitableTimer
//------------------------------------------------------------------------------

type
  TJclWaitableTimer = class (TJclDispatcherObject)
  private
    FResume: Boolean;
  public
    constructor Create(SecAttr: PSecurityAttributes; Manual: Boolean; const Name: string);
    constructor Open(Access: Cardinal; Inheritable: Boolean; const Name: string);
    function Cancel: Boolean;
    function SetTimer(const DueTime: Int64; Period: Longint; Resume: Boolean): Boolean;
    function SetTimerApc(const DueTime: Int64; Period: Longint; Resume: Boolean; Apc: TFNTimerAPCRoutine; Arg: Pointer): Boolean;
  end;

//------------------------------------------------------------------------------
// TJclSemaphore
//------------------------------------------------------------------------------

type
  TJclSemaphore = class (TJclDispatcherObject)
  public
    constructor Create(SecAttr: PSecurityAttributes; Initial, Maximum: Longint; const Name: string);
    constructor Open(Access: Cardinal; Inheritable: Boolean; const Name: string);
    function Release(ReleaseCount: Longint): Boolean;
    function ReleasePrev(ReleaseCount: Longint; var PrevCount: Longint): Boolean;
  end;

//------------------------------------------------------------------------------
// TJclMutex
//------------------------------------------------------------------------------

type
  TJclMutex = class (TJclDispatcherObject)
  public
    constructor Create(SecAttr: PSecurityAttributes; InitialOwner: Boolean; const Name: string);
    constructor Open(Access: Cardinal; Inheritable: Boolean; const Name: string);
    function Release: Boolean;
  end;

//------------------------------------------------------------------------------
// TJclOptex
//------------------------------------------------------------------------------

type
  POptexSharedInfo = ^TOptexSharedInfo;
  TOptexSharedInfo = record
    SpinCount: Integer;      // number of times to try and enter the optex before
                             // waiting on kernel event, 0 on single processor
    LockCount: Integer;      // count of enter attempts
    ThreadId: Longword;      // id of thread that owns the optex, 0 if free
    RecursionCount: Integer; // number of times the optex is owned, 0 if free
  end;

  TJclOptex = class (TObject)
  private
    FEvent: TJclEvent;
    FExisted: Boolean;
    FFileMapping: THandle;
    FName: string;
    FSharedInfo: POptexSharedInfo;
    function GetUniProcess: Boolean;
    function GetSpinCount: Integer;
    procedure SetSpinCount(Value: Integer);
  public
    constructor Create(const Name: string {$IFDEF SUPPORTS_DEFAULTPARAMS} = '' {$ENDIF};
      SpinCount: Integer {$IFDEF SUPPORTS_DEFAULTPARAMS} = 4000 {$ENDIF});
    destructor Destroy; override;
    procedure Enter;
    procedure Leave;
    function TryEnter: Boolean;
    property Existed: Boolean read FExisted;
    property Name: string read FName;
    property SpinCount: Integer read GetSpinCount write SetSpinCount;
    property UniProcess: Boolean read GetUniProcess;
  end;

//------------------------------------------------------------------------------
// TJclMultiReadExclusiveWrite
//------------------------------------------------------------------------------

type
  TMrewPreferred = (mpReaders, mpWriters, mpEqual);

  TMrewThreadInfo = record
    ThreadId: Longword;      // client-id of thread
    RecursionCount: Integer; // number of times a thread accessed the mrew
    Reader: Boolean;         // true if reader, false if writer
  end;
  TMrewThreadInfoArray = array of TMrewThreadInfo;

  TJclMultiReadExclusiveWrite = class (TObject)
  private
    FLock: TJclCriticalSection;
    FPreferred: TMrewPreferred;
    FSemReaders: TJclSemaphore;
    FSemWriters: TJclSemaphore;
    FState: Integer;
    FThreads: TMrewThreadInfoArray;
    FWaitingReaders: Integer;
    FWaitingWriters: Integer;
    procedure AddToThreadList(ThreadId: Longword; Reader: Boolean);
    procedure RemoveFromThreadList(Index: Integer);
    function FindThread(ThreadId: Longword): Integer;
    procedure ReleaseWaiters(WasReading: Boolean);
  protected
    procedure Release;
  public
    constructor Create(Preferred: TMrewPreferred); virtual;
    destructor Destroy; override;
    procedure BeginRead;
    procedure BeginWrite;
    procedure EndRead;
    procedure EndWrite;
  end;

//------------------------------------------------------------------------------
// TJclMeteredSection
//------------------------------------------------------------------------------

type
  PMetSectSharedInfo = ^TMetSectSharedInfo;
  TMetSectSharedInfo = record
    Initialized: LongBool;    // Is the metered section initialized?
    SpinLock: Longint;        // Used to gain access to this structure
    ThreadsWaiting: Longint;  // Count of threads waiting
    AvailableCount: Longint;  // Available resource count
    MaximumCount: Longint;    // Maximum resource count
  end;

  PMeteredSection = ^TMeteredSection;
  TMeteredSection = record
    Event: THandle;           // Handle to a kernel event object
    FileMap: THandle;         // Handle to memory mapped file
    SharedInfo: PMetSectSharedInfo;
  end;

  TJclMeteredSection = class (TObject)
  private
    FMetSect: PMeteredSection;
    procedure CloseMeteredSection;
    function InitMeteredSection(InitialCount, MaxCount: Longint; const Name: string; OpenOnly: Boolean): Boolean;
    function CreateMetSectEvent(const Name: string; OpenOnly: Boolean): Boolean;
    function CreateMetSectFileView(InitialCount, MaxCount: Longint; const Name: string; OpenOnly: Boolean): Boolean;
  protected
    procedure AcquireLock;
    procedure ReleaseLock;
  public
    constructor Create(InitialCount, MaxCount: Longint; const Name: string); overload;
    constructor Open(const Name: string);
    destructor Destroy; override;
    function Enter(TimeOut: Longword): TJclWaitResult;
    function Leave(ReleaseCount: Longint): Boolean; overload;
    function Leave(ReleaseCount: Longint; var PrevCount: Longint): Boolean; overload;
  end;

//------------------------------------------------------------------------------
// Debugging
//
// Note that the following function and structure declarations are all offically
// undocumented and, except for QueryCriticalSection, require Windows NT since
// it is all part of the Windows NT Native API.
//------------------------------------------------------------------------------

type
  TEventInfo = record
    EventType: Longint;       // 0 = manual, otherwise auto
    Signaled: LongBool;       // true is signaled
  end;

  TMutexInfo = record
    SignalState: Longint;     // >0 = signaled, <0 = |SignalState| recurs. acquired
    Owned: Boolean;           // owned by thread
    Abandoned: Boolean;       // is abandoned?
  end;

  TSemaphoreCounts = record
    CurrentCount: Longint;    // current semaphore count
    MaximumCount: Longint;    // maximum semaphore count
  end;

  TTimerInfo = record
    Remaining: TLargeInteger; // 100ns intervals until signaled
    Signaled: LongBool;       // is signaled?
  end;

function QueryCriticalSection(CS: TJclCriticalSection; var Info: TRTLCriticalSection): Boolean;
function QueryEvent(Handle: THandle; var Info: TEventInfo): Boolean;
function QueryMutex(Handle: THandle; var Info: TMutexInfo): Boolean;
function QuerySemaphore(Handle: THandle; var Info: TSemaphoreCounts): Boolean;
function QueryTimer(Handle: THandle; var Info: TTimerInfo): Boolean;

//------------------------------------------------------------------------------
// Exceptions
//------------------------------------------------------------------------------

type
  EJclWin32HandleObjectError = class (EJclWin32Error);
  EJclDispatcherObjectError = class (EJclWin32Error);
  EJclCriticalSectionError = class (EJclWin32Error);
  EJclEventError = class (EJclWin32Error);
  EJclWaitableTimerError = class (EJclWin32Error);
  EJclSemaphoreError = class (EJclWin32Error);
  EJclMutexError = class (EJclWin32Error);
  EJclMeteredSectionError = class (EJclError);

implementation

uses
  SysUtils,
  JclLogic, JclRegistry, JclResources, JclSysInfo, JclSysUtils, JclWin32;

const
  RegSessionManager = {HKLM\}'System\CurrentControlSet\Control\Session Manager';
  RegCritSecTimeout = {RegSessionManager\}'CriticalSectionTimeout';

//==============================================================================
// Locked Integer manipulation
//==============================================================================

function LockedAdd(var Target: Integer; Value: Integer): Integer; assembler;
asm
        MOV     ECX, EAX
        MOV     EAX, EDX
        LOCK XADD [ECX], EAX
        ADD     EAX, EDX
end;

//------------------------------------------------------------------------------

function LockedCompareExchange(var Target: Integer; Exch, Comp: Integer): Integer; assembler;
asm
        XCHG    EAX, ECX
        LOCK CMPXCHG [ECX], EDX
end;

//------------------------------------------------------------------------------

function LockedCompareExchange(var Target: Pointer; Exch, Comp: Pointer): Pointer; assembler;
asm
        XCHG    EAX, ECX
        LOCK CMPXCHG [ECX], EDX
end;

//------------------------------------------------------------------------------

function LockedDec(var Target: Integer): Integer; assembler;
asm
        MOV     ECX, EAX
        MOV     EAX, -1
        LOCK XADD [ECX], EAX
        DEC     EAX
end;

//------------------------------------------------------------------------------

function LockedExchange(var Target: Integer; Value: Integer): Integer; assembler;
asm
        MOV     ECX, EAX
        MOV     EAX, EDX
        LOCK XCHG [ECX], EAX
end;

//------------------------------------------------------------------------------

function LockedExchangeAdd(var Target: Integer; Value: Integer): Integer; assembler;
asm
        MOV     ECX, EAX
        MOV     EAX, EDX
        LOCK XADD [ECX], EAX
end;

//------------------------------------------------------------------------------

function LockedExchangeDec(var Target: Integer): Integer; assembler;
asm
        MOV     ECX, EAX
        MOV     EAX, -1
        LOCK XADD [ECX], EAX
end;

//------------------------------------------------------------------------------

function LockedExchangeInc(var Target: Integer): Integer; assembler;
asm
        MOV     ECX, EAX
        MOV     EAX, 1
        LOCK XADD [ECX], EAX
end;

//------------------------------------------------------------------------------

function LockedExchangeSub(var Target: Integer; Value: Integer): Integer<