unit WaitFreeMemoryPool;

interface

uses
  LazyRelease,
  Windows, Classes, SysUtils;

const
  POOL_LIST_COUNT = 10;

  INDEX_1KB = 3;
  INDEX_2KB = 4;
  INDEX_4KB = 5;
  INDEX_8KB = 6;
  INDEX_16KB = 7;
  INDEX_32KB = 8;
  INDEX_64KB = 9;

  MEMORY_SIZES : array [0..POOL_LIST_COUNT-1] of integer = (
    128, 256, 512, 1024, 2*1024, 4*1024, 8*1024, 16*1024, 32*1024, 64*1024
  );

type
  TWaitFreeMemoryPool = class
  private
    FTopIndex : integer;
    FPoolList : array [0..POOL_LIST_COUNT-1] of TObject;
    FLazyRelease : TLazyRelease;
  public
    constructor Create(AFenderSize:integer); reintroduce;
    destructor Destroy; override;

    /// Don't call this method when you are using TWaitFreeMemoryPool.
    procedure SetMemoryPoolSize(AIndex,ASize:integer);

    procedure GetMem(var AData:pointer; ASize:integer);

    /// (AData, ASize) --> [Packet] = [Size] [Data]
    function GetPacket(AData:pointer; ASize:integer): pointer;
  end;

implementation

type
  TMemoryPool = class
  strict private
    FIndex : integer;
    FPool : array of pointer;
    FMemorySize : integer;
    procedure clear_Pool;
  strict private
    FSize : integer;
    procedure SetSize(ASize:integer);
  public
    constructor Create(AMemorySize:integer); reintroduce;
    destructor Destroy; override;

    procedure GetMem(var AData:pointer);

    property Size : integer read FSize write SetSize;
  end;

{ TWaitFreeMemoryPool }

constructor TWaitFreeMemoryPool.Create(AFenderSize:integer);
var
  Loop: Integer;
begin
  inherited Create;

  FTopIndex := 0;

  for Loop := 0 to POOL_LIST_COUNT-1 do
    FPoolList[Loop] := TMemoryPool.Create(MEMORY_SIZES[Loop]);

  FLazyRelease := TLazyRelease.Create(AFenderSize);
end;

destructor TWaitFreeMemoryPool.Destroy;
var
  Loop: Integer;
begin
  for Loop := 0 to POOL_LIST_COUNT-1 do FreeAndNil(FPoolList[Loop]);

  inherited;
end;

procedure TWaitFreeMemoryPool.GetMem(var AData: pointer; ASize: integer);
var
  iIndex : integer;
  Loop: Integer;
begin
  iIndex := -1;
  for Loop := 0 to FTopIndex do begin
    if TMemoryPool(FPoolList[Loop]).Size <= 0 then Continue;

    if MEMORY_SIZES[Loop] >= ASize then begin
      iIndex := Loop;
      Break;
    end;
  end;

  if iIndex = -1 then begin
    System.GetMem(AData, ASize);
    FLazyRelease.Release(AData);
  end else begin
    TMemoryPool(FPoolList[iIndex]).GetMem(AData);
  end;
end;

function TWaitFreeMemoryPool.GetPacket(AData: pointer; ASize: integer): pointer;
var
  pBuffer : PByte;
begin
  Self.GetMem(Result, ASize +SizeOf(Integer));

  pBuffer := Result;
  Move(ASize, pBuffer^, SizeOf(ASize));

  if ASize > 0 then begin
    Inc(pBuffer, SizeOf(ASize));
    Move(AData^, pBuffer^, ASize);
  end;
end;

procedure TWaitFreeMemoryPool.SetMemoryPoolSize(AIndex, ASize: integer);
begin
  if ASize > 0 then begin
    if AIndex > FTopIndex then FTopIndex := AIndex;
    TMemoryPool(FPoolList[AIndex]).Size := ASize;
  end;
end;

{ TMemoryPool }

procedure TMemoryPool.clear_Pool;
var
  Loop : Integer;
  Temp : pointer;
begin
  FIndex := 0;
  for Loop := 0 to Size-1 do begin
    Temp := InterlockedExchangePointer(FPool[Loop], nil);
    if Temp <> nil then FreeMem(Temp);
  end;
end;

constructor TMemoryPool.Create(AMemorySize: integer);
begin
  inherited Create;

  FMemorySize := AMemorySize;

  FIndex := 0;
  FSize := 0;
end;

destructor TMemoryPool.Destroy;
begin
  clear_Pool;

  inherited;
end;

procedure TMemoryPool.GetMem(var AData: pointer);
var
  iIndex, iMod : integer;
begin
  iIndex := InterlockedIncrement(FIndex);
  if iIndex >= FSize then begin
    iMod := iIndex mod FSize;
    InterlockedCompareExchange(FIndex, iMod, iIndex);
  end else begin
    iMod := iIndex;
  end;

  AData := FPool[iMod];
end;

procedure TMemoryPool.SetSize(ASize: integer);
var
  Loop: Integer;
begin
  if ASize = FSize then Exit;

  clear_Pool;

  FSize := ASize;

  SetLength(FPool, ASize);
  for Loop := 0 to ASize-1 do System.GetMem(FPool[Loop], FMemorySize);
end;

end.
