jclsynch.pas

East make Tray Icon in delphi

{**************************************************************************************************}
{                                                                                                  }
{ 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