{**************************************************************************************************}
{                                                                                                  }
{ 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 Developers of the Original Code are Marcel van Brakel and Azret Botash.              }
{ Portions created by these individuals are Copyright (C) of these individuals.                    }
{ All Rights Reserved.                                                                             }
{                                                                                                  }
{ Contributor(s):                                                                                  }
{   Marcel van Brakel                                                                              }
{   Olivier Sannier (obones)                                                                       }
{   Matthias Thoma (mthoma)                                                                        }
{                                                                                                  }
{**************************************************************************************************}
{                                                                                                  }
{ 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.                                                                                }
{                                                                                                  }
{**************************************************************************************************}

// Last modified: $Date: 2005/03/08 08:33:23 $
// For history see end of file

unit JclSynch;

{$I jcl.inc}

interface

uses
  {$IFDEF MSWINDOWS}
  Windows,
  {$ENDIF MSWINDOWS}
  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;

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 = 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 = 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 = 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 = 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 = 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;

  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 = ''; SpinCount: Integer = 4000);
    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;

  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;

  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);
    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.
{ TODO -cTest : Test this structures }
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: ByteBool;          // owned by thread
    Abandoned: ByteBool;      // 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: ByteBool;       // is signaled?
  end;

function QueryCriticalSection(CS: TJclCriticalSection; var Info: TRTLCriticalSection): Boolean;
{ TODO -cTest : Test these 4 functions }
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;

type
  // Exceptions
  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, 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; assembler;
asm
        MOV     ECX, EAX
        NEG     EDX
        MOV     EAX, EDX
        LOCK XADD [ECX], EAX
end;

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

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

//=== { TJclDispatcherObject } ===============================================

function MapSignalResult(const Ret: DWORD): TJclWaitResult;
begin
  case Ret of
    WAIT_ABANDONED:
      Result := wrAbandoned;
    WAIT_OBJECT_0:
      Result := wrSignaled;
    WAIT_TIMEOUT:
      Result := wrTimeout;
    WAIT_IO_COMPLETION:
      Result := wrIoCompletion;
    WAIT_FAILED:
      Result := wrError;
  else
    Result := wrError;
  end;
end;

constructor TJclDispatcherObject.Attach(Handle: THandle);
begin
  FExisted := True;
  FHandle := Handle;
  FName := '';
end;

destructor TJclDispatcherObject.Destroy;
begin
  CloseHandle(FHandle);
  inherited Destroy;
end;

{ TODO: Use RTDL Version of SignalObjectAndWait }

function TJclDispatcherObject.SignalAndWait(const Obj: TJclDispatcherObject;
  TimeOut: Cardinal; Alertable: Boolean): TJclWaitResult;
begin
  // Note: Do not make this method virtual! It's only available on NT 4 up...
  Result := MapSignalResult(Cardinal(Windows.SignalObjectAndWait(Obj.Handle, Handle, TimeOut, Alertable)));
end;

function TJclDispatcherObject.WaitAlertable(const TimeOut: Cardinal): TJclWaitResult;
begin
  Result := MapSignalResult(Windows.WaitForSingleObjectEx(FHandle, TimeOut, True));
end;

function TJclDispatcherObject.WaitFor(const TimeOut: Cardinal): TJclWaitResult;
begin
  Result := MapSignalResult(Windows.WaitForSingleObject(FHandle, TimeOut));
end;

function TJclDispatcherObject.WaitForever: TJclWaitResult;
begin
  Result := WaitFor(INFINITE);
end;

// Wait functions
function WaitForMultipleObjects(const Objects: array of TJclDispatcherObject;
  WaitAll: Boolean; TimeOut: Cardinal): Cardinal;
var
  Handles: array of THandle;
  I, Count: Integer;
begin
  Count := High(Objects) + 1;
  SetLength(Handles, Count);
  for I := 0 to Count - 1 do
    Handles[I] := Objects[I].Handle;
  Result := Windows.WaitForMultipleObjects(Count, @Handles[0], WaitAll, TimeOut);
end;

function WaitAlertableForMultipleObjects(const Objects: array of TJclDispatcherObject;
  WaitAll: Boolean; TimeOut: Cardinal): Cardinal;
var
  Handles: array of THandle;
  I, Count: Integer;
begin
  Count := High(Objects) + 1;
  SetLength(Handles, Count);
  for I := 0 to Count - 1 do
    Handles[I] := Objects[I].Handle;
  Result := Windows.WaitForMultipleObjectsEx(Count, @Handles[0], WaitAll, TimeOut, True);
end;

