|
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.
|