Delphi 高效讀寫鎖

https://github.com/search?q=GetQueuedCompletionStatus+WaitforMultipleObjects&type=Code

 

本人設計了一個高效讀寫鎖，可實現多個線程讀一個線程寫的鎖，應該比Delphi自帶的讀寫鎖高效，本人沒有做對比測試。

本文的鎖不可以在一個線程里重入，否則會鎖死，另外讀寫鎖最多支持65535個線程同時讀。

// HeZiHang@cnblogs
// 跨平台簡易高效鎖
 
unit utLocker;
 
interface
 
type
  // 多讀單寫鎖
  // 1.寫的時候阻塞其他所有寫和讀
  // 2.讀的時候不阻塞其他讀，但阻塞所有寫，當阻塞了一個或以上的寫后，將阻塞所有后來新的讀
  TMultiReadSingleWriteLocker = class
  protected
    [Volatile]
    FLocker: Integer;
  public
    procedure LockRead;
    procedure UnLockRead; inline;
    procedure LockWrite;
    procedure UnLockWrite; inline;
    function TryLockRead: Boolean; inline;
    function TryLockWrite: Boolean; inline;
    constructor Create;
  end;
 
  TSimpleLocker = class
  protected
    [Volatile]
    FLocker: Integer;
  public
    procedure Lock;
    procedure UnLock; inline;
    function TryLock: Boolean; inline;
  end;
 
implementation
 
uses System.SyncObjs, System.SysUtils, System.Classes;
 
type
  TSpinWait = record
  private const
    YieldThreshold = 10;
    Sleep1Threshold = 20;
    Sleep0Threshold = 5;
  private
    FCount: Integer;
    function GetNextSpinCycleWillYield: Boolean; inline;
  public
    procedure Reset;inline;
    procedure SpinCycle;inline;
 
    property Count: Integer read FCount;
    property NextSpinCycleWillYield: Boolean read GetNextSpinCycleWillYield;
  end;
 
  { TSpinWait }
 
function TSpinWait.GetNextSpinCycleWillYield: Boolean;
begin
  Result := (FCount > YieldThreshold) or (CPUCount = 1);
end;
 
procedure TSpinWait.Reset;
begin
  FCount := 0;
end;
 
procedure TSpinWait.SpinCycle;
var
  SpinCount: Integer;
begin
  if NextSpinCycleWillYield then
  begin
    if FCount >= YieldThreshold then
      SpinCount := FCount - YieldThreshold
    else
      SpinCount := FCount;
    if SpinCount mod Sleep1Threshold = Sleep1Threshold - 1 then
      TThread.Sleep(1)
    else if SpinCount mod Sleep0Threshold = Sleep0Threshold - 1 then
      TThread.Sleep(0)
    else
      TThread.Yield;
  end
  else
    TThread.SpinWait(4 shl FCount);
  Inc(FCount);
  if FCount < 0 then
    FCount := YieldThreshold + 1;
end;
 
{ TMultiReadSingleWriteLocker }
 
procedure TMultiReadSingleWriteLocker.LockRead;
var
  CurLock: Integer;
  Wait: TSpinWait;
begin
  Wait.Reset;
  while True do
  begin
    CurLock := FLocker;
    if CurLock <= $FFFF then
    begin
      if TInterlocked.CompareExchange(FLocker, CurLock + 1, CurLock) = CurLock
      then
        Exit;
    end;
    Wait.SpinCycle;
  end;
end;
 
procedure TMultiReadSingleWriteLocker.LockWrite;
var
  CurLock: Integer;
  Wait: TSpinWait;
begin
  Wait.Reset;
  while True do
  begin
    CurLock := FLocker;
    if CurLock <= $FFFF then
    begin
      if TInterlocked.CompareExchange(FLocker, CurLock + $10000, CurLock) = CurLock
      then
        Exit;
    end;
    Wait.SpinCycle;
  end;
end;
 
function TMultiReadSingleWriteLocker.TryLockRead: Boolean;
var
  CurLock: Integer;