//=== { TJclCriticalSection } ================================================

constructor TJclCriticalSection.Create;
begin
  inherited Create;
  Windows.InitializeCriticalSection(FCriticalSection);
end;

destructor TJclCriticalSection.Destroy;
begin
  Windows.DeleteCriticalSection(FCriticalSection);
  inherited Destroy;
end;

class procedure TJclCriticalSection.CreateAndEnter(var CS: TJclCriticalSection);
var
  NewCritSect: TJclCriticalSection;
begin
  NewCritSect := TJclCriticalSection.Create;
  if LockedCompareExchange(Pointer(CS), Pointer(NewCritSect), nil) <> nil then
  begin
    // LoadInProgress was <> nil -> no exchange took place, free the CS
    NewCritSect.Free;
  end;
  CS.Enter;
end;

procedure TJclCriticalSection.Enter;
begin
  Windows.EnterCriticalSection(FCriticalSection);
end;

procedure TJclCriticalSection.Leave;
begin
  Windows.LeaveCriticalSection(FCriticalSection);
end;

//== { TJclCriticalSectionEx } ===============================================

const
  DefaultCritSectSpinCount = 4000;

constructor TJclCriticalSectionEx.Create;
begin
  CreateEx(DefaultCritSectSpinCount, False);
end;

{ TODO: Use RTDL Version of InitializeCriticalSectionAndSpinCount }

constructor TJclCriticalSectionEx.CreateEx(SpinCount: Cardinal;
  NoFailEnter: Boolean);
begin
  FSpinCount := SpinCount;
  if NoFailEnter then
    SpinCount := SpinCount or Cardinal($80000000);

  if not InitializeCriticalSectionAndSpinCount(FCriticalSection, SpinCount) then
    raise EJclCriticalSectionError.CreateRes(@RsSynchInitCriticalSection);
end;

function TJclCriticalSectionEx.GetSpinCount: Cardinal;
begin
  // Spinning only makes sense on multiprocessor systems. On a single processor
  // system the thread would simply waste cycles while the owning thread is
  // suspended and thus cannot release the critical section.
  if ProcessorCount = 1 then
    Result := 0
  else
    Result := FSpinCount;
end;

class function TJclCriticalSectionEx.GetSpinTimeOut: Cardinal;
begin
  Result := Cardinal(RegReadInteger(HKEY_LOCAL_MACHINE, RegSessionManager,
    RegCritSecTimeout));
end;

{ TODO: Use RTLD version of SetCriticalSectionSpinCount }
procedure TJclCriticalSectionEx.SetSpinCount(const Value: Cardinal);
begin
  FSpinCount := SetCriticalSectionSpinCount(FCriticalSection, Value);
end;

class procedure TJclCriticalSectionEx.SetSpinTimeOut(const Value: Cardinal);
begin
  RegWriteInteger(HKEY_LOCAL_MACHINE, RegSessionManager, RegCritSecTimeout,
    Integer(Value));
end;

{ TODO: Use RTLD version of TryEnterCriticalSection }
function TJclCriticalSectionEx.TryEnter: Boolean;
begin
  Result := TryEnterCriticalSection(FCriticalSection);
end;

//== { TJclEvent } ===========================================================

constructor TJclEvent.Create(SecAttr: PSecurityAttributes;
  Manual, Signaled: Boolean; const Name: string);
begin
  inherited Create;
  FName := Name;
  FHandle := Windows.CreateEvent(SecAttr, Manual, Signaled, PChar(FName));
  if FHandle = 0 then
    raise EJclEventError.CreateRes(@RsSynchCreateEvent);
  FExisted := GetLastError = ERROR_ALREADY_EXISTS;
end;

constructor TJclEvent.Open(Access: Cardinal; Inheritable: Boolean;
  const Name: string);
begin
  FName := Name;
  FExisted := True;
  FHandle := Windows.OpenEvent(Access, Inheritable, PChar(Name));
  if FHandle = 0 then
    raise EJclEventError.CreateRes(@RsSynchOpenEvent);
end;

function TJclEvent.Pulse: Boolean;
begin
  Result := Windows.PulseEvent(FHandle);
end;

function TJclEvent.ResetEvent: Boolean;
begin
  Result := Windows.ResetEvent(FHandle);
end;

function TJclEvent.SetEvent: Boolean;
begin
  Result := Windows.SetEvent(FHandle);
end;

//=== { TJclWaitableTimer } ==================================================

{ TODO: Use RTLD version of CreateWaitableTimer }
constructor TJclWaitableTimer.Create(SecAttr: PSecurityAttributes;
  Manual: Boolean; const Name: string);
