unit xSychronizers;

interface
  USES Windows, SysUtils;

type
  TActiveThreadRecord = record
    ThreadID: Integer;
    RecursionCount: Integer;
  end;
  TActiveThreadArray = array of TActiveThreadRecord;

  TMultiReadExclusiveWriteSynchronizerEx = class
  private
    FLock: TRTLCriticalSection;
    FReadExit: THandle;
    FWriteLock: THandle;
    FCount: Integer;
    FSaveReadCount: Integer;
    FActiveThreads: TActiveThreadArray;
    FWriteRequestorID: Integer;
    FReallocFlag: Integer;
    FWriting: Boolean;
    function WriterIsOnlyReader: Boolean;
    function AlreadyInRead: Boolean;
    procedure PlaceInRead;
  public
    constructor Create;
    destructor Destroy; override;
    procedure BeginRead;
    function  BeginReadTimeOut(TimeOut:cardinal):dword;
    procedure EndRead;
    procedure BeginWrite;
    function  BeginWriteTimeOut(TimeOut:cardinal):dword;
    procedure EndWrite;
  end;


implementation
{ TMultiReadExclusiveWriteSynchronizer }

constructor TMultiReadExclusiveWriteSynchronizerEx.Create;
begin
  InitializeCriticalSection(FLock);
  EnterCriticalSection(FLock);  // Block new read or write ops from starting

  FWriteLock:= CreateMutex(nil, True, nil);  // start owned
  FReadExit := CreateEvent(nil, True, True, nil);  // manual reset, start signaled
  inherited Create;
  SetLength(FActiveThreads, 4);

  LeaveCriticalSection(FLock);
  ReleaseMutex(FWriteLock);
end;

destructor TMultiReadExclusiveWriteSynchronizerEx.Destroy;
begin
  BeginWrite;
  EnterCriticalSection(FLock);  // Block new read or write ops from starting
  inherited Destroy;
  CloseHandle(FReadExit);
  CloseHandle(FWriteLock);
  DeleteCriticalSection(FLock);
end;

function TMultiReadExclusiveWriteSynchronizerEx.WriterIsOnlyReader: Boolean;
var
  I, Len: Integer;
begin
  Result := False;
  if FWriteRequestorID = 0 then Exit;
  // We know a writer is waiting for entry with the FLock locked,
  // so FActiveThreads is stable - no BeginRead could be resizing it now
  I := 0;
  Len := High(FActiveThreads);
  while (I < Len) and
    ((FActiveThreads[I].ThreadID = 0) or (FActiveThreads[I].ThreadID = FWriteRequestorID)) do
    Inc(I);
  Result := I >= Len;
end;

procedure TMultiReadExclusiveWriteSynchronizerEx.BeginWrite;
begin
  WaitForSingleObject(FWriteLock,INFINITE);
  if not FWriting then
  begin
    FWriteRequestorID := GetCurrentThreadID;   // Indicate that writer is waiting for entry
    if not WriterIsOnlyReader then              // See if any other thread is reading
      WaitForSingleObject(FReadExit, INFINITE); // Wait for current readers to finish
    FSaveReadCount := FCount;  // record prior read recursions for this thread
    FCount := 0;
    FWriteRequestorID := 0;
    FWriting := True;
  end;
  Inc(FCount);  // allow read recursions during write without signalling FReadExit event
end;

function TMultiReadExclusiveWriteSynchronizerEx.BeginWriteTimeOut(TimeOut:cardinal):dword;
begin
  Result:=WaitForSingleObject(FWriteLock,TimeOut);
  if Result=WAIT_TIMEOUT then Exit;
  if not FWriting then
  begin
    FWriteRequestorID := GetCurrentThreadID;   // Indicate that writer is waiting for entry
    if not WriterIsOnlyReader then begin        // See if any other thread is reading
      if WaitForSingleObject(FReadExit, TimeOut)<>WAIT_OBJECT_0 then begin
        FWriteRequestorID := 0;
        ReleaseMutex(FWriteLock);
        exit; // Wait for current readers to finish
      end;
    end;
    FSaveReadCount := FCount;  // record prior read recursions for this thread
    FCount := 0;
    FWriteRequestorID := 0;
    FWriting := True;
  end;
  Inc(FCount);  // allow read recursions during write without signalling FReadExit event
end;

procedure TMultiReadExclusiveWriteSynchronizerEx.EndWrite;
begin
//  if WaitForSingleObject(FWriteLock,INFINITE)=WAIT_OBJECT_0 then
  Dec(FCount);
  if FCount = 0 then
  begin
    FCount := FSaveReadCount;  // restore read recursion count
    FSaveReadCount := 0;
    FWriting := False;
    ReleaseMutex(FWriteLock);
  end;
end;