begin
  CurLock := FLocker;
  if CurLock <= $FFFF then
    Result := TInterlocked.CompareExchange(FLocker, CurLock + 1, CurLock)
      = CurLock
  else
    Result := False;
end;
 
function TMultiReadSingleWriteLocker.TryLockWrite: Boolean;
var
  CurLock: Integer;
begin
  CurLock := FLocker;
  if CurLock <= $FFFF then
    Result := TInterlocked.CompareExchange(FLocker, CurLock + $10000, CurLock)
      = CurLock
  else
    Result := False;
end;
 
procedure TMultiReadSingleWriteLocker.UnLockWrite;
begin
  if FLocker < $10000 then
    raise Exception.Create('TMultiReadSingleWriteLocker Error');
 
  TInterlocked.Add(FLocker, -$10000);
end;
 
procedure TMultiReadSingleWriteLocker.UnLockRead;
begin
  TInterlocked.Decrement(FLocker);
end;
 
constructor TMultiReadSingleWriteLocker.Create;
begin
  FLocker := 0;
end;
 
{ TSimpleLocker }
 
procedure TSimpleLocker.Lock;
var
  Wait: TSpinWait;
begin
  Wait.Reset;
  while True do
  begin
    if FLocker = 0 then
    begin
      if TInterlocked.CompareExchange(FLocker, 1, 0) = 0 then
        Exit;
    end;
    Wait.SpinCycle;
  end;
end;
 
function TSimpleLocker.TryLock: Boolean;
begin
  if FLocker = 0 then
  begin
    Result := TInterlocked.CompareExchange(FLocker, 1, 0) = 0;
  end
  else
    Result := False;
end;
 
procedure TSimpleLocker.UnLock;
begin
  if TInterlocked.CompareExchange(FLocker, 0, 1) <> 1 then
    raise Exception.Create('TSimpleLocker Error');
end;
 
end.

一個簡易無鎖池

 

一個簡易 無鎖池

