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.