unit untMemoryPool;

interface

{$WARNINGS OFF}

uses

  System.Classes, System.SysUtils, Winapi.Windows;

type

  //Node for block memory

  pMemNode = ^TMemNode;

  TMemNode = record

    Free : Boolean;                 //Is free?

    FSize: Integer;                 //Block Size

    FAddr: Pointer;                 //Address pointer to memory allocated

    FNext: pMemNode;                //Next block pointer

    FPrev: pMemNode;                //Block befor

  end;

  //Memory pool class

  TMemoryPool = class(TObject)

  private

    FBlkSize: Integer;               //Block size

    FBlkCnt : Integer;               //Memory bock count each time allocate

    FMemHead: pMemNode;              //Memory list

    FreeHead: pMemNode;              //Free memory start position

    FMemTail: pMemNode;              //Tail of current memory

    FLock   : TRTLCriticalSection;

    procedure InitLock;

    procedure Lock;

    procedure UnLock;

    procedure UnInitLock;

    procedure GetResource(ABlocks: Integer);

    procedure FreeResource;

  public

    constructor Create(const ABlocks: Integer = 10; const ABlockSize: Integer = 1024);

    destructor Destroy; override;

    //Get a free buffer

    function  GetBuffer: Pointer;

    //After use the buffer

    function FreeBuffer(const ABuffer: Pointer): Boolean;

  published

    property BlockSize: Integer read FBlkSize;

  end;

implementation

{ TMemoryPool }

{******************************************************************************}

{*     Procedure: Create                                                      *}

{*       Purpose: constructor of TMemoryPool.                                 *}

{*    Paramaters: ABlocks    --  Block to allocate when create.               *}

{*                ABlockSize --  Each block size.                             *}

{******************************************************************************}

constructor TMemoryPool.Create(const ABlocks, ABlockSize: Integer);

begin

  InitLock;

  FBlkCnt := ABlocks;

  FBlkSize:= ABlockSize;

  FMemHead:= nil;

  FMemTail:= nil;

  FreeHead:= nil;

  GetResource(ABlocks);

end;

{******************************************************************************}

{*     Procedure: Destroy                                                     *}

{*       Purpose: Destrucotr of TMemoryPool.                                  *}

{*    Paramaters: None.                                                       *}

{******************************************************************************}

destructor TMemoryPool.Destroy;

begin

  FreeResource;

  UnInitLock;

  inherited;

end;

{******************************************************************************}

{*      Function: FreeBuffer                                                  *}

{*       Purpose: Free memory buffer allocated.                               *}

{*    Paramaters: ABuffer  --  Buffer address to free.                        *}

{*        Return: True  --  Block is free.                                    *}

{*                False --  Free error or the block not found.                *}

{******************************************************************************}

function TMemoryPool.FreeBuffer(const ABuffer: Pointer): Boolean;

var

  m_pTmp: pMemNode;

begin

  Result:= false;

  Lock;

  try

    if (nil = ABuffer) then exit;

    m_pTmp:= FMemHead;

    while (m_pTmp <> nil) do

    begin

      if (ABuffer = m_pTmp.FAddr) then

      begin

        if FreeHead = nil then

          FreeHead:= FMemTail

        else

          FreeHead:= FreeHead.FPrev;     //Move free head back

        //Swap two blocks's content

        m_pTmp.Free := false;

        m_pTmp.FAddr:= FreeHead.FAddr;

        FreeHead.Free := true;

        FreeHead.FAddr:= ABuffer;

        Result:= true;

        exit;

      end;

      m_pTmp:= m_pTmp.FNext;

      // Not find the block, exit

      if (m_pTmp = FreeHead) then break;

    end;

  finally

    UnLock;

  end;

end;

{******************************************************************************}

{*     Procedure: FreeResource                                                *}

{*       Purpose: Free all memory allocated.                                  *}

{*    Paramaters: None.                                                       *}

{******************************************************************************}

procedure TMemoryPool.FreeResource;

var

  m_pNode: pMemNode;

  m_pTmp : pMemNode;

begin

  m_pNode:= FMemHead;

  try

    while (m_pNode <> nil) do

    begin

      m_pTmp:= m_pNode;

      m_pNode:= m_pNode.FNext;

      FreeMem(m_pTmp.FAddr);

      Dispose(m_pTmp);

    end;

  except

  end;

  FMemHead:= nil;

end;

{******************************************************************************}

{*      Function: GetBuffer                                                   *}

{*       Purpose: Get a memroy block buffer.                                  *}

{*    Paramaters: None.                                                       *}

{*        Return: Pointer  --  A pointer pointer to buffer.                   *}

{******************************************************************************}

function TMemoryPool.GetBuffer: Pointer;

begin

  Lock;

  try

    //If there's no free memroy, allocate new memory

    if (FreeHead = nil) then

      GetResource(FBlkCnt);

    //Return free memory head address

    Result:= FreeHead.FAddr;

    //Mark the block is not free

    FreeHead.Free:= false;

    //Move free head pointer forward

    FreeHead:= FreeHead.FNext;

  finally

    UnLock;

  end;

end;

{******************************************************************************}

{*     Procedure: GetResource                                                 *}

{*       Purpose: Allocate memroy.                                            *}

{*    Paramaters: ABlocks  --  How many blocks to allocate.                   *}

{******************************************************************************}

procedure TMemoryPool.GetResource(ABlocks: Integer);

var

  m_pNode: pMemNode;

  m_iTmp : Integer;

begin

  if (ABlocks <= 0) or (FBlkSize <= 0) then exit;

  //Get new memory block

  new(m_pNode);

  m_pNode.Free := true;

  m_pNode.FSize:= FBlkSize;

  m_pNode.FPrev:= FMemTail;

  GetMem(m_pNode.FAddr, FBlkSize);

  m_pNode.FNext:= nil;

  //If the memroy block list is empty, assign head

  if FMemHead = nil then

  begin

    FMemHead:= m_pNode;

    FMemTail:= FMemHead;

    FreeHead:= FMemHead;

  end

  else begin

    FMemTail.FNext:= m_pNode;

    FMemTail:= m_pNode;

  end;

  if (FreeHead = nil) then

    FreeHead:= m_pNode;

  for m_iTmp:= 1 to ABlocks - 1 do

  begin

    new(m_pNode);

    m_pNode.Free := true;

    m_pNode.FSize:= FBlkSize;

    m_pNode.FNext:= nil;

    m_pNode.FPrev:= FMemTail;

    GetMem(m_pNode.FAddr, FBlkSize);

    FMemTail.FNext:= m_pNode;

    FMemTail:= m_pNode;

  end;

end;

procedure TMemoryPool.InitLock;

begin

  InitializeCriticalSection(FLock);

end;

procedure TMemoryPool.Lock;

begin

  EnterCriticalSection(FLock);

end;

procedure TMemoryPool.UnInitLock;

begin

  DeleteCriticalSection(FLock);

end;

procedure TMemoryPool.UnLock;

begin

  LeaveCriticalSection(FLock);

end;

end.