begin
  FName := Name;
  FResume := False;
  FHandle := CreateWaitableTimer(SecAttr, Manual, PChar(Name));
  if FHandle = 0 then
    raise EJclWaitableTimerError.CreateRes(@RsSynchCreateWaitableTimer);
  FExisted := GetLastError = ERROR_ALREADY_EXISTS;
end;

{ TODO: Use RTLD version of CancelWaitableTimer }
function TJclWaitableTimer.Cancel: Boolean;
begin
  Result := CancelWaitableTimer(FHandle);
end;

{ TODO: Use RTLD version of OpenWaitableTimer }

constructor TJclWaitableTimer.Open(Access: Cardinal; Inheritable: Boolean;
  const Name: string);
begin
  FExisted := True;
  FName := Name;
  FResume := False;
  FHandle := OpenWaitableTimer(Access, Inheritable, PChar(Name));
  if FHandle = 0 then
    raise EJclWaitableTimerError.CreateRes(@RsSynchOpenWaitableTimer);
end;

{ TODO: Use RTLD version of SetWaitableTimer }
function TJclWaitableTimer.SetTimer(const DueTime: Int64; Period: Longint;
  Resume: Boolean): Boolean;
var
  DT: Int64;
begin
  DT := DueTime;
  Result := SetWaitableTimer(FHandle, DT, Period, nil, nil, FResume);
end;

{ TODO -cHelp : OS restrictions }
function TJclWaitableTimer.SetTimerApc(const DueTime: Int64; Period: Longint;
  Resume: Boolean; Apc: TFNTimerAPCRoutine; Arg: Pointer): Boolean;
var
  DT: Int64;
begin
  DT := DueTime;
  Result := RtdlSetWaitableTimer(FHandle, DT, Period, Apc, Arg, FResume);
  { TODO : Exception for Win9x, older WinNT? }
  // if not Result and (GetLastError = ERROR_CALL_NOT_IMPLEMENTED) then
  //   RaiseLastOSError;
end;

//== { TJclSemaphore } =======================================================

constructor TJclSemaphore.Create(SecAttr: PSecurityAttributes;
  Initial, Maximum: Integer; const Name: string);
begin
  Assert((Initial >= 0) and (Maximum > 0));
  FName := Name;
  FHandle := Windows.CreateSemaphore(SecAttr, Initial, Maximum, PChar(Name));
  if FHandle = 0 then
    raise EJclSemaphoreError.CreateRes(@RsSynchCreateSemaphore);
  FExisted := GetLastError = ERROR_ALREADY_EXISTS;
end;

constructor TJclSemaphore.Open(Access: Cardinal; Inheritable: Boolean;
  const Name: string);
begin
  FName := Name;
  FExisted := True;
  FHandle := Windows.OpenSemaphore(Access, Inheritable, PChar(Name));
  if FHandle = 0 then
    raise EJclSemaphoreError.CreateRes(@RsSynchOpenSemaphore);
end;

function TJclSemaphore.ReleasePrev(ReleaseCount: Longint;
  var PrevCount: Longint): Boolean;
begin
  Result := Windows.ReleaseSemaphore(FHandle, ReleaseCount, @PrevCount);
end;

function TJclSemaphore.Release(ReleaseCount: Integer): Boolean;
begin
  Result := Windows.ReleaseSemaphore(FHandle, ReleaseCount, nil);
end;

//=== { TJclMutex } ==========================================================

constructor TJclMutex.Create(SecAttr: PSecurityAttributes; InitialOwner: Boolean; const Name: string);
begin
  FName := Name;
  FHandle := JclWin32.CreateMutex(SecAttr, Ord(InitialOwner), PChar(Name));
  if FHandle = 0 then
    raise EJclMutexError.CreateRes(@RsSynchCreateMutex);
  FExisted := GetLastError = ERROR_ALREADY_EXISTS;
end;

constructor TJclMutex.Open(Access: Cardinal; Inheritable: Boolean; const Name: string);
begin
  FName := Name;
  FExisted := True;
  FHandle := Windows.OpenMutex(Access, Inheritable, PChar(Name));
  if FHandle = 0 then
    raise EJclMutexError.CreateRes(@RsSynchOpenMutex);
end;

function TJclMutex.Release: Boolean;
begin
  Result := Windows.ReleaseMutex(FHandle);
end;

//=== { TJclOptex } ==========================================================

