delphi 内存池

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.