8.4.4. Написание вашего собственного менеджера памяти

На верх  Назад  Вперёд

Free Pascal позволяет вам написать и использовать ваш собственный менеджер памяти. Стандартные функции GetMem, FreeMem, ReallocMem и т.п. специальную запись в модуле system для управления памятью. Модуль system инициализирует эту запись с собственным менеджером памяти модуля system, но вы можете прочитать и установить эту запись, используя вызов GetMemoryManager и SetMemoryManager:

procedure GetMemoryManager(var MemMgr: TMemoryManager);
procedure SetMemoryManager(const MemMgr: TmemoryManager);

Запись TMemoryManager определена следующим образом:

TMemoryManager = record
  NeedLock   : Boolean;
  Getmem     : Function(Size:PtrInt):Pointer;
  Freemem     : Function(var p:pointer):PtrInt;
  FreememSize : Function(var p:pointer;Size:PtrInt):PtrInt;
  AllocMem   : Function(Size:PtrInt):Pointer;
  ReAllocMem : Function(var p:pointer;Size:PtrInt):Pointer;
  MemSize     : function(p:pointer):PtrInt;
  InitThread       : procedure;
  DoneThread       : procedure;
  RelocateHeap     : procedure;
  GetHeapStatus   : function :THeapStatus;
  GetFPCHeapStatus : function :TFPCHeapStatus;
end;

Как вы можете видеть, элементы этой записи в основном являются процедурными переменными. Модуль system не делает ничего, кроме вызова этих переменных, когда вы выделяете или освобождаете память.

Каждое из этих полей ссылается на соответствующий вызов в модуле system. Эти вызовы описаны ниже.

NeedLock
Этот флаг указывает, будет ли менеджер памяти нуждаться в блокировке: если менеджер памяти сам не является «потокобезопасным», то этот флаг можно установить в True и процедуры работы с памятью будут использовать блокировку для всех процедур работы с памятью. Если это поле установлено в False, блокировка не используется.

Getmem
Эта функция выделяет новый блок в куче. Блок должен иметь размер, указанный в Size. Возвращаемое значение – это указатель на вновь выделенный блок.

Freemem
Должна освободить ранее выделенный блок. Указатель P указывает на ранее выделенный блок. Менеджер памяти должен иметь механизм для определения размера освобождаемого блока памяти (например, путём записи его размера в отрицательное смещение). Возвращаемое значение является не обязательным, и может быть использовано для возврата размера освобождённой памяти.

FreememSize
Эта функция должна освободить память, указанную при помощи P. Аргумент Size – это ожидаемый размер блока памяти, на который ссылается указатель P. Её не следует принимать во внимание, но можно использовать для проверки поведения программы.

AllocMem
То же, что и getmem, только выделенная память должна быть заполнена нулями перед возвратом.

ReAllocMem
Должна выделить блок памяти с максимальным размером Size байт и заполнить его содержимым блока памяти, указанным в P, обрезав это содержимое по новому размеру при необходимости. После этого блок памяти, указанный в P, может быть освобождён. Возвращаемое значение является указателем на новый блок памяти. Учтите, что P может быть Nil, в этом случае поведения эквивалентно GetMem.

MemSize
Должна вернуть общий объём памяти, доступной для выделения. Эта функция может возвращать ноль, если менеджер памяти не позволяет определять это значение.

InitThread
Эта процедура вызывается, когда запускается новый поток: она должна инициализировать структуру кучи для текущего потока (если таковой имеется).

DoneThread
Эта процедура вызывается при закрытии потока: она должна очищать все структуры кучи для текущего потока.

RelocateHeap
Реструктурирует кучу – это только для локальных куч потоков.

GetHeapStatus
Должна возвращать запись THeapStatus с состоянием менеджера памяти. Эта запись должна заполняться значениями, совместимыми с Delphi.

GetHeapStatus
Должна возвращать запись TFPCHeapStatus с состоянием менеджера памяти. Эта запись должна заполняться значениями, совместимыми с FPC.

Чтобы реализовать ваш собственный менеджер памяти, достаточно создать такую запись и выполнить вызов SetMemoryManager.

Чтобы избежать конфликтов с системным менеджером памяти, настройка менеджера памяти должна произойти как можно скорее в разделе инициализации вашей программы, то есть перед любым обращением к getmem.