constructor TJclOptex.Create(const Name: string; SpinCount: Integer);
begin
  FExisted := False;
  FName := Name;
  if Name = '' then
  begin
    // None shared optex, don't need filemapping, sharedinfo is local
    FFileMapping := 0;
    FEvent := TJclEvent.Create(nil, False, False, '');
    FSharedInfo := AllocMem(SizeOf(TOptexSharedInfo));
  end
  else
  begin
    // Shared optex, event protects access to sharedinfo. Creation of filemapping
    // doesn't need protection as it will automatically "open" instead of "create"
    // if another process already created it.
    FEvent := TJclEvent.Create(nil, False, False, 'Optex_Event_' + Name);
    FExisted := FEvent.Existed;
    FFileMapping := Windows.CreateFileMapping(INVALID_HANDLE_VALUE, nil, PAGE_READWRITE,
      0, SizeOf(TOptexSharedInfo), PChar('Optex_MMF_' + Name));
    Assert(FFileMapping <> 0);
    FSharedInfo := Windows.MapViewOfFile(FFileMapping, FILE_MAP_WRITE, 0, 0, 0);
    Assert(FSharedInfo <> nil);
  end;
  SetSpinCount(SpinCount);
end;

destructor TJclOptex.Destroy;
begin
  FreeAndNil(FEvent);
  if UniProcess then
    FreeMem(FSharedInfo)
  else
  begin
    Windows.UnmapViewOfFile(FSharedInfo);
    Windows.CloseHandle(FFileMapping);
  end;
  inherited Destroy;
end;

procedure TJclOptex.Enter;
var
  ThreadId: Longword;
begin
  if TryEnter then
    Exit;
  ThreadId := Windows.GetCurrentThreadId;
  if Windows.InterlockedIncrement(FSharedInfo^.LockCount) = 1 then
  begin
    // Optex was unowned
    FSharedInfo^.ThreadId := ThreadId;
    FSharedInfo^.RecursionCount := 1;
  end
  else
  begin
    if FSharedInfo^.ThreadId = ThreadId then
    begin
      // We already owned it, increase ownership count
      Inc(FSharedInfo^.RecursionCount)
    end
    else
    begin
      // Optex is owner by someone else, wait for it to be released and then
      // immediately take ownership
      FEvent.WaitForever;
      FSharedInfo^.ThreadId := ThreadId;
      FSharedInfo^.RecursionCount := 1;
    end;
  end;
end;

function TJclOptex.GetSpinCount: Integer;
begin
  Result := FSharedInfo^.SpinCount;
end;

function TJclOptex.GetUniProcess: Boolean;
begin
  Result := FFileMapping = 0;
end;

procedure TJclOptex.Leave;
begin
  Dec(FSharedInfo^.RecursionCount);
  if FSharedInfo^.RecursionCount > 0 then
    Windows.InterlockedDecrement(FSharedInfo^.LockCount)
  else
  begin
    FSharedInfo^.ThreadId := 0;
    if Windows.InterlockedDecrement(FSharedInfo^.LockCount) > 0 then
      FEvent.SetEvent;
  end;
end;

procedure TJclOptex.SetSpinCount(Value: Integer);
begin
  if Value < 0 then
    Value := DefaultCritSectSpinCount;
  // Spinning only makes sense on multiprocessor systems
  if ProcessorCount > 1 then
    Windows.InterlockedExchange(Integer(FSharedInfo^.SpinCount), Value);
end;

function TJclOptex.TryEnter: Boolean;
var
  ThreadId: Longword;
  ThreadOwnsOptex: Boolean;
  SpinCount: Integer;
begin
  ThreadId := Windows.GetCurrentThreadId;
  SpinCount := FSharedInfo^.SpinCount;
  repeat
    //ThreadOwnsOptex := InterlockedCompareExchange(Pointer(FSharedInfo^.LockCount),
    //  Pointer(1), Pointer(0)) = Pointer(0); // not available on win95
    ThreadOwnsOptex := LockedCompareExchange(FSharedInfo^.LockCount, 1, 0) = 0;
    if ThreadOwnsOptex then
    begin
      // Optex was unowned
      FSharedInfo^.ThreadId := ThreadId;
      FSharedInfo^.RecursionCount := 1;
    end
    else
    begin
      if FSharedInfo^.ThreadId = ThreadId then
      begin
        // We already owned the Optex
        Windows.InterlockedIncrement(FSharedInfo^.LockCount);
        Inc(FSharedInfo^.RecursionCount);
        ThreadOwnsOptex := True;
      end;
    end;
    Dec(SpinCount);
  until ThreadOwnsOptex or (SpinCount <= 0);
  Result := ThreadOwnsOptex;
