{
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;
{$MODE OBJFPC}
{$DEFINE BK_FEATURES} { ~bk Code regarding agnostic heaptrc and initializing
memorymanager and heaptrc BEFORE system.pp }
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';
{$if defined(Windows)}
Function _MemSize(P : Pointer) : ptruint; cdecl; external LibName name '_msize';
{$endif}
{$endif not USE_STATIC_LIBC}
implementation
uses
SysUtils;
function CGetMem(Size: ptruint): Pointer;
{var
lErrno: integer; }
begin
{$if defined(Windows)}
CGetMem := Malloc(Size);
{$else}
CGetMem := Malloc(Size + sizeof(ptruint));
if (CGetMem <> nil) then begin
Pptruint(CGetMem)^ := size;
Inc(CGetMem, sizeof(ptruint));
end;
{$endif}
end;
function CFreeMem(P: pointer): ptruint;
begin
{$if not defined(Windows)}
if (p <> nil) then
Dec(p, sizeof(ptruint));
{$endif}
Free(P);
CFreeMem := 0;
end;
function CFreeMemSize(p: pointer; Size: ptruint): ptruint;
begin
if size <= 0 then
exit;
{$if not defined(Windows)}
if (p <> nil) then begin
if (size <> Pptruint(p - sizeof(ptruint))^) then
runerror(204);
end;
{$endif}
CFreeMemSize := CFreeMem(p);
end;
function CAllocMem(Size: ptruint): Pointer;
begin
{$if defined(Windows)}
CAllocMem := calloc(Size, 1);
{$else}
CAllocMem := calloc(Size + sizeof(ptruint), 1);
if (CAllocMem <> nil) then begin
Pptruint(CAllocMem)^ := size;
Inc(CAllocMem, sizeof(ptruint));
end;
{$endif}
end;
function CReAllocMem(var p: pointer; Size: ptruint): Pointer;
begin
{$if defined(WINDOWS)}
p := Realloc(p, size);
CReAllocMem := p;
{$else}
if size = 0 then begin
if p <> nil then begin
Dec(p, sizeof(ptruint));
Free(p);
p := nil;
end;
end
else begin
Inc(size, sizeof(ptruint));
if p = nil then
p := malloc(Size)
else begin
Dec(p, sizeof(ptruint));
p := realloc(p, size);
end;
if (p <> nil) then begin
Pptruint(p)^ := size - sizeof(ptruint);
Inc(p, sizeof(ptruint));
end;
end;
{$endif}
CReAllocMem := p;
end;
function CMemSize(p: pointer): ptruint;
begin
{$if defined(WINDOWS)}
CMemSize := _MemSize(p);
{$else}
CMemSize := Pptruint(p - sizeof(ptruint))^;
{$endif}
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, mmtCmem, nil, @FinalizeCMem);
Finalization
SetMemoryManager (OldMemoryManager);
end.