1.所有讀寫無等待，不需要判斷條件直接讀寫(除自動擴充容量時），效率是一般帶鎖或帶條件判斷池的兩倍以上。

2.預先開辟2的冪大小容量，可自增，每次翻倍

3.僅提供思路，工程應用可靠性還不確定。

// 無鎖池
// hezihang @cnblogs.com

// 20160228 增加代引用計數器內存塊的池，增加編譯指令POOLGROW功能，可打開關閉池的自動翻倍增長功能
// 20160225 修正Grow中FWritePtr沒有增長Bug
// 20140609 增加Grow臨界區，減少等待時間
// 20140608 修正可能存在同時Grow的Bug

unit Iocp.AtomPool;

interface

{ .$DEFINE POOLGROW }

Uses
  System.SysUtils,
  System.SyncObjs;

Type
  Int32 = Integer;
  UInt32 = Cardinal;

  TAtomPoolAbstract = class
  private
    FWritePtr: Int32;
    FReadPtr: Int32;
    FHighBound: UInt32;
    FData: array of Pointer;
{$IFDEF POOLGROW}
    FCs: TCriticalSection;
    FLock: Int32;
    procedure CheckGrow; inline;
    procedure Grow; inline;
{$ENDIF}
  Protected
    function AllocItemResource: Pointer; virtual; abstract;
    procedure FreeItemResource(Item: Pointer); virtual; abstract;
    function GetCapacity: UInt32;
    procedure FreeResources;
  Public
    procedure AllocResources;
    function Get: Pointer;
    procedure Put(Item: Pointer);
    Constructor Create(Capacity: UInt32); Virtual;
    Destructor Destroy; Override;
    property Capacity: UInt32 read GetCapacity;
  End;

  TAtomPoolMem4K = class(TAtomPoolAbstract)
    function AllocItemResource: Pointer; override;
    procedure FreeItemResource(Item: Pointer); override;
  end;

  // 內存塊帶引用計數器的池,池容量恆定不能增長
  TAtomMemoryPoolRef = class
  private
    FMemory: PByteArray;
    FWritePtr: Int32;
    FReadPtr: Int32;
    FHighBound: UInt32;
    FMemSize: UInt32;
    FData: array of Pointer;
    FDataRef: array of Int32;
  Protected
    function GetCapacity: UInt32;
    procedure AllocResources;
    procedure FreeResources;
  Public
    function Get: Pointer;
    procedure Put(Item: Pointer);
    function IncRef(Item: Pointer): Int32;
    function DecRef(var Item: Pointer): Int32;
    Constructor Create(Capacity: UInt32; MemSize: UInt32);
    Destructor Destroy; Override;
    property Capacity: UInt32 read GetCapacity;
    property MemSize:UInt32 read FMemSize;
  End;

Implementation

const
  MAXTHREADCOUNT = 1000; // 從池中申請資源最大線程數
  // 創建池，大小必須是2的冪,並且必須大於MAXTHREADCOUNT

Constructor TAtomPoolAbstract.Create(Capacity: UInt32);
var
  OK: Boolean;
Begin
  Inherited Create;
  OK := (Capacity and (Capacity - 1) = 0);
  OK := OK and (Capacity > MAXTHREADCOUNT);

  if not OK then
    raise Exception.Create(Format('池長度必須大於%d並為2的冪', [MAXTHREADCOUNT]));
{$IFDEF POOLGROW}
  FCs := TCriticalSection.Create;
{$ENDIF}
  FHighBound := Capacity - 1;
  FReadPtr := 0;
End;

Destructor TAtomPoolAbstract.Destroy;
Begin
  FreeResources;
  SetLength(FData, 0);
{$IFDEF POOLGROW}
  FCs.Free;
{$ENDIF}
  Inherited;
End;

procedure TAtomPoolAbstract.AllocResources;
var
  i: UInt32;
begin
  try
    SetLength(FData, Capacity);
    for i := 0 to FHighBound do
      FData[i] := AllocItemResource;
  except
    Raise Exception.Create('池申請內存失敗');
  end;
end;

procedure TAtomPoolAbstract.FreeResources;
var
  i: UInt32;
begin
  for i := FHighBound downto 0 do
    Self.FreeItemResource(FData[i]);
end;

procedure TAtomPoolAbstract.Put(Item: Pointer);
var
  N: UInt32;
begin
{$IFDEF POOLGROW}
  CheckGrow;
{$ENDIF}
  N := TInterlocked.Increment(FWritePtr);
  FData[N and FHighBound] := Item;
end;

Function TAtomPoolAbstract.Get: Pointer;
var
{$IFDEF POOLGROW}
  N, M, K: UInt32;
{$ELSE}
  N: UInt32;
{$ENDIF}
begin
{$IFDEF POOLGROW}
  N := FWritePtr and FHighBound;
  M := FReadPtr and FHighBound;
  K := (M + MAXTHREADCOUNT) and FHighBound;
  if (N > M) and (N < K) then
  // if ((N > M) and (N < K)) or ((N < M) and (N > K)) then
  begin
    Grow
  end;
{$ENDIF}
  N := TInterlocked.Increment(FReadPtr);
  Result := FData[N and FHighBound];
end;

function TAtomPoolAbstract.GetCapacity: UInt32;
begin
  Result := FHighBound + 1;
end;

{$IFDEF POOLGROW}

procedure TAtomPoolAbstract.CheckGrow;
begin
  if TInterlocked.Add(FLock, 0) > 0 then
  begin
    while FLock = 1 do
      Sleep(0);
    FCs.Enter;
    FCs.Leave;
  end;
end;

procedure TAtomPoolAbstract.Grow;
var
  i, N: Integer;
begin
  if TInterlocked.CompareExchange(FLock, 1, 0) = 0 then // 加鎖
  begin
    FCs.Enter;
    TInterlocked.Increment(FLock);
    N := Length(FData);
    SetLength(FData, N + N);
    for i := N to High(FData) do
      FData[i] := AllocItemResource;
    TInterlocked.Increment(FLock);
    FHighBound := High(FData);
    FWritePtr := FHighBound;
    FCs.Leave;
    TInterlocked.Exchange(FLock, 0);
  end
  else
    CheckGrow;
end;
{$ENDIF}
{ TAtomPoolMem4K }

function TAtomPoolMem4K.AllocItemResource: Pointer;
begin
  GetMem(Result, 4096);
end;

procedure TAtomPoolMem4K.FreeItemResource(Item: Pointer);
begin
  FreeMem(Item, 4096);
end;

Constructor TAtomMemoryPoolRef.Create(Capacity: UInt32; MemSize: UInt32);
var
  OK: Boolean;
Begin
  Inherited Create;
  OK := (Capacity and (Capacity - 1) = 0);
  OK := OK and (Capacity > MAXTHREADCOUNT);

  if not OK then
    raise Exception.Create(Format('池長度必須大於%d並為2的冪', [MAXTHREADCOUNT]));
  if FMemSize and $10 <> 0 then
    raise Exception.Create('內存塊大小必須是16的倍數');

  FMemSize := MemSize;
  try
    AllocResources;
    FHighBound := Capacity - 1;
    FWritePtr := FHighBound;
    FReadPtr := 0;
  except
    Raise Exception.Create('池申請內存失敗');
  end;
End;

function TAtomMemoryPoolRef.DecRef(var Item: Pointer): Int32;
var
  N: Integer;
begin
  N := (NativeUInt(Item) - NativeUInt(FMemory)) div FMemSize;
  if (N>=0) and (N<=FHighBound) then
  begin
    Result := TInterlocked.Decrement(FDataRef[N]);
    if Result = 0 then
    begin
      Put(Item);
      Item := nil;
    end;
  end
  else Result:=-1;
end;

Destructor TAtomMemoryPoolRef.Destroy;
Begin
  FreeResources;
  Inherited;
End;

procedure TAtomMemoryPoolRef.AllocResources;
var
  i: UInt32;
  P: PByteArray;
begin
  SetLength(FData, Capacity);
  SetLength(FDataRef, Capacity);
  FillChar(FDataRef[0], Capacity * Sizeof(FDataRef[0]), 0);
  GetMem(FMemory, Length(FData) * FMemSize); // 一次申請所有內存
  P := FMemory;
  for i := 0 to FHighBound do
  begin
    FData[i] := P;
    Inc(P, FMemSize);
  end;
end;

procedure TAtomMemoryPoolRef.FreeResources;
begin
  FreeMem(FMemory, Length(FData) * FMemSize);
  SetLength(FData, 0);
  SetLength(FDataRef, 0);
end;

procedure TAtomMemoryPoolRef.Put(Item: Pointer);
var
  N: UInt32;
begin
  N := TInterlocked.Increment(FWritePtr);
  FData[N and FHighBound] := Item;
end;

Function TAtomMemoryPoolRef.Get: Pointer;
var
  N: UInt32;
begin
  N := TInterlocked.Increment(FReadPtr);
  Result := FData[N and FHighBound];
end;

function TAtomMemoryPoolRef.GetCapacity: UInt32;
begin
  Result := FHighBound + 1;
end;

function TAtomMemoryPoolRef.IncRef(Item: Pointer): Int32;
var
  N: Integer;
begin
  N := (NativeInt(Item) - NativeInt(FMemory)) div FMemSize;
  if (N>=0) and (N<=FHighBound) then
    Result := TInterlocked.Increment(FDataRef[N])
  else
    Result:=-1;
end;

End.

簡易高效的Delphi原子隊列

本文提供Delphi一個基於原子操作的無鎖隊列，簡易高效。適用於多線程大吞吐量操作的隊列。

可用於Android系統和32，64位Windows系統。

 

感謝殲10和qsl提供了修改建議！

有如下問題：

1.必須事先足夠大開辟內存，大到不會出現隊列溢出了。

2.隊列大小必須是2的冪

3.不能壓入空指針

4.本程序還未經過工程應用考驗

unit Iocp.AtomQueue;

interface

Uses
  SysUtils,
  SyncObjs;

Type
  TAtomFIFO = Class
  Protected
    FWritePtr: Integer;
    FReadPtr: Integer;
    FCount:Integer;
    FHighBound:Integer;
    FisEmpty:Integer;
    FData: array of Pointer;
    function GetSize:Integer;
  Public
    procedure Push(Item: Pointer);
    function Pop: Pointer;
    Constructor Create(Size: Integer); Virtual;
    Destructor Destroy; Override;
    Procedure Empty;
    property Size: Integer read GetSize;
    property UsedCount:Integer read FCount;
  End;

Implementation

//創建隊列，大小必須是2的冪，需要開辟足夠大的隊列，防止隊列溢出

Constructor TAtomFIFO.Create(Size: Integer);
var
  i:NativeInt;
  OK:Boolean;
Begin
  Inherited Create;
  OK:=(Size and (Size-1)=0);

  if not OK then raise Exception.Create('FIFO長度必須大於等於256並為2的冪');

  try
    SetLength(FData, Size);
    FHighBound:=Size-1;
  except
    Raise Exception.Create('FIFO申請內存失敗');
  end;
End;

Destructor TAtomFIFO.Destroy;
Begin
  SetLength(FData, 0);
  Inherited;
End;

procedure TAtomFIFO.Empty;
begin
  while (TInterlocked.Exchange(FReadPtr, 0)<>0) and
  (TInterlocked.Exchange(FWritePtr, 0)<>0) and
  (TInterlocked.Exchange(FCount, 0)<>0) do;
end;

function TAtomFIFO.GetSize: Integer;
begin
  Result:=FHighBound+1;
end;

procedure TAtomFIFO.Push(Item:Pointer);
var
  N:Integer;
begin
  if Item=nil then Exit;

  N:=TInterlocked.Increment(FWritePtr) and FHighBound;
  FData[N]:=Item;
  TInterlocked.Increment(FCount);
end;

Function TAtomFIFO.Pop:Pointer;
var
  N:Integer;
begin
  if TInterlocked.Decrement(FCount)<0 then
  begin
    TInterlocked.Increment(FCount);
    Result:=nil;
  end
  else
  begin
    N:=TInterlocked.Increment(FReadPtr) and FHighBound;
    //假設線程A調用了Push,並且正好是第1個push，
    //執行了N:=TInterlocked.Increment(FWritePtr) and FHighBound,
    //還沒執行FData[N]:=Item, 被切換到其他線程
    //此時假設線程B調用了Push，並且正好是第2個push,並且執行完畢，這樣出現FCount=1,第2個Item不為空，而第一個Item還是nil（線程A還沒執行賦值）
    //假設線程C執行Pop，由於Count>0（線程B的作用）所以可以執行到這里，但此時FData[N]=nil（線程A還沒執行賦值），
    //因此線程C要等待線程A完成FData[N]:=Item后，才能取走FData[N]
    //出現這種情況的概率應該比較小，基本上不會浪費太多CPU
    while FData[N]=nil do Sleep(1);
    Result:=FData[N];

    FData[N]:=nil;
  end;
end;

End.

性能測試：

采用天地弦提供的評估程序，進行了一些修改，分別對使用不同的臨界區的隊列進行對比結果如下：

其中Swith是因隊列讀空，進行線程上下文切換的次數

 

 

Delphi的FIFO實現

FIFO主要用於多個不同線程或進程之間數據交換時做緩沖區用，尤其適合實時數據通訊應用中的數據緩沖，接收線程（進程）將數據寫入FIFO，處理線程（進程）從FIFO取出數據

本單元中：

TMemoryFIFO類適用於單進程內不同線程之間交換數據

TMapFileFIFO類適用於不同進程之間交換數據

 

Unit UtFIFO;
 
Interface
 
Uses
  Windows,
  SysUtils,
  SyncObjs;
 
Type
  PFIFOStruct= ^TFIFOStruct;
 
  TFIFOStruct= Record
    FSize: Integer;
    FWritePtr: Integer;
    FReadPtr: Integer;
    FBuffer: TByteArray;
  End;
 
  TFIFOReadFunc= Function(Buf: Pointer; Count: Integer): Integer;
  TFIFOReadFuncOfObject= Function(const Buf;  Count: Integer): Integer Of Object;
 
  TAbstractFIFO= Class
  Protected
    FSelfAccess: Boolean;
    FDataStruct: PFIFOStruct; // 數據區指針
    Procedure AllocateResource(Size: Integer); Virtual; Abstract;
    Procedure FreeResources; Virtual; Abstract;
    Procedure Lock; Virtual; Abstract;
    Procedure UnLock; Virtual; Abstract;
  Public
    Function FIFOFreeSpace: Integer;
    Function FIFOUsedSpace: Integer;
    Function CheckFIFOFull: Boolean;
    Function CheckFIFOEmpty: Boolean;
    Function WriteData(const Buf: Pointer; Count: Integer): Integer; Virtual;
    Function ReadData(Buf: Pointer; Count: Integer): Integer; Virtual;
    Function ReadDataByFunc(Func: TFIFOReadFuncOfObject;
      Count: Integer): Integer; Virtual;
    Constructor Create(Size: Integer); Virtual;
    Destructor Destroy; Override;
    Procedure Empty;
    Function Size: Integer;
  End;
 
  TMemoryFIFO= Class(TAbstractFIFO)
  Protected
    FLocker: TCriticalSection;
    Procedure AllocateResource(Size: Integer); Override;
    Procedure FreeResources; Override;
    Procedure Lock; Override;
    Procedure UnLock; Override;
  Public
    Constructor Create(Size: Integer); Override;
    Destructor Destroy; Override;
  End;
 
  TFileMapFIFO= Class(TAbstractFIFO)
  Private
    FMaster:Boolean;
    FMapHandle: THandle; // 內存映射文件句柄
    FMutexHandle: THandle; // 互斥句柄
    FMapName: String; // 內存映射對象
    FPVHandle: THandle;
  Protected
    Procedure AllocateResource(Size: Integer); Override;
    Procedure FreeResources; Override;
    Procedure Lock; Override;
    Procedure UnLock; Override;
  Public
    Constructor Create(Const MapName: String; Size: Integer;bMaster:Boolean); Overload;
    Destructor Destroy; Override;
    Function WriteData(const Buf: Pointer; Count: Integer): Integer; Override;
    Function ReadData(Buf: Pointer; Count: Integer): Integer; Override;
    property PVHandle:NativeUInt  read FPVHandle;
  End;
 
Implementation
 
Function Min(Const A, B: Integer): Integer; inline;
begin
  if A>B then Result:=B else Result:=A
end;
 
Constructor TAbstractFIFO.Create(Size: Integer);
Begin
  Inherited Create;
  AllocateResource(Size);
 
  If Not Assigned(FDataStruct) Then
    Raise Exception.Create('FIFO申請內存失敗');
End;
 
Destructor TAbstractFIFO.Destroy;
Begin
  FreeResources;
  Inherited;
End;
 
Function TAbstractFIFO.FIFOFreeSpace;
Begin
  With FDataStruct^ Do
  Begin
    Lock;
    If FWritePtr> FReadPtr Then
      Result:= (FSize- FWritePtr)+ FReadPtr- 1
    Else
    If FWritePtr< FReadPtr Then
      Result:= FReadPtr- FWritePtr- 1
    Else
      Result:= FSize;
    UnLock;
  End;
End;
 
Function TAbstractFIFO.FIFOUsedSpace;
Begin
  With FDataStruct^ Do
  Begin
    Lock;
    If FWritePtr> FReadPtr Then
      Result:= FWritePtr- FReadPtr
    Else
    If FWritePtr< FReadPtr Then
      Result:= (FSize- FReadPtr)+ FWritePtr
    Else
      Result:= 0;
    UnLock;
  End;
End;
 
Function TAbstractFIFO.CheckFIFOFull: Boolean;
Begin
  With FDataStruct^ Do
  Begin
    Lock;
    If (FWritePtr= FSize- 1)And (FReadPtr= 0) Then
      Result:= True
    Else
    If (FWritePtr+ 1= FReadPtr) Then
      Result:= True
    Else
      Result:= False;
    UnLock;
  End;
End;
 
Function TAbstractFIFO.CheckFIFOEmpty: Boolean;
Begin
  With FDataStruct^ Do
  Begin
    Lock;
    Result:= (FWritePtr= FReadPtr);
    UnLock;
  End;
End;
 
Function TAbstractFIFO.WriteData(const Buf: Pointer; Count: Integer): Integer;
Var
  N: Integer;
Begin
   Result:= 0;
  If Count<= 0 Then
    Exit;
  With FDataStruct^ Do
  Begin
    Lock;
    If FWritePtr< FReadPtr Then               //如果沒有滿或已滿
    Begin
      Result:= Min(Count, FReadPtr- FWritePtr- 1);
      Move(Buf^, FBuffer[FWritePtr], Result);
      FWritePtr:= (FWritePtr+ Result)Mod FSize;
    End
    Else
    If FWritePtr = FReadPtr Then //Buffer 空
    Begin
      Result:= Min(Count, FSize- 1);
      Move(Buf^, FBuffer[0], Result);
      FWritePtr:= Result;
      FReadPtr:= 0;
    End
    Else
    Begin
      Result:= Min(Count, FSize- FWritePtr);
      Move(Buf^, FBuffer[FWritePtr], Result);
      if Result=Count then FWritePtr:= (FWritePtr+ Result) Mod FSize
      else
      Begin
          N:= Min(Count- Result, FReadPtr);
          Move(PByteArray(Buf)^[Result], FBuffer[0], N);
          FWritePtr:= N;
          Result:= Result+ N;
      End;
    End;
    UnLock;
  End;
End;
 
Function TAbstractFIFO.ReadData(Buf: Pointer; Count: Integer): Integer;
Var
  N: Integer;
Begin
  Result:= 0;
  If Count<= 0 Then
    Exit;
  With FDataStruct^ Do
  Begin
    Lock;
    If FReadPtr< FWritePtr Then
    Begin
      Result:= Min(Count, FWritePtr- FReadPtr);
      Move(FBuffer[FReadPtr], Buf^, Result);
      FReadPtr:= (FReadPtr+ Result)Mod FSize;
    End
    Else if FReadPtr>FWritePtr Then
    Begin
      Result:= Min(Count, FSize- FReadPtr);
      Move(FBuffer[FReadPtr], Buf^, Result);
      if Result=Count then FReadPtr:=(FReadPtr+Result) mod FSize
      else
      Begin
          N:= Min(Count- Result, FWritePtr);
          Move(FBuffer[0], PByteArray(Buf)[Result], N);
          FReadPtr:= N;
          Result:= Result+ N;
      End;
    End;
    UnLock;
  End;
End;
 
Function TAbstractFIFO.ReadDataByFunc(Func: TFIFOReadFuncOfObject;
  Count: Integer): Integer;
Var
  N, M: Integer;
Begin
  Result:= 0;
  If Count<= 0 Then
    Exit;
 
  With FDataStruct^ Do
  Begin
    Lock;
    Try
      If FReadPtr< FWritePtr Then
      Begin
        Result:= Func(FBuffer[FReadPtr], Min(Count, FWritePtr- FReadPtr));
        FReadPtr:= (FReadPtr+ Result)Mod FSize;
      End
      Else if FReadPtr>FWritePtr Then
      Begin
        Result:= Func(FBuffer[FReadPtr], Min(Count, FSize- FReadPtr));
        if Result=Count then FReadPtr:=(FReadPtr+Result) mod FSize
        else
        Begin
            N:= Func(FBuffer[0], Min(Count- Result, FWritePtr));
            FReadPtr:= N;
            Result:= Result+ N;
        End;
      End;
    Finally
      UnLock;
    End;
  End;
End;
 
Procedure TAbstractFIFO.Empty;
Begin
  Lock;
  With FDataStruct^ Do
  Begin
    FWritePtr:= 0;
    FReadPtr:= 0;
  End;
  UnLock;
End;
 
Function TAbstractFIFO.Size: Integer;
Begin
  Result:= FDataStruct^.FSize- 1;
End;
 
Constructor TMemoryFIFO.Create(Size: Integer);
Begin
  Inherited Create(Size);
  FLocker:= TCriticalSection.Create;
End;
 
Destructor TMemoryFIFO.Destroy;
Begin
  FLocker.Free;
  Inherited;
End;
 
Procedure TMemoryFIFO.AllocateResource(Size: Integer);
Begin
  Inherited;
  GetMem(FDataStruct, Size+ 3* Sizeof(Integer));
  With FDataStruct^ Do
  Begin
    FSize:= Size;
    FWritePtr:= 0;
    FReadPtr:= 0;
  End;
End;
 
Procedure TMemoryFIFO.FreeResources;
Begin
  FreeMem(FDataStruct, FDataStruct^.FSize+ 3* Sizeof(Integer));
  Inherited;
End;
 
Procedure TMemoryFIFO.Lock;
Begin
  FLocker.Enter;
End;
Procedure TMemoryFIFO.UnLock;
Begin
  FLocker.Leave;
End;
 
// 構造函數
Constructor TFileMapFIFO.Create(Const MapName: String; Size: Integer;bMaster:Boolean);
Begin
  FMapName:= MapName;
  FMaster:=bMaster;
  Inherited Create(Size);
End;
 
Destructor TFileMapFIFO.Destroy;
Begin
  CloseHandle(FPVHandle);
  Inherited;
End;
 
Procedure TFileMapFIFO.AllocateResource(Size: Integer);
Begin
  Inherited;
  if FMaster then
  begin
    FMapHandle:= CreateFileMapping($FFFFFFFF, Nil, PAGE_READWRITE, 0,
      Size+ 3* Sizeof(Integer), PChar(FMapName));
 
    If (FMapHandle= INVALID_HANDLE_VALUE)Or (FMapHandle= 0) Then
      Raise Exception.Create('創建文件映射對象失敗!');
  end
  else
    FMapHandle:=OpenFileMapping(FILE_MAP_ALL_ACCESS,False,PChar(FMapName));
 
  FDataStruct:= MapViewOfFile(FMapHandle, FILE_MAP_ALL_ACCESS, 0, 0, 0);
 
  // 創建互斥對象，在寫文件映射空間時用到它，以保持數據同步
  FMutexHandle:= Windows.CreateMutex(Nil, False, PChar(FMapName+ '.Mtx'));
  FPVHandle := CreateEvent(nil,True,False,PChar(FMapName + '.PV'));
  If (FMutexHandle= 0)or(FPVHandle = 0) Then
    Raise Exception.Create('創建互斥對象失敗');
 
  // 判斷是否已經建立文件映射了
  If (FMapHandle <> 0)And (GetLastError = ERROR_ALREADY_EXISTS) Then
  Begin
  End
  Else
  Begin
    FillChar(FDataStruct^, Size+ 3* Sizeof(Integer), 0);
    FDataStruct^.FSize:= Size;
  End
End;
 
Procedure TFileMapFIFO.FreeResources;
Begin
  UnmapViewOfFile(FDataStruct);
  CloseHandle(FMutexHandle);
  CloseHandle(FMapHandle);
  Inherited;
End;
Procedure TFileMapFIFO.Lock;
Begin
  WaitForSingleObject(FMutexHandle, INFINITE); // =WAIT_OBJECT_0)
End;
 
Procedure TFileMapFIFO.UnLock;
Begin
  ReleaseMutex(FMutexHandle);
End;
 
Function TFileMapFIFO.WriteData(const Buf: Pointer; Count: Integer): Integer;
Begin
  Lock;
  Result:= Inherited WriteData(Buf, Count);
  SetEvent(FPVHandle);
  UnLock;
End;
 
Function TFileMapFIFO.ReadData(Buf: Pointer; Count: Integer): Integer;
Begin
  Lock;
  Result:= Inherited ReadData(Buf, Count);
  UnLock;
End;
 
End.

 https://www.cnblogs.com/chencheng/p/3527692.html

https://blog.csdn.net/qq51931373/article/details/46652029

https://www.baidu.com/baidu?tn=monline_7_dg&ie=utf-8&wd=delphi+circular+buffer