end;

//=== { TJclMultiReadExclusiveWrite } ========================================

constructor TJclMultiReadExclusiveWrite.Create(Preferred: TMrewPreferred);
begin
  inherited Create;
  FLock := TJclCriticalSection.Create;
  FPreferred := Preferred;
  FSemReaders := TJclSemaphore.Create(nil, 0, MaxInt, '');
  FSemWriters := TJclSemaphore.Create(nil, 0, MaxInt, '');
  SetLength(FThreads, 0);
  FState := 0;
  FWaitingReaders := 0;
  FWaitingWriters := 0;
end;

destructor TJclMultiReadExclusiveWrite.Destroy;
begin
  FreeAndNil(FSemReaders);
  FreeAndNil(FSemWriters);
  FreeAndNil(FLock);
  inherited Destroy;
end;

procedure TJclMultiReadExclusiveWrite.AddToThreadList(ThreadId: Longword;
  Reader: Boolean);
var
  L: Integer;
begin
  // Caller must own lock
  L := Length(FThreads);
  SetLength(FThreads, L + 1);
  FThreads[L].ThreadId := ThreadId;
  FThreads[L].RecursionCount := 1;
  FThreads[L].Reader := Reader;
end;

procedure TJclMultiReadExclusiveWrite.BeginRead;
var
  ThreadId: Longword;
  Index: Integer;
  MustWait: Boolean;
begin
  MustWait := False;
  ThreadId := Windows.GetCurrentThreadId;
  FLock.Enter;
  try
    Index := FindThread(ThreadId);
    if Index >= 0 then
    begin
      // Thread is on threadslist so it is already reading
      Inc(FThreads[Index].RecursionCount);
    end
    else
    begin
      // Request to read (first time)
      AddToThreadList(ThreadId, True);
      if FState >= 0 then
      begin
        // MREW is unowned or only readers. If there are no waiting writers or
        // readers are preferred then allow thread to continue, otherwise it must
        // wait it's turn
        if (FPreferred = mpReaders) or (FWaitingWriters = 0) then
          Inc(FState)
        else
        begin
          Inc(FWaitingReaders);
          MustWait := True;
        end;
      end
      else
      begin
        // MREW is owner by a writer, must wait
        Inc(FWaitingReaders);
        MustWait := True;
      end;
    end;
  finally
    FLock.Leave;
  end;
  if MustWait then
    FSemReaders.WaitForever;
end;

procedure TJclMultiReadExclusiveWrite.BeginWrite;
var
  ThreadId: Longword;
  Index: Integer;
  MustWait: Boolean;
begin
  MustWait := False;
  FLock.Enter;
  try
    ThreadId := Windows.GetCurrentThreadId;
    Index := FindThread(ThreadId);
    if Index < 0 then
    begin
      // Request to write (first time)
      AddToThreadList(ThreadId, False);
      if FState = 0 then
      begin
        // MREW is unowned so start writing
        FState := -1;
      end
      else
      begin
        // MREW is owner, must wait
        Inc(FWaitingWriters);
        MustWait := True;
      end;
    end
    else
    begin
      if FThreads[Index].Reader then
      begin
        // Request to write while reading
        Inc(FThreads[Index].RecursionCount);
        FThreads[Index].Reader := False;
        Dec(FState);
        if FState = 0 then
        begin
          // MREW is unowned so start writing
          FState := -1;
        end
        else
        begin
          // MREW is owned, must wait
          MustWait := True;
          Inc(FWaitingWriters);
        end;
      end
      else
        // Requesting to write while already writing
        Inc(FThreads[Index].RecursionCount);
    end;
  finally
    FLock.Leave;
  end;
  if MustWait then
    FSemWriters.WaitFor(INFINITE);
end;

procedure TJclMultiReadExclusiveWrite.EndRead;
begin
  Release;
end;

procedure TJclMultiReadExclusiveWrite.EndWrite;
begin
  Release;
end;

function TJclMultiReadExclusiveWrite.FindThread(ThreadId: Longword): Integer;
var
  I: Integer;
begin
  // Caller must lock
  Result := -1;
  for I := 0 to Length(FThreads) - 1 do
    if FThreads[I].ThreadId = ThreadId then
    begin
      Result := I;
      Exit;
    end;
end;

procedure TJclMultiReadExclusiveWrite.Release;
var
  ThreadId: Longword;
  Index: Integer;
  WasReading: Boolean;
