Created
November 18, 2014 19:14
-
-
Save chainq/6f69a7821cfa2503962f to your computer and use it in GitHub Desktop.
CMem memory allocator for Free Pascal with 16 byte alignment
This file contains bidirectional Unicode text that may be interpreted or compiled differently than what appears below. To review, open the file in an editor that reveals hidden Unicode characters.
Learn more about bidirectional Unicode characters
{ | |
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. |
Sign up for free
to join this conversation on GitHub.
Already have an account?
Sign in to comment