[prev] [prev-tail] [tail] [up]

8.4.4 Writing your own memory manager

Free Pascal allows you to write and use your own memory manager. The standard functions GetMem, FreeMem, ReallocMem etc. use a special record in the system unit to do the actual memory management. The system unit initializes this record with the system unit's own memory manager, but you can read and set this record using the GetMemoryManager and SetMemoryManager calls:

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

the TMemoryManager record is dened as follows:

  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;  
    GetHeapStatus       : function :THeapStatus;  
    GetFPCHeapStatus    : function :TFPCHeapStatus;  
  end;

As you can see, the elements of this record are mostly procedural variables. The system unit does nothing but call these various variables when you allocate or deallocate memory.

Each of these elds corresponds to the corresponding call in the system unit. We'll describe each one of them:

NeedLock
This boolean indicates whether the memory manager needs a lock: if the memory manager itself is not thread-safe, then this can be set to True, and the Memory routines will use a lock for all memory routines. If this eld is set to false, no lock will be used.
Getmem
This function allocates a new block on the heap. The block should be Size bytes long. The return value is a pointer to the newly allocated block.
Freemem
should release a previously allocated block. The pointer P points to a previously allocated block. The Memory manager should implement a mechanism to determine what the size of the memory block is 2 The return value is optional, and can be used to return the size of the freed memory.
FreememSize
This function should release the memory pointed to by P. The argument Size is the expected size of the memory block pointed to by P. This should be disregarded, but can be used to check the behaviour of the program.
AllocMem
Is the same as getmem, only the allocated memory should be lled with zeroes before the call returns.
ReAllocMem
Should allocate a memory block Size bytes large, and should ll it with the contents of the memory block pointed to by P, truncating this to the new size of needed. After that, the memory pointed to by P may be deallocated. The return value is a pointer to the new memory block. Note that P may be Nil, in which case the behaviour is equivalent to GetMem.
MemSize
should return the total amount of memory available for allocation. This function may return zero if the memory manager does not allow to determine this information.
GetHeapStatus
should return a THeapStatus record with the status of the memory manager. This record should be lled with Delphi-compliant values.
GetHeapStatus
should return a TFPCHeapStatus record with the status of the memory manager. This record should be lled with FPC-Compliant values.

To implement your own memory manager, it is sucient to construct such a record and to issue a call to SetMemoryManager.

To avoid conicts with the system memory manager, setting the memory manager should happen as soon as possible in the initialization of your program, i.e. before any call to getmem is processed.

This means in practice that the unit implementing the memory manager should be the rst in the uses clause of your program or library, since it will then be initialized before all other units (except of the system unit)

This also means that it is not possible to use the heaptrc unit in combination with a custom memory manager, since the heaptrc unit uses the system memory manager to do all it's allocation. Putting the heaptrc unit after the unit implementing the memory manager would overwrite the memory manager record installed by the custom memory manager, and vice versa.

The following unit shows a straightforward implementation of a custom memory manager using the memory manager of the C library. It is distributed as a package with 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;  
      GetHeapStatus : @CGetHeapStatus;  
      GetFPCHeapStatus: @CGetFPCHeapStatus;  
    );  
 
Var  
  OldMemoryManager : TMemoryManager;  
 
Initialization  
  GetMemoryManager (OldMemoryManager);  
  SetMemoryManager (CmemoryManager);  
 
Finalization  
  SetMemoryManager (OldMemoryManager);  
end.

[prev] [prev-tail] [front] [up]