begin
  ThreadId := GetCurrentThreadId;
  FLock.Enter;
  try
    Index := FindThread(ThreadId);
    if Index >= 0 then
    begin
      Dec(FThreads[Index].RecursionCount);
      if FThreads[Index].RecursionCount = 0 then
      begin
        WasReading := FThreads[Index].Reader;
        if WasReading then
          Dec(FState)
        else
          FState := 0;
        RemoveFromThreadList(Index);
        if FState = 0 then
          ReleaseWaiters(WasReading);
      end;
    end;
  finally
    FLock.Leave;
  end;
end;

procedure TJclMultiReadExclusiveWrite.ReleaseWaiters(WasReading: Boolean);
var
  ToRelease: TMrewPreferred;
begin
  // Caller must Lock
  ToRelease := mpEqual;
  case FPreferred of
    mpReaders:
      if FWaitingReaders > 0 then
        ToRelease := mpReaders
      else
      if FWaitingWriters > 0 then
        ToRelease := mpWriters;
    mpWriters:
      if FWaitingWriters > 0 then
        ToRelease := mpWriters
      else
      if FWaitingReaders > 0 then
        ToRelease := mpReaders;
    mpEqual:
      if WasReading then
      begin
        if FWaitingWriters > 0 then
          ToRelease := mpWriters
        else
        if FWaitingReaders > 0 then
          ToRelease := mpReaders;
      end
      else
      begin
        if FWaitingReaders > 0 then
          ToRelease := mpReaders
        else
        if FWaitingWriters > 0 then
          ToRelease := mpWriters;
      end;
  end;
  case ToRelease of
    mpReaders:
      begin
        FState := FWaitingReaders;
        FWaitingReaders := 0;
        FSemReaders.Release(FState);
      end;
    mpWriters:
      begin
        FState := -1;
        Dec(FWaitingWriters);
        FSemWriters.Release(1);
      end;
    mpEqual:
      // no waiters
  end;
end;

procedure TJclMultiReadExclusiveWrite.RemoveFromThreadList(Index: Integer);
var
  L: Integer;
begin
  // Caller must Lock
  L := Length(FThreads);
  Move(FThreads[Index + 1], FThreads[Index], SizeOf(TMrewThreadInfo) * (L - Index - 1));
  SetLength(FThreads, L - 1);
end;

//=== { TJclMeteredSection } =================================================

const
  MAX_METSECT_NAMELEN = 128;

constructor TJclMeteredSection.Create(InitialCount, MaxCount: Integer; const Name: string);
begin
  if (MaxCount < 1) or (InitialCount > MaxCount) or (InitialCount < 0) or
    (Length(Name) > MAX_METSECT_NAMELEN) then
    raise EJclMeteredSectionError.CreateRes(@RsMetSectInvalidParameter);
  FMetSect := PMeteredSection(AllocMem(SizeOf(TMeteredSection)));
  if FMetSect <> nil then
  begin
    if not InitMeteredSection(InitialCount, MaxCount, Name, False) then
    begin
      CloseMeteredSection;
      FMetSect := nil;
      raise EJclMeteredSectionError.CreateRes(@RsMetSectInitialize);
    end;
  end;
end;

constructor TJclMeteredSection.Open(const Name: string);
begin
  FMetSect := nil;
  if Name = '' then
    raise EJclMeteredSectionError.CreateRes(@RsMetSectNameEmpty);
  FMetSect := PMeteredSection(AllocMem(SizeOf(TMeteredSection)));
  Assert(FMetSect <> nil);
  if not InitMeteredSection(0, 0, Name, True) then
  begin
    CloseMeteredSection;
    FMetSect := nil;
    raise EJclMeteredSectionError.CreateRes(@RsMetSectInitialize);
  end;
end;

destructor TJclMeteredSection.Destroy;
begin
  CloseMeteredSection;
  inherited Destroy;
end;

procedure TJclMeteredSection.AcquireLock;
begin
  while Windows.InterlockedExchange(FMetSect^.SharedInfo^.SpinLock, 1) <> 0 do
    Windows.Sleep(0);
end;

procedure TJclMeteredSection.CloseMeteredSection;
begin
  if FMetSect <> nil then
  begin
    if FMetSect^.SharedInfo <> nil then
      Windows.UnmapViewOfFile(FMetSect^.SharedInfo);
    if FMetSect^.FileMap <> 0 then
      Windows.CloseHandle(FMetSect^.FileMap);
    if FMetSect^.Event <> 0 then
      Windows.CloseHandle(FMetSect^.Event);
    FreeMem(FMetSect);
  end;
end;