Это означает, что модуль, реализующий менеджер памяти, должен быть первым в разделе uses вашей программы или библиотеки, так как он будет инициализирован перед всеми другими модулями (конечно, за исключением самого модуля system ).

Это также означает, что невозможно использовать модуль heaptrc совместно с пользовательским менеджером памяти, так как модуль heaptrc использует системный менеджер памяти для работы с памятью. Поместив модуль heaptrc после модуля, реализующего ваш менеджер памяти, вы перезапишите запись вашего менеджера памяти, и наоборот.

Следующий пример реализует простой пользовательский менеджер памяти, используя менеджер памяти библиотеки C. Он распространяется в виде пакета с Free Pascal.

unit cmem;
 
interface
 
Const
LibName = 'libc';
 
Function Malloc (Size : ptrint) : Pointer; cdecl; external LibName name 'malloc';
Procedure Free (P : pointer); cdecl; external LibName name 'free';
function ReAlloc (P : Pointer; Size : ptrint) : pointer; cdecl; external LibName name 'realloc';
Function CAlloc (unitSize,UnitCount : ptrint) : pointer; cdecl; external LibName name 'calloc';
 
implementation
 
type
pptrint = ^ptrint;
 
Function CGetMem (Size : ptrint) : Pointer;
begin
CGetMem:=Malloc(Size+sizeof(ptrint));
if (CGetMem <> nil) then
  begin
    pptrint(CGetMem)^ := size;
    inc(CGetMem,sizeof(ptrint));
  end;
end;
 
Function CFreeMem (P : pointer) : ptrint;
begin
if (p <> nil) then
  dec(p,sizeof(ptrint));
  Free(P);
  CFreeMem:=0;
end;
 
Function CFreeMemSize(p:pointer;Size:ptrint):ptrint;
begin
if size<=0 then
  begin
    if size<0 then
    runerror(204);
    exit;
  end;
if (p <> nil) then
  begin
    if (size <> pptrint(p-sizeof(ptrint))^) then
    runerror(204);
  end;
CFreeMemSize:=CFreeMem(P);
end;
 
Function CAllocMem(Size : ptrint) : Pointer;
begin
CAllocMem:=calloc(Size+sizeof(ptrint),1);
if (CAllocMem <> nil) then
  begin
    pptrint(CAllocMem)^ := size;
    inc(CAllocMem,sizeof(ptrint));
  end;
end;
 
Function CReAllocMem (var p:pointer;Size:ptrint):Pointer;
begin
if size=0 then
begin
  if p<>nil then
    begin
      dec(p,sizeof(ptrint));
      free(p);
      p:=nil;
    end;
end
else
begin
  inc(size,sizeof(ptrint));
  if p=nil then
    p:=malloc(Size)
else
begin dec(p,sizeof(ptrint)); p:=realloc(p,size); end;
  if (p <> nil) then
  begin
    pptrint(p)^ := size-sizeof(ptrint);
    inc(p,sizeof(ptrint));
  end;
end;
CReAllocMem:=p;
end;
 
Function CMemSize (p:pointer): ptrint;
begin
CMemSize:=pptrint(p-sizeof(ptrint))^;
end;
 
function CGetHeapStatus:THeapStatus;
var
res: THeapStatus;
begin
fillchar(res,sizeof(res),0);
CGetHeapStatus:=res;
end;
 
function CGetFPCHeapStatus:TFPCHeapStatus;
begin
  fillchar(CGetFPCHeapStatus,sizeof(CGetFPCHeapStatus),0);
end;
 
Const
  CMemoryManager : TMemoryManager =
(
    NeedLock : false;
    GetMem : @CGetmem;
    FreeMem : @CFreeMem;
    FreememSize : @CFreememSize;
    AllocMem : @CAllocMem;
    ReallocMem : @CReAllocMem;
    MemSize : @CMemSize;
    InitThread : Nil;
    DoneThread : Nil;
    RelocateHeap : Nil;
    GetHeapStatus : @CGetHeapStatus;
    GetFPCHeapStatus: @CGetFPCHeapStatus;
  );
 
Var
  OldMemoryManager : TMemoryManager;
 
Initialization
  GetMemoryManager (OldMemoryManager);
  SetMemoryManager (CmemoryManager);
 
Finalization
  SetMemoryManager(OldMemoryManager);
end.