procedure TMultiReadExclusiveWriteSynchronizerEx.BeginRead;
begin
  if not AlreadyInRead then begin
    // Ok, we don't already have a lock, so do the hard work of making one
    EnterCriticalSection(FLock);
    try
      PlaceInRead;
    finally
      LeaveCriticalSection(FLock);
    end;
  end;
end;

function  TMultiReadExclusiveWriteSynchronizerEx.BeginReadTimeOut(TimeOut:cardinal):dword;
begin
  if AlreadyInRead then begin
    Result:=WAIT_OBJECT_0;
  end else begin
    // Ok, we don't already have a lock, so do the hard work of making one
    Result:=WaitForSingleObject(FWriteLock,TimeOut);
    if Result=WAIT_TIMEOUT then Exit;
    EnterCriticalSection(FLock);
    try
      PlaceInRead;
    finally
      LeaveCriticalSection(FLock);
      ReleaseMutex(FWriteLock);
    end;
  end;
end;

function TMultiReadExclusiveWriteSynchronizerEx.AlreadyInRead: Boolean;
var
  I: Integer;
  ThreadID: Integer;
  ZeroSlot: Integer;
begin
  ThreadID := GetCurrentThreadID;
  // First, do a lightweight check to see if this thread already has a read lock
  while InterlockedExchange(FReallocFlag, ThreadID) <> 0 do  Sleep(0);
  try    // FActiveThreads array is now stable
    I := 0;
    while (I < High(FActiveThreads)) and (FActiveThreads[I].ThreadID <> ThreadID) do
      Inc(I);
    Result := I < High(FActiveThreads);
    if Result then  // This thread already has a read lock
    begin                   // Don't grab FLock, since that could deadlock with
      if not FWriting then  // a waiting BeginWrite
      begin                 // Bump up ref counts and exit
        InterlockedIncrement(FCount);
        Inc(FActiveThreads[I].RecursionCount); // thread safe = unique to threadid
      end;
    end
  finally
    FReallocFlag := 0;
  end;
end;

procedure TMultiReadExclusiveWriteSynchronizerEx.PlaceInRead;
var
  I: Integer;
  ThreadID: Integer;
  ZeroSlot: Integer;
begin
  ThreadID := GetCurrentThreadID;
  if not FWriting then  begin
  EnterCriticalSection(FLock);  // Block new read or write ops from starting
   // This will call ResetEvent more than necessary on win95, but still work
   if InterlockedIncrement(FCount) = 1 then
     ResetEvent(FReadExit); // Make writer wait until all readers are finished.
     I := 0;  // scan for empty slot in activethreads list
     ZeroSlot := -1;
     while (I < High(FActiveThreads)) and (FActiveThreads[I].ThreadID <> ThreadID) do begin
       if (FActiveThreads[I].ThreadID = 0) and (ZeroSlot < 0) then ZeroSlot := I;
       Inc(I);
     end;
     if I >= High(FActiveThreads) then  // didn't find our threadid slot
     begin
       if ZeroSlot < 0 then  // no slots available.  Grow array to make room
       begin   // spin loop.  wait for EndRead to put zero back into FReallocFlag
         while InterlockedExchange(FReallocFlag, ThreadID) <> 0 do  Sleep(0);
         try
           SetLength(FActiveThreads, High(FActiveThreads) + 3);
         finally
           FReallocFlag := 0;
         end;
       end
       else  // use an empty slot
         I := ZeroSlot;
        // no concurrency issue here.  We're the only thread interested in this record.
       FActiveThreads[I].ThreadID := ThreadID;
       FActiveThreads[I].RecursionCount := 1;
     end
     else  // found our threadid slot.
       Inc(FActiveThreads[I].RecursionCount); // thread safe = unique to threadid
  end;
end;

procedure TMultiReadExclusiveWriteSynchronizerEx.EndRead;
var
  I, ThreadID, Len: Integer;
begin
  if not FWriting then
  begin
    // Remove our threadid from the list of active threads
    I := 0;
    ThreadID := GetCurrentThreadID;
    // wait for BeginRead to finish any pending realloc of FActiveThreads
    while InterlockedExchange(FReallocFlag, ThreadID) <> 0 do  Sleep(0);
    try
      Len := High(FActiveThreads);
      while (I < Len) and (FActiveThreads[I].ThreadID <> ThreadID) do Inc(I);
      assert(I < Len);
      // no concurrency issues here.  We're the only thread interested in this record.
      Dec(FActiveThreads[I].RecursionCount); // threadsafe = unique to threadid
      if FActiveThreads[I].RecursionCount = 0 then
        FActiveThreads[I].ThreadID := 0; // must do this last!
    finally
      FReallocFlag := 0;
    end;
    if (InterlockedDecrement(FCount) = 0) or WriterIsOnlyReader then
      SetEvent(FReadExit);     // release next writer
  end;
end;

END.