function TJclMeteredSection.CreateMetSectEvent(const Name: string; OpenOnly: Boolean): Boolean;
var
  FullName: string;
begin
  if Name = '' then
    FMetSect^.Event := Windows.CreateEvent(nil, False, False, nil)
  else
  begin
    FullName :=  'JCL_MSECT_EVT_' + Name;
    if OpenOnly then
      FMetSect^.Event := Windows.OpenEvent(0, False, PChar(FullName))
    else
      FMetSect^.Event := Windows.CreateEvent(nil, False, False, PChar(FullName));
  end;
  Result := FMetSect^.Event <> 0;
end;

function TJclMeteredSection.CreateMetSectFileView(InitialCount, MaxCount: Longint;
  const Name: string; OpenOnly: Boolean): Boolean;
var
  FullName: string;
  LastError: DWORD;
begin
  Result := False;
  if Name = '' then
    FMetSect^.FileMap := Windows.CreateFileMapping(INVALID_HANDLE_VALUE, nil, PAGE_READWRITE, 0, SizeOf(TMetSectSharedInfo), nil)
  else
  begin
    FullName := 'JCL_MSECT_MMF_' + Name;
    if OpenOnly then
      FMetSect^.FileMap := Windows.OpenFileMapping(0, False, PChar(FullName))
    else
      FMetSect^.FileMap := Windows.CreateFileMapping(INVALID_HANDLE_VALUE, nil, PAGE_READWRITE, 0, SizeOf(TMetSectSharedInfo), PChar(FullName));
  end;
  if FMetSect^.FileMap <> 0 then
  begin
    LastError := GetLastError;
    FMetSect^.SharedInfo := Windows.MapViewOfFile(FMetSect^.FileMap, FILE_MAP_WRITE, 0, 0, 0);
    if FMetSect^.SharedInfo <> nil then
    begin
      if LastError = ERROR_ALREADY_EXISTS then
        while not FMetSect^.SharedInfo^.Initialized do Sleep(0)
      else
      begin
        FMetSect^.SharedInfo^.SpinLock := 0;
        FMetSect^.SharedInfo^.ThreadsWaiting := 0;
        FMetSect^.SharedInfo^.AvailableCount := InitialCount;
        FMetSect^.SharedInfo^.MaximumCount := MaxCount;
        Windows.InterlockedExchange(Integer(FMetSect^.SharedInfo^.Initialized), 1);
      end;
      Result := True;
    end;
  end;
end;

function TJclMeteredSection.Enter(TimeOut: Longword): TJclWaitResult;
begin
  Result := wrSignaled;
  while Result = wrSignaled do
  begin
    AcquireLock;
    try
      if FMetSect^.SharedInfo^.AvailableCount >= 1 then
      begin
        Dec(FMetSect^.SharedInfo^.AvailableCount);
        Result := MapSignalResult(WAIT_OBJECT_0);
        Exit;
      end;
      Inc(FMetSect^.SharedInfo^.ThreadsWaiting);
      Windows.ResetEvent(FMetSect^.Event);
    finally
      ReleaseLock;
    end;
    Result := MapSignalResult(Windows.WaitForSingleObject(FMetSect^.Event, TimeOut));
  end;
end;

function TJclMeteredSection.InitMeteredSection(InitialCount, MaxCount: Longint;
  const Name: string; OpenOnly: Boolean): Boolean;
begin
  Result := False;
  if CreateMetSectEvent(Name, OpenOnly) then
    Result := CreateMetSectFileView(InitialCount, MaxCount, Name, OpenOnly);
end;

function TJclMeteredSection.Leave(ReleaseCount: Integer; var PrevCount: Integer): Boolean;
var
  Count: Integer;
begin
  Result := False;
  AcquireLock;
  try
    PrevCount := FMetSect^.SharedInfo^.AvailableCount;
    if (ReleaseCount < 0) or
      (FMetSect^.SharedInfo^.AvailableCount + ReleaseCount > FMetSect^.SharedInfo^.MaximumCount) then
    begin
      Windows.SetLastError(ERROR_INVALID_PARAMETER);
      Exit;
    end;
    Inc(FMetSect^.SharedInfo^.AvailableCount, ReleaseCount);
    ReleaseCount := Min(ReleaseCount, FMetSect^.SharedInfo^.ThreadsWaiting);
    if FMetSect^.SharedInfo^.ThreadsWaiting > 0 then
    begin
      for Count := 0 to ReleaseCount - 1 do
      begin
        Dec(FMetSect^.SharedInfo^.ThreadsWaiting);
        Windows.SetEvent(FMetSect^.Event);
      end;
    end;
  finally
    ReleaseLock;
  end;
  Result := True;
