CMem memory allocator for Free Pascal with 16 byte alignment

cmem.pp

{
    This file is part of the Free Pascal run time library.
    Copyright (c) 1999 by Michael Van Canneyt, member of the
    Free Pascal development team

    Implements a memory manager that uses the C memory management.

    See the file COPYING.FPC, included in this distribution,
    for details about the copyright.

    This program is distributed in the hope that it will be useful,
    but WITHOUT ANY WARRANTY; without even the implied warranty of
    MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE.

 **********************************************************************}
unit cmem;

interface

Const

{$if defined(go32v2) or defined(wii)}
  {$define USE_STATIC_LIBC}
{$endif}

{$if defined(win32)}
  LibName = 'msvcrt';
{$elseif defined(win64)}
  LibName = 'msvcrt';
{$elseif defined(wince)}
  LibName = 'coredll';
{$elseif defined(netware)}
  LibName = 'clib';
{$elseif defined(netwlibc)}
  LibName = 'libc';
{$elseif defined(macos)}
  LibName = 'StdCLib';
{$elseif defined(beos)}
  LibName = 'root';
{$else}
  LibName = 'c';
{$endif}

{$ifdef USE_STATIC_LIBC}
  {$linklib c}
Function malloc (Size : ptruint) : Pointer;cdecl; external;
Procedure free (P : pointer); cdecl; external;
function realloc (P : Pointer; Size : ptruint) : pointer;cdecl; external;
Function calloc (unitSize,UnitCount : ptruint) : pointer;cdecl; external;
{$else not USE_STATIC_LIBC}
Function Malloc (Size : ptruint) : Pointer; cdecl; external LibName name 'malloc';
Procedure Free (P : pointer); cdecl; external LibName name 'free';
function ReAlloc (P : Pointer; Size : ptruint) : pointer; cdecl; external LibName name 'realloc';
Function CAlloc (unitSize,UnitCount : ptruint) : pointer; cdecl; external LibName name 'calloc';
{$endif not USE_STATIC_LIBC}

implementation


const
  GETMEM_ALIGNMENT = 16;

type
  TMemoryHeader = record
    blockPtr: Pointer;
    pascalSize: PtrUInt;
  end;
  PMemoryHeader = ^TMemoryHeader;


Function CGetMem  (Size : ptruint) : Pointer;
var
  origPtr: Pointer;
begin
  CGetMem:=Malloc(Size + sizeof(TMemoryHeader) + GETMEM_ALIGNMENT);
  if (CGetMem <> nil) then
    begin
      origPtr:=CGetMem;
      CGetMem:=Align(origPtr + sizeof(TMemoryHeader), GETMEM_ALIGNMENT);
      with PMemoryHeader(CGetMem - sizeof(TMemoryHeader))^ do
        begin
          blockPtr:=origPtr;
          pascalSize:=size;
        end;
    end;
end;

Function CFreeMem (P : pointer) : ptruint;

begin
  if (p <> nil) then
    Free(PMemoryHeader(p - sizeof(TMemoryHeader))^.blockPtr);
  CFreeMem:=0;
end;

Function CFreeMemSize(p:pointer;Size:ptruint):ptruint;

begin
  if (p <> nil) then
    begin
      with PMemoryHeader(p - sizeof(TMemoryHeader))^ do
        if (size <> pascalSize) then
          runerror(204);
    end;
  CFreeMemSize:=CFreeMem(P);
end;

Function CAllocMem(Size : ptruint) : Pointer;
var
  origPtr: Pointer;
begin
  CAllocMem:=calloc(Size + sizeof(TMemoryHeader) + GETMEM_ALIGNMENT, 1);
  if (CAllocMem <> nil) then
    begin
      origPtr:=CAllocMem;
      CAllocMem:=Align(origPtr + sizeof(TMemoryHeader), GETMEM_ALIGNMENT);
      with PMemoryHeader(CAllocMem - sizeof(TMemoryHeader))^ do
        begin
          blockPtr:=origPtr;
          pascalSize:=size;
        end;
    end;
end;

Function CReAllocMem (var p:pointer;Size:ptruint):Pointer;
var
  origPtr: Pointer;
begin
  if size=0 then
    begin
      if p<>nil then
        begin
          Free(PMemoryHeader(p - sizeof(TMemoryHeader))^.blockPtr);
          p:=nil;
        end;
    end
  else
    begin
      if p=nil then
        p:=malloc(size + sizeof(TMemoryHeader) + GETMEM_ALIGNMENT)
      else
        p:=realloc(PMemoryHeader(p - sizeof(TMemoryHeader))^.blockPtr, size + sizeof(TMemoryHeader) + GETMEM_ALIGNMENT);

      if (p <> nil) then
        begin
          origPtr:=p;
          p:=Align(origPtr + sizeof(TMemoryHeader), GETMEM_ALIGNMENT);
          with PMemoryHeader(p - sizeof(TMemoryHeader))^ do
            begin
              blockPtr:=origPtr;
              pascalSize:=size;
            end;
        end;
    end;
  CReAllocMem:=p;
end;

Function CMemSize (p:pointer): ptruint;

begin
  CMemSize:=PMemoryHeader(p - sizeof(TMemoryHeader))^.pascalSize;
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.