end;

function TJclMeteredSection.Leave(ReleaseCount: Integer): Boolean;
var
  Previous: Longint;
begin
  Result := Leave(ReleaseCount, Previous);
end;

procedure TJclMeteredSection.ReleaseLock;
begin
  Windows.InterlockedExchange(FMetSect^.SharedInfo^.SpinLock, 0);
end;

//=== Debugging ==============================================================

function QueryCriticalSection(CS: TJclCriticalSection; var Info: TRTLCriticalSection): Boolean;
begin
  Result := CS <> nil;
  if Result then
    Info := CS.FCriticalSection;
end;

// Native API functions
// http://undocumented.ntinternals.net/

{ TODO: RTLD version }

type
 TNtQueryProc = function (Handle: THandle; InfoClass: Byte; Info: Pointer;
     Len: Longint; ResLen: PLongint): Longint; stdcall;

 var
   _QueryEvent: TNtQueryProc = nil;
   _QueryMutex: TNtQueryProc = nil;
   _QuerySemaphore: TNtQueryProc = nil;
   _QueryTimer: TNtQueryProc = nil;

 function CallQueryProc(var P: TNtQueryProc; const Name: string; Handle: THandle;
   Info: Pointer; InfoSize: Longint): Boolean;
 var
   NtDll: THandle;
   Status: Longint;
 begin
   Result := False;
   if @P = nil then
   begin
     NtDll := GetModuleHandle(PChar('ntdll.dll'));
     if NtDll <> 0 then
       @P := GetProcAddress(NtDll, PChar(Name));
   end;
   if @P <> nil then
   begin
     Status := P(Handle, 0, Info, InfoSize, nil);
     Result := (Status and $80000000) = 0;
   end;
 end;

function QueryEvent(Handle: THandle; var Info: TEventInfo): Boolean;
begin
  Result := CallQueryProc(_QueryEvent, 'NtQueryEvent', Handle, @Info, SizeOf(Info));
end;

function QueryMutex(Handle: THandle; var Info: TMutexInfo): Boolean;
begin
  Result := CallQueryProc(_QueryMutex, 'NtQueryMutex', Handle, @Info, SizeOf(Info));
end;

function QuerySemaphore(Handle: THandle; var Info: TSemaphoreCounts): Boolean;
begin
  Result := CallQueryProc(_QuerySemaphore, 'NtQuerySemaphore', Handle, @Info, SizeOf(Info));
end;

function QueryTimer(Handle: THandle; var Info: TTimerInfo): Boolean;
begin
  Result := CallQueryProc(_QueryTimer, 'NtQueryTimer', Handle, @Info, SizeOf(Info));
end;

// History:

// $Log: JclSynch.pas,v $
// Revision 1.17  2005/03/08 08:33:23  marquardt
// overhaul of exceptions and resourcestrings, minor style cleaning
//
// Revision 1.16  2005/03/04 06:40:26  marquardt
// changed overloaded constructors to constructor with default parameter (BCB friendly)
//
// Revision 1.15  2005/02/24 16:34:53  marquardt
// remove divider lines, add section lines (unfinished)
//
// Revision 1.14  2004/10/21 08:40:11  marquardt
// style cleaning
//
// Revision 1.13  2004/10/17 23:09:37  mthoma
// More cleaning. Removing RTLD versions of some functions.
//
// Revision 1.12  2004/10/17 21:00:16  mthoma
// cleaning
//
// Revision 1.11  2004/08/01 11:40:23  marquardt
// move constructors/destructors
//
// Revision 1.10  2004/07/28 18:00:54  marquardt
// various style cleanings, some minor fixes
//
// Revision 1.9  2004/07/26 03:47:36  rrossmair
// replaced SetCriticalSectionSpinCount by RtdlSetCriticalSectionSpinCount to make it Win95 compatible
//
// Revision 1.8  2004/06/02 03:23:47  rrossmair
// cosmetic changes in several units (code formatting, help TODOs processed etc.)
//
// Revision 1.7  2004/05/09 10:13:38  ahuser
// Better Delphi 7.1 fix that does not throw hints for older versions
//
// Revision 1.6  2004/05/07 19:29:09  ahuser
// Fix for Delphi 7.1 compiler warning bug.
//
// Revision 1.5  2004/05/05 07:33:49  rrossmair
// header updated according to new policy: initial developers & contributors listed
//
// Revision 1.4  2004/04/06 04:55:18  
// adapt compiler conditions, add log entry
//

end.