mirror of
https://gitlab.com/freepascal.org/fpc/source.git
synced 2025-05-04 21:03:53 +02:00
1181 lines
30 KiB
PHP
1181 lines
30 KiB
PHP
{
|
|
$Id$
|
|
This file is part of the Free Pascal run time library.
|
|
Copyright (c) 1993-98 by the Free Pascal development team.
|
|
|
|
functions for heap management in the data segment
|
|
|
|
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.
|
|
|
|
**********************************************************************}
|
|
|
|
{
|
|
Supported conditionnals:
|
|
------------------------
|
|
TEMPHEAP to allow to split the heap in two parts for easier release
|
|
started for the compiler
|
|
|
|
CHECKHEAP if you want to test the heap integrity
|
|
|
|
}
|
|
|
|
{ Memory manager }
|
|
const
|
|
MemoryManager: TMemoryManager = (
|
|
GetMem: SysGetMem;
|
|
FreeMem: SysFreeMem
|
|
);
|
|
|
|
{ Default Heap }
|
|
const
|
|
max_size = 256;
|
|
maxblock = max_size div 8;
|
|
|
|
type
|
|
pfreerecord = ^tfreerecord;
|
|
tfreerecord = record
|
|
next : pfreerecord;
|
|
size : longint;
|
|
end;
|
|
|
|
tblocks = array[1..maxblock] of pointer;
|
|
pblocks = ^tblocks;
|
|
tnblocks = array[1..maxblock] of longint;
|
|
pnblocks = ^tnblocks;
|
|
|
|
var
|
|
internal_memavail : longint;
|
|
internal_heapsize : longint;
|
|
baseblocks : tblocks;
|
|
basenblocks : tnblocks;
|
|
|
|
const
|
|
blocks : pblocks = @baseblocks;
|
|
nblocks : pnblocks = @basenblocks;
|
|
|
|
|
|
{ Check Heap }
|
|
{$IfDef CHECKHEAP}
|
|
{ 4 levels of tracing }
|
|
const
|
|
tracesize = 4;
|
|
freerecord_list_length : longint = 0;
|
|
type
|
|
pheap_mem_info = ^heap_mem_info;
|
|
heap_mem_info = record
|
|
next,
|
|
previous : pheap_mem_info;
|
|
size : longint;
|
|
sig : longint; {dummy number for test }
|
|
calls : array [1..tracesize] of longint;
|
|
end;
|
|
{ size 8*4 = 32 }
|
|
const
|
|
{ help variables for debugging with GDB }
|
|
check : boolean = false;
|
|
growheapstop : boolean = false;
|
|
free_nothing : boolean = false;
|
|
trace : boolean = true;
|
|
var
|
|
|
|
last_assigned : pheap_mem_info;
|
|
getmem_nb : longint;
|
|
freemem_nb : longint;
|
|
{$EndIf CHECKHEAP}
|
|
|
|
|
|
{ Temp Heap }
|
|
{$ifdef TEMPHEAP}
|
|
const
|
|
heap_split : boolean = false;
|
|
type
|
|
pheapinfo = ^theapinfo;
|
|
theapinfo = record
|
|
heaporg,heapptr,
|
|
heapend,freelist : pointer;
|
|
memavail,heapsize : longint;
|
|
block : pblocks;
|
|
nblock : pnblocks;
|
|
{$IfDef CHECKHEAP}
|
|
last_mem : pheap_mem_info;
|
|
nb_get,
|
|
nb_free : longint;
|
|
{$EndIf CHECKHEAP}
|
|
end;
|
|
var
|
|
baseheap : theapinfo;
|
|
curheap : pheapinfo;
|
|
tempheap : theapinfo;
|
|
otherheap : pheapinfo;
|
|
{$endif TEMPHEAP}
|
|
|
|
{*****************************************************************************
|
|
Memory Manager
|
|
*****************************************************************************}
|
|
|
|
procedure GetMemoryManager(var MemMgr:TMemoryManager);
|
|
begin
|
|
MemMgr:=MemoryManager;
|
|
end;
|
|
|
|
|
|
procedure SetMemoryManager(const MemMgr:TMemoryManager);
|
|
begin
|
|
MemoryManager:=MemMgr;
|
|
end;
|
|
|
|
|
|
function IsMemoryManagerSet:Boolean;
|
|
begin
|
|
IsMemoryManagerSet:=(MemoryManager.GetMem<>@SysGetMem) or
|
|
(MemoryManager.FreeMem<>@SysFreeMem);
|
|
end;
|
|
|
|
|
|
procedure GetMem(Var p:pointer;Size:Longint);[public,alias:'FPC_GETMEM'];
|
|
begin
|
|
MemoryManager.GetMem(p,Size);
|
|
end;
|
|
|
|
|
|
procedure FreeMem(Var p:pointer;Size:Longint);[public,alias:'FPC_FREEMEM'];
|
|
begin
|
|
MemoryManager.FreeMem(p,Size);
|
|
end;
|
|
|
|
|
|
{*****************************************************************************
|
|
Heapsize,Memavail,MaxAvail
|
|
*****************************************************************************}
|
|
|
|
function heapsize : longint;
|
|
begin
|
|
heapsize:=internal_heapsize;
|
|
end;
|
|
|
|
|
|
function memavail : longint;
|
|
begin
|
|
memavail:=internal_memavail;
|
|
end;
|
|
|
|
|
|
function maxavail : longint;
|
|
var
|
|
hp : pfreerecord;
|
|
begin
|
|
maxavail:=heapend-heapptr;
|
|
hp:=freelist;
|
|
while assigned(hp) do
|
|
begin
|
|
if hp^.size>maxavail then
|
|
maxavail:=hp^.size;
|
|
hp:=hp^.next;
|
|
end;
|
|
end;
|
|
|
|
|
|
function calc_memavail : longint;
|
|
var
|
|
hp : pfreerecord;
|
|
ma : longint;
|
|
i : longint;
|
|
begin
|
|
ma:=heapend-heapptr;
|
|
{ count blocks }
|
|
if heapblocks then
|
|
for i:=1 to maxblock do
|
|
inc(ma,i*8*nblocks^[i]);
|
|
{ walk freelist }
|
|
hp:=freelist;
|
|
while assigned(hp) do
|
|
begin
|
|
inc(ma,hp^.size);
|
|
{$IfDef CHECKHEAP}
|
|
if (longint(hp^.next)=0) then
|
|
begin
|
|
if ((longint(hp)+hp^.size)>longint(heapptr)) then
|
|
writeln('freerecordlist bad at end ')
|
|
end
|
|
else
|
|
if ((longint(hp^.next)<=(longint(hp)+hp^.size)) or
|
|
((hp^.size and 7) <> 0)) then
|
|
writeln('error in freerecord list ');
|
|
{$EndIf CHECKHEAP}
|
|
hp:=hp^.next;
|
|
end;
|
|
calc_memavail:=ma;
|
|
end;
|
|
|
|
|
|
{*****************************************************************************
|
|
Check Heap helpers
|
|
*****************************************************************************}
|
|
|
|
{$IfDef CHECKHEAP}
|
|
|
|
procedure call_stack(p : pointer);
|
|
var
|
|
i : longint;
|
|
pp : pheap_mem_info;
|
|
begin
|
|
if trace then
|
|
begin
|
|
pp:=pheap_mem_info(p-sizeof(heap_mem_info));
|
|
writeln('Call trace of 0x',hexstr(longint(p),8));
|
|
writeln('of size ',pp^.size);
|
|
for i:=1 to tracesize do
|
|
writeln(i,' 0x',hexstr(pp^.calls[i],8));
|
|
end
|
|
else
|
|
writeln('tracing not enabled, sorry !!');
|
|
end;
|
|
|
|
procedure dump_heap(mark : boolean);
|
|
var
|
|
pp : pheap_mem_info;
|
|
begin
|
|
pp:=last_assigned;
|
|
while pp<>nil do
|
|
begin
|
|
call_stack(pp+sizeof(heap_mem_info));
|
|
if mark then
|
|
pp^.sig:=$AAAAAAAA;
|
|
pp:=pp^.previous;
|
|
end;
|
|
end;
|
|
|
|
procedure dump_free(p : pheap_mem_info);
|
|
var
|
|
ebp : longint;
|
|
begin
|
|
Writeln('Marked memory at ',HexStr(longint(p),8),' released');
|
|
call_stack(p+sizeof(heap_mem_info));
|
|
dump_stack(output,get_caller_frame(get_frame));
|
|
end;
|
|
|
|
|
|
function is_in_getmem_list (p : pointer) : boolean;
|
|
var
|
|
i : longint;
|
|
pp : pheap_mem_info;
|
|
begin
|
|
is_in_getmem_list:=false;
|
|
pp:=last_assigned;
|
|
i:=0;
|
|
while pp<>nil do
|
|
begin
|
|
if (pp^.sig<>$DEADBEEF) and (pp^.sig <> $AAAAAAAA) then
|
|
begin
|
|
writeln('error in linked list of heap_mem_info');
|
|
HandleError(204);
|
|
end
|
|
if pp=p then
|
|
is_in_getmem_list:=true;
|
|
pp:=pp^.previous;
|
|
inc(i);
|
|
if i > getmem_nb - freemem_nb then
|
|
writeln('error in linked list of heap_mem_info');
|
|
end;
|
|
end;
|
|
|
|
function is_in_free(p : pointer) : boolean;
|
|
var
|
|
hp : pfreerecord;
|
|
begin
|
|
if p>heapptr then
|
|
begin
|
|
is_in_free:=true;
|
|
exit;
|
|
end
|
|
else
|
|
begin
|
|
hp:=freelist;
|
|
while assigned(hp) do
|
|
begin
|
|
if (p>=hp) and (p<hp+hp^.size) then
|
|
begin
|
|
is_in_free:=true;
|
|
exit;
|
|
end;
|
|
hp:=hp^.next;
|
|
end;
|
|
is_in_free:=false;
|
|
end;
|
|
end;
|
|
|
|
procedure test_memavail;
|
|
begin
|
|
if check and (internal_memavail<>calc_memavail) then
|
|
writeln('Memavail error in getmem/freemem');
|
|
end;
|
|
|
|
{$EndIf CHECKHEAP}
|
|
|
|
|
|
{*****************************************************************************
|
|
Temp Heap support
|
|
*****************************************************************************}
|
|
|
|
{$ifdef TEMPHEAP}
|
|
procedure split_heap;
|
|
begin
|
|
if not heap_split then
|
|
begin
|
|
getmem(tempheap.block,sizeof(tblocks));
|
|
getmem(tempheap.nblock,sizeof(tnblocks));
|
|
fillchar(tempheap.block^,sizeof(tblocks),0);
|
|
fillchar(tempheap.nblock^,sizeof(tnblocks),0);
|
|
baseheap.heaporg:=heaporg;
|
|
baseheap.heapptr:=heapptr;
|
|
baseheap.freelist:=freelist;
|
|
baseheap.block:=blocks;
|
|
baseheap.nblock:=nblocks;
|
|
longint(baseheap.heapend):=((longint(heapend)+longint(heapptr)) div 16)*8;
|
|
tempheap.heaporg:=baseheap.heapend;
|
|
tempheap.freelist:=nil;
|
|
tempheap.heapptr:=tempheap.heaporg;
|
|
{$IfDef CHECKHEAP}
|
|
tempheap.last_mem:=nil;
|
|
tempheap.nb_get:=0;
|
|
tempheap.nb_free:=0;
|
|
{$EndIf CHECKHEAP}
|
|
tempheap.heapend:=heapend;
|
|
tempheap.memavail:=longint(tempheap.heapend) - longint(tempheap.heaporg);
|
|
tempheap.heapsize:=tempheap.memavail;
|
|
heapend:=baseheap.heapend;
|
|
internal_memavail:=calc_memavail;
|
|
baseheap.memavail:=internal_memavail;
|
|
baseheap.heapsize:=longint(baseheap.heapend)-longint(baseheap.heaporg);
|
|
curheap:=@baseheap;
|
|
otherheap:=@tempheap;
|
|
heap_split:=true;
|
|
end;
|
|
end;
|
|
|
|
procedure switch_to_temp_heap;
|
|
begin
|
|
if curheap = @baseheap then
|
|
begin
|
|
baseheap.heaporg:=heaporg;
|
|
baseheap.heapend:=heapend;
|
|
baseheap.heapptr:=heapptr;
|
|
baseheap.freelist:=freelist;
|
|
baseheap.memavail:=internal_memavail;
|
|
baseheap.block:=blocks;
|
|
baseheap.nblock:=nblocks;
|
|
{$IfDef CHECKHEAP}
|
|
baseheap.last_mem:=last_assigned;
|
|
last_assigned:=tempheap.last_mem;
|
|
baseheap.nb_get:=getmem_nb;
|
|
baseheap.nb_free:=freemem_nb;
|
|
getmem_nb:=tempheap.nb_get;
|
|
freemem_nb:=tempheap.nb_free;
|
|
{$EndIf CHECKHEAP}
|
|
heaporg:=tempheap.heaporg;
|
|
heapptr:=tempheap.heapptr;
|
|
freelist:=tempheap.freelist;
|
|
heapend:=tempheap.heapend;
|
|
blocks:=tempheap.block;
|
|
nblocks:=tempheap.nblock;
|
|
internal_memavail:=calc_memavail;
|
|
curheap:=@tempheap;
|
|
otherheap:=@baseheap;
|
|
end;
|
|
end;
|
|
|
|
procedure switch_to_base_heap;
|
|
begin
|
|
if curheap = @tempheap then
|
|
begin
|
|
tempheap.heaporg:=heaporg;
|
|
tempheap.heapend:=heapend;
|
|
tempheap.heapptr:=heapptr;
|
|
tempheap.freelist:=freelist;
|
|
tempheap.memavail:=internal_memavail;
|
|
{$IfDef CHECKHEAP}
|
|
tempheap.last_mem:=last_assigned;
|
|
last_assigned:=baseheap.last_mem;
|
|
tempheap.nb_get:=getmem_nb;
|
|
tempheap.nb_free:=freemem_nb;
|
|
getmem_nb:=baseheap.nb_get;
|
|
freemem_nb:=baseheap.nb_free;
|
|
{$EndIf CHECKHEAP}
|
|
heaporg:=baseheap.heaporg;
|
|
heapptr:=baseheap.heapptr;
|
|
freelist:=baseheap.freelist;
|
|
heapend:=baseheap.heapend;
|
|
blocks:=baseheap.block;
|
|
nblocks:=baseheap.nblock;
|
|
internal_memavail:=calc_memavail;
|
|
curheap:=@baseheap;
|
|
otherheap:=@tempheap;
|
|
end;
|
|
end;
|
|
|
|
procedure switch_heap;
|
|
begin
|
|
if not heap_split then
|
|
split_heap;
|
|
if curheap = @tempheap then
|
|
switch_to_base_heap
|
|
else
|
|
switch_to_temp_heap;
|
|
end;
|
|
|
|
procedure gettempmem(var p : pointer;size : longint);
|
|
begin
|
|
split_heap;
|
|
switch_to_temp_heap;
|
|
allow_special:=true;
|
|
getmem(p,size);
|
|
allow_special:=false;
|
|
end;
|
|
|
|
procedure unsplit_heap;
|
|
var
|
|
hp,hp2,thp : pfreerecord;
|
|
begin
|
|
{heapend can be modified by HeapError }
|
|
if not heap_split then
|
|
exit;
|
|
if baseheap.heapend = tempheap.heaporg then
|
|
begin
|
|
switch_to_base_heap;
|
|
hp:=pfreerecord(freelist);
|
|
if assigned(hp) then
|
|
begin
|
|
while assigned(hp^.next) do
|
|
hp:=hp^.next;
|
|
end;
|
|
if tempheap.heapptr<>tempheap.heaporg then
|
|
begin
|
|
if hp<>nil then
|
|
hp^.next:=heapptr;
|
|
hp:=pfreerecord(heapptr);
|
|
hp^.size:=heapend-heapptr;
|
|
hp^.next:=tempheap.freelist;
|
|
heapptr:=tempheap.heapptr;
|
|
end;
|
|
heapend:=tempheap.heapend;
|
|
internal_memavail:=calc_memavail;
|
|
heap_split:=false;
|
|
end
|
|
else
|
|
begin
|
|
hp:=pfreerecord(baseheap.freelist);
|
|
hp2:=pfreerecord(tempheap.freelist);
|
|
while assigned(hp) and assigned(hp2) do
|
|
begin
|
|
if hp=hp2 then
|
|
break;
|
|
if hp>hp2 then
|
|
begin
|
|
thp:=hp2;
|
|
hp2:=hp;
|
|
hp:=thp;
|
|
end;
|
|
while assigned(hp^.next) and (hp^.next<hp2) do
|
|
hp:=hp^.next;
|
|
if assigned(hp^.next) then
|
|
begin
|
|
thp:=hp^.next;
|
|
hp^.next:=hp2;
|
|
hp:=thp;
|
|
end
|
|
else
|
|
begin
|
|
hp^.next:=hp2;
|
|
hp:=nil;
|
|
end;
|
|
end;
|
|
if heapend < tempheap.heapend then
|
|
heapend:=tempheap.heapend;
|
|
if heapptr < tempheap.heapptr then
|
|
heapptr:=tempheap.heapptr;
|
|
freemem(tempheap.block,sizeof(tblocks));
|
|
freemem(tempheap.nblock,sizeof(tnblocks));
|
|
internal_memavail:=calc_memavail;
|
|
heap_split:=false;
|
|
end;
|
|
end;
|
|
|
|
procedure releasetempheap;
|
|
begin
|
|
switch_to_temp_heap;
|
|
{$ifdef CHECKHEAP}
|
|
if heapptr<>heaporg then
|
|
writeln('Warning in releasetempheap : ',longint(tempheap.heapsize)-longint(tempheap.memavail),' bytes used !');
|
|
dump_heap(true);
|
|
{ release(heaporg);
|
|
fillchar(heaporg^,longint(heapend)-longint(heaporg),#0); }
|
|
{$endif CHECKHEAP }
|
|
unsplit_heap;
|
|
split_heap;
|
|
end;
|
|
{$endif TEMPHEAP}
|
|
|
|
|
|
{*****************************************************************************
|
|
SysGetMem
|
|
*****************************************************************************}
|
|
|
|
procedure SysGetMem(var p : pointer;size : longint);
|
|
type
|
|
heaperrorproc=function(size:longint):integer;
|
|
var
|
|
proc : heaperrorproc;
|
|
last,hp : pfreerecord;
|
|
again : boolean;
|
|
s,hpsize : longint;
|
|
{$IfDef CHECKHEAP}
|
|
i,bp,orsize : longint;
|
|
label
|
|
check_new;
|
|
{$endif CHECKHEAP}
|
|
begin
|
|
{$ifdef CHECKHEAP}
|
|
if trace then
|
|
begin
|
|
orsize:=size;
|
|
inc(size,sizeof(heap_mem_info));
|
|
end;
|
|
{$endif CHECKHEAP}
|
|
{ Something to allocate ? }
|
|
if size<=0 then
|
|
begin
|
|
{ give an error for < 0 }
|
|
if size<0 then
|
|
HandleError(204);
|
|
p:=heapend;
|
|
{$ifdef CHECKHEAP}
|
|
goto check_new;
|
|
{$else CHECKHEAP}
|
|
exit;
|
|
{$endif CHECKHEAP}
|
|
end;
|
|
{ temp heap checking }
|
|
{$ifdef TEMPHEAP}
|
|
if heap_split and not allow_special then
|
|
begin
|
|
if (@p < otherheap^.heapend) and (@p > otherheap^.heaporg) then
|
|
{ useful line for the debugger }
|
|
writeln('warning : p and @p are in different heaps !');
|
|
end;
|
|
{$endif TEMPHEAP}
|
|
{ calc to multiply of 8 }
|
|
size:=(size+7) and (not 7);
|
|
dec(internal_memavail,size);
|
|
{ first try heap blocks }
|
|
if heapblocks then
|
|
begin
|
|
{ search cache }
|
|
if size<=max_size then
|
|
begin
|
|
s:=size shr 3;
|
|
p:=blocks^[s];
|
|
if assigned(p) then
|
|
begin
|
|
blocks^[s]:=pointer(p^);
|
|
dec(nblocks^[s]);
|
|
{$ifdef CHECKHEAP}
|
|
goto check_new;
|
|
{$else CHECKHEAP}
|
|
exit;
|
|
{$endif CHECKHEAP}
|
|
end;
|
|
end;
|
|
end;
|
|
{ walk free list }
|
|
repeat
|
|
again:=false;
|
|
{ search the freelist }
|
|
if assigned(freelist) then
|
|
begin
|
|
last:=nil;
|
|
hp:=freelist;
|
|
while assigned(hp) do
|
|
begin
|
|
hpsize:=hp^.size;
|
|
{ take the first fitting block }
|
|
if hpsize>=size then
|
|
begin
|
|
p:=hp;
|
|
{ need we the whole block ? }
|
|
if (hpsize>size) and heapblocks then
|
|
begin
|
|
{ we must check if we are still below the limit !! }
|
|
if hpsize-size<=max_size then
|
|
begin
|
|
{ adjust the list }
|
|
if assigned(last) then
|
|
last^.next:=hp^.next
|
|
else
|
|
freelist:=hp^.next;
|
|
{ insert in chain }
|
|
s:=(hpsize-size) div 8;
|
|
ppointer(hp+size)^:=blocks^[s];
|
|
blocks^[s]:=hp+size;
|
|
inc(nblocks^[s]);
|
|
end
|
|
else
|
|
begin
|
|
(hp+size)^.size:=hpsize-size;
|
|
(hp+size)^.next:=hp^.next;
|
|
if assigned(last) then
|
|
last^.next:=hp+size
|
|
else
|
|
freelist:=hp+size;
|
|
end;
|
|
end
|
|
else
|
|
begin
|
|
{$IfDef CHECKHEAP}
|
|
dec(freerecord_list_length);
|
|
{$endif CHECKHEAP}
|
|
if assigned(last) then
|
|
last^.next:=hp^.next
|
|
else
|
|
freelist:=hp^.next;
|
|
end;
|
|
{$ifdef CHECKHEAP}
|
|
goto check_new;
|
|
{$else CHECKHEAP}
|
|
exit;
|
|
{$endif CHECKHEAP}
|
|
end;
|
|
last:=hp;
|
|
hp:=hp^.next;
|
|
end;
|
|
end;
|
|
{ Latly, the top of the heap is checked, to see if there is }
|
|
{ still memory available. }
|
|
if heapend-heapptr<size then
|
|
begin
|
|
if assigned(heaperror) then
|
|
begin
|
|
proc:=heaperrorproc(heaperror);
|
|
case proc(size) of
|
|
0 : HandleError(203);
|
|
1 : p:=nil;
|
|
2 : again:=true;
|
|
end;
|
|
end
|
|
else
|
|
HandleError(203);
|
|
end
|
|
else
|
|
begin
|
|
p:=heapptr;
|
|
inc(heapptr,size);
|
|
end;
|
|
until not again;
|
|
{$ifdef CHECKHEAP}
|
|
check_new:
|
|
inc(getmem_nb);
|
|
test_memavail;
|
|
if trace then
|
|
begin
|
|
pheap_mem_info(p)^.sig:=$DEADBEEF;
|
|
pheap_mem_info(p)^.previous:=last_assigned;
|
|
if last_assigned<>nil then
|
|
last_assigned^.next:=pheap_mem_info(p);
|
|
last_assigned:=p;
|
|
pheap_mem_info(p)^.next:=nil;
|
|
pheap_mem_info(p)^.size:=orsize;
|
|
bp:=get_caller_frame(get_frame);
|
|
for i:=1 to tracesize do
|
|
begin
|
|
pheap_mem_info(p)^.calls[i]:=get_caller_addr(bp);
|
|
bp:=get_caller_frame(bp);
|
|
end;
|
|
inc(p,sizeof(heap_mem_info));
|
|
end;
|
|
{$endif CHECKHEAP}
|
|
end;
|
|
|
|
|
|
{*****************************************************************************
|
|
SysFreeMem
|
|
*****************************************************************************}
|
|
|
|
procedure SysFreeMem(var p : pointer;size : longint);
|
|
var
|
|
hp : pfreerecord;
|
|
{$ifdef TEMPHEAP}
|
|
heap_switched : boolean;
|
|
{$endif TEMPHEAP}
|
|
s : longint;
|
|
label
|
|
freemem_exit;
|
|
begin
|
|
if size<=0 then
|
|
begin
|
|
if size<0 then
|
|
HandleError(204);
|
|
p:=nil;
|
|
exit;
|
|
end;
|
|
if p=nil then
|
|
HandleError(204);
|
|
{$ifdef CHECKHEAP}
|
|
if free_nothing then
|
|
begin
|
|
p:=nil;
|
|
exit;
|
|
end;
|
|
if trace then
|
|
begin
|
|
inc(size,sizeof(heap_mem_info));
|
|
dec(p,sizeof(heap_mem_info));
|
|
end;
|
|
{$endif CHECKHEAP}
|
|
{$ifdef TEMPHEAP}
|
|
heap_switched:=false;
|
|
if heap_split and not allow_special then
|
|
begin
|
|
if (p<=heapptr) and (p>=heaporg) and
|
|
(@p<=otherheap^.heapend) and (@p>=otherheap^.heaporg) then
|
|
writeln('warning : p and @p are in different heaps !');
|
|
end;
|
|
if (p<heaporg) or (p>heapptr) then
|
|
begin
|
|
if heap_split and (p<otherheap^.heapend) and (p>otherheap^.heaporg) then
|
|
begin
|
|
if (@p>=heaporg) and (@p<=heapptr) and not allow_special then
|
|
writeln('warning : p and @p are in different heaps !');
|
|
switch_heap;
|
|
heap_switched:=true;
|
|
end
|
|
else
|
|
begin
|
|
writeln('pointer ',hexstr(longint(@p),8),' at ',hexstr(longint(p),8),' doesn''t points to the heap');
|
|
HandleError(204);
|
|
end;
|
|
end;
|
|
{$endif TEMPHEAP}
|
|
{$ifdef CHECKHEAP}
|
|
if trace then
|
|
begin
|
|
if not (is_in_getmem_list(p)) then
|
|
HandleError(204);
|
|
if pheap_mem_info(p)^.sig=$AAAAAAAA then
|
|
dump_free(p);
|
|
if pheap_mem_info(p)^.next<>nil then
|
|
pheap_mem_info(p)^.next^.previous:=pheap_mem_info(p)^.previous;
|
|
if pheap_mem_info(p)^.previous<>nil then
|
|
pheap_mem_info(p)^.previous^.next:=pheap_mem_info(p)^.next;
|
|
if pheap_mem_info(p)=last_assigned then
|
|
last_assigned:=last_assigned^.previous;
|
|
end;
|
|
{$endif CHECKHEAP}
|
|
{ calc to multiple of 8 }
|
|
size:=(size+7) and (not 7);
|
|
inc(internal_memavail,size);
|
|
{ end of the heap ? }
|
|
if p+size>=heapptr then
|
|
begin
|
|
if p+size>heapptr then
|
|
HandleError(204);
|
|
heapptr:=p;
|
|
{internal_memavail:=internal_heapsize;
|
|
THIS IS WRONG !!!!!! PM
|
|
it would only be true if p is heaporg ! }
|
|
goto freemem_exit;
|
|
end;
|
|
{ heap block? }
|
|
if heapblocks and (size<=max_size) then
|
|
begin
|
|
s:=size shr 3;
|
|
ppointer(p)^:=blocks^[s];
|
|
blocks^[s]:=p;
|
|
inc(nblocks^[s]);
|
|
end
|
|
else
|
|
begin
|
|
{ size can be allways set }
|
|
pfreerecord(p)^.size:=size;
|
|
{ if there is no free list }
|
|
if not assigned(freelist) then
|
|
begin
|
|
{ then generate one }
|
|
freelist:=p;
|
|
pfreerecord(p)^.next:=nil;
|
|
{$ifdef CHECKHEAP}
|
|
inc(freerecord_list_length);
|
|
{$endif CHECKHEAP}
|
|
goto freemem_exit;
|
|
end;
|
|
if p+size<freelist then
|
|
begin
|
|
pfreerecord(p)^.next:=freelist;
|
|
freelist:=p;
|
|
{$ifdef CHECKHEAP}
|
|
inc(freerecord_list_length);
|
|
{$endif CHECKHEAP}
|
|
goto freemem_exit;
|
|
end
|
|
else
|
|
if p+size=freelist then
|
|
begin
|
|
pfreerecord(p)^.size:=Pfreerecord(p)^.size+pfreerecord(freelist)^.size;
|
|
pfreerecord(p)^.next:=pfreerecord(freelist)^.next;
|
|
freelist:=p;
|
|
{ but now it can also connect the next block !!}
|
|
if p+pfreerecord(p)^.size=pfreerecord(p)^.next then
|
|
begin
|
|
pfreerecord(p)^.size:=pfreerecord(p)^.size+pfreerecord(p)^.next^.size;
|
|
{$ifdef CHECKHEAP}
|
|
dec(freerecord_list_length);
|
|
{$endif CHECKHEAP}
|
|
pfreerecord(p)^.next:=pfreerecord(freelist)^.next^.next;
|
|
end;
|
|
goto freemem_exit;
|
|
end;
|
|
{ insert block in freelist }
|
|
hp:=freelist;
|
|
while assigned(hp) do
|
|
begin
|
|
if p<hp+hp^.size then
|
|
begin
|
|
{$ifdef CHECKHEAP}
|
|
writeln('pointer to dispose at ',hexstr(longint(p),8),' has already been disposed');
|
|
{$endif CHECKHEAP}
|
|
HandleError(204);
|
|
end;
|
|
{ connecting two blocks ? }
|
|
if hp+hp^.size=p then
|
|
begin
|
|
inc(hp^.size,size);
|
|
{ connecting also to next block ? }
|
|
if hp+hp^.size=hp^.next then
|
|
begin
|
|
inc(hp^.size,hp^.next^.size);
|
|
{$ifdef CHECKHEAP}
|
|
dec(freerecord_list_length);
|
|
{$endif CHECKHEAP}
|
|
hp^.next:=hp^.next^.next;
|
|
end
|
|
else
|
|
if (hp^.next<>nil) and (hp+hp^.size>hp^.next) then
|
|
begin
|
|
{$ifdef CHECKHEAP}
|
|
writeln('pointer to dispose at ',hexstr(longint(p),8),' is too big !!');
|
|
{$endif CHECKHEAP}
|
|
HandleError(204);
|
|
end;
|
|
break;
|
|
end
|
|
{ if the end is reached, then concat }
|
|
else
|
|
if hp^.next=nil then
|
|
begin
|
|
hp^.next:=p;
|
|
{$ifdef CHECKHEAP}
|
|
inc(freerecord_list_length);
|
|
{$endif CHECKHEAP}
|
|
pfreerecord(p)^.next:=nil;
|
|
break;
|
|
end
|
|
{ if next pointer is greater, then insert }
|
|
else
|
|
if hp^.next>p then
|
|
begin
|
|
{ connect to blocks }
|
|
if p+size=hp^.next then
|
|
begin
|
|
pfreerecord(p)^.next:=hp^.next^.next;
|
|
pfreerecord(p)^.size:=pfreerecord(p)^.size+hp^.next^.size;
|
|
{ we have to reset the right position }
|
|
hp^.next:=pfreerecord(p);
|
|
end
|
|
else
|
|
begin
|
|
pfreerecord(p)^.next:=hp^.next;
|
|
hp^.next:=p;
|
|
{$ifdef CHECKHEAP}
|
|
inc(freerecord_list_length);
|
|
{$endif CHECKHEAP}
|
|
end;
|
|
break;
|
|
end;
|
|
hp:=hp^.next;
|
|
end;
|
|
end;
|
|
freemem_exit:
|
|
{$ifdef CHECKHEAP}
|
|
inc(freemem_nb);
|
|
test_memavail;
|
|
{$endif CHECKHEAP}
|
|
{$ifdef TEMPHEAP}
|
|
if heap_switched then
|
|
switch_heap;
|
|
{$endif TEMPHEAP}
|
|
p:=nil;
|
|
end;
|
|
|
|
|
|
{*****************************************************************************
|
|
Mark/Release
|
|
*****************************************************************************}
|
|
|
|
procedure release(var p : pointer);
|
|
begin
|
|
heapptr:=p;
|
|
freelist:=nil;
|
|
internal_memavail:=calc_memavail;
|
|
end;
|
|
|
|
|
|
procedure mark(var p : pointer);
|
|
begin
|
|
p:=heapptr;
|
|
end;
|
|
|
|
|
|
procedure markheap(var oldfreelist,oldheapptr : pointer);
|
|
begin
|
|
oldheapptr:=heapptr;
|
|
oldfreelist:=freelist;
|
|
freelist:=nil;
|
|
internal_memavail:=calc_memavail;
|
|
end;
|
|
|
|
|
|
|
|
procedure releaseheap(oldfreelist,oldheapptr : pointer);
|
|
begin
|
|
heapptr:=oldheapptr;
|
|
if longint(freelist) < longint(heapptr) then
|
|
begin
|
|
{ here we should reget the freed blocks }
|
|
end;
|
|
freelist:=oldfreelist;
|
|
internal_memavail:=calc_memavail;
|
|
end;
|
|
|
|
|
|
{*****************************************************************************
|
|
Grow Heap
|
|
*****************************************************************************}
|
|
|
|
function growheap(size :longint) : integer;
|
|
var
|
|
{$ifdef CHECKHEAP}
|
|
NewLimit,
|
|
{$endif CHECKHEAP}
|
|
NewPos,
|
|
wantedsize : longint;
|
|
hp : pfreerecord;
|
|
begin
|
|
wantedsize:=size;
|
|
{ Allocate by 64K size }
|
|
size:=(size+$fffff) and $ffff0000;
|
|
{ first try 256K (default) }
|
|
if size<GrowHeapSize1 then
|
|
begin
|
|
NewPos:=Sbrk(GrowHeapSize1);
|
|
if NewPos>0 then
|
|
size:=GrowHeapSize1;
|
|
end
|
|
else
|
|
{ second try 1024K (default) }
|
|
if size<GrowHeapSize2 then
|
|
begin
|
|
NewPos:=Sbrk(GrowHeapSize2);
|
|
if NewPos>0 then
|
|
size:=GrowHeapSize2;
|
|
end
|
|
{ else alloate the needed bytes }
|
|
else
|
|
NewPos:=SBrk(size);
|
|
{ try again }
|
|
if NewPos=-1 then
|
|
begin
|
|
NewPos:=Sbrk(size);
|
|
if NewPos=-1 then
|
|
begin
|
|
GrowHeap:=0;
|
|
{$IfDef CHECKHEAP}
|
|
writeln('Call to GrowHeap failed');
|
|
readln;
|
|
{$EndIf CHECKHEAP}
|
|
Exit;
|
|
end;
|
|
end;
|
|
{ make the room clean }
|
|
{$ifdef CHECKHEAP}
|
|
Fillword(pointer(NewPos)^,size div 2,$ABCD);
|
|
Newlimit:=(newpos+size) or $3fff;
|
|
{$endif CHECKHEAP}
|
|
hp:=pfreerecord(freelist);
|
|
if not assigned(hp) then
|
|
begin
|
|
if pointer(newpos) = heapend then
|
|
heapend:=pointer(newpos+size)
|
|
else
|
|
begin
|
|
if heapend - heapptr > 0 then
|
|
begin
|
|
freelist:=heapptr;
|
|
hp:=pfreerecord(freelist);
|
|
hp^.size:=heapend-heapptr;
|
|
hp^.next:=nil;
|
|
end;
|
|
heapptr:=pointer(newpos);
|
|
heapend:=pointer(newpos+size);
|
|
end;
|
|
end
|
|
else
|
|
begin
|
|
if pointer(newpos) = heapend then
|
|
heapend:=pointer(newpos+size)
|
|
else
|
|
begin
|
|
while assigned(hp^.next) and (longint(hp^.next) < longint(NewPos)) do
|
|
hp:=hp^.next;
|
|
if hp^.next = nil then
|
|
begin
|
|
hp^.next:=pfreerecord(heapptr);
|
|
hp:=pfreerecord(heapptr);
|
|
hp^.size:=heapend-heapptr;
|
|
hp^.next:=nil;
|
|
heapptr:=pointer(NewPos);
|
|
heapend:=pointer(NewPos+Size);
|
|
end
|
|
else
|
|
begin
|
|
pfreerecord(NewPos)^.Size:=Size;
|
|
pfreerecord(NewPos)^.Next:=hp^.next;
|
|
hp^.next:=pfreerecord(NewPos);
|
|
end;
|
|
end;
|
|
end;
|
|
{ the wanted size has to be substracted
|
|
why it will be substracted in the second try
|
|
to get the memory PM }
|
|
internal_memavail:=calc_memavail;
|
|
{ set the total new heap size }
|
|
inc(internal_heapsize,size);
|
|
{ try again }
|
|
GrowHeap:=2;
|
|
{$IfDef CHECKHEAP}
|
|
writeln('Call to GrowHeap succedeed : HeapSize = ',internal_heapsize,' MemAvail = ',memavail);
|
|
writeln('New heap part begins at ',Newpos,' with size ',size);
|
|
if growheapstop then
|
|
readln;
|
|
{$EndIf CHECKHEAP}
|
|
end;
|
|
|
|
|
|
{*****************************************************************************
|
|
InitHeap
|
|
*****************************************************************************}
|
|
|
|
{ This function will initialize the Heap manager and need to be called from
|
|
the initialization of the system unit }
|
|
procedure InitHeap;
|
|
begin
|
|
FillChar(Blocks^,sizeof(Blocks^),0);
|
|
FillChar(NBlocks^,sizeof(NBlocks^),0);
|
|
{$ifdef TEMPHEAP}
|
|
Curheap:=@baseheap;
|
|
Otherheap:=@tempheap;
|
|
{$endif TEMPHEAP}
|
|
internal_heapsize:=GetHeapSize;
|
|
internal_memavail:=internal_heapsize;
|
|
HeapOrg:=GetHeapStart;
|
|
HeapPtr:=HeapOrg;
|
|
HeapEnd:=HeapOrg+internal_memavail;
|
|
HeapError:=@GrowHeap;
|
|
Freelist:=nil;
|
|
end;
|
|
|
|
{
|
|
$Log$
|
|
Revision 1.11 1999-05-31 20:36:34 peter
|
|
* growing is now 256k or 1mb
|
|
|
|
Revision 1.10 1999/05/17 21:52:36 florian
|
|
* most of the Object Pascal stuff moved to the system unit
|
|
|
|
Revision 1.9 1999/04/19 11:53:13 pierre
|
|
* error 204 if trying to free too much memory of heap top !
|
|
|
|
Revision 1.8 1999/04/19 11:11:39 pierre
|
|
* wrong statement in freemem removed : corrupted memavail result
|
|
|
|
Revision 1.7 1999/03/18 11:21:16 peter
|
|
* memavail fixed for too big freemem calls
|
|
|
|
Revision 1.6 1999/02/08 09:31:39 florian
|
|
* fixed small things regarding TEMPHEAP
|
|
|
|
Revision 1.5 1999/01/22 12:39:21 pierre
|
|
+ added text arg for dump_stack
|
|
|
|
Revision 1.4 1998/12/16 00:22:24 peter
|
|
* more temp symbols removed
|
|
|
|
Revision 1.3 1998/10/22 23:50:45 peter
|
|
+ check for < 0 which otherwise segfaulted
|
|
|
|
Revision 1.2 1998/10/01 14:55:17 peter
|
|
+ memorymanager like delphi
|
|
|
|
Revision 1.1 1998/09/14 10:48:17 peter
|
|
* FPC_ names
|
|
* Heap manager is now system independent
|
|
|
|
Revision 1.18 1998/09/08 15:02:48 peter
|
|
* much more readable :)
|
|
|
|
Revision 1.17 1998/09/04 17:27:48 pierre
|
|
* small corrections
|
|
|
|
Revision 1.16 1998/08/25 14:15:51 pierre
|
|
* corrected a bug introduced by my last change
|
|
(allocating 1Mb but only using a small part !!)
|
|
|
|
Revision 1.15 1998/08/24 14:44:04 pierre
|
|
* bug allocation of more than 1 MB failed corrected
|
|
|
|
Revision 1.14 1998/07/30 13:26:21 michael
|
|
+ Added support for ErrorProc variable. All internal functions are required
|
|
to call HandleError instead of runerror from now on.
|
|
This is necessary for exception support.
|
|
|
|
Revision 1.13 1998/07/02 14:24:09 michael
|
|
Undid carls changes, but renamed _heapsize to internal_heapsize. Make cycle now works
|
|
|
|
Revision 1.11 1998/06/25 09:26:10 daniel
|
|
* Removed some more tabs
|
|
|
|
Revision 1.10 1998/06/24 11:53:26 daniel
|
|
* Removed some tabs.
|
|
|
|
Revision 1.9 1998/06/16 14:55:49 daniel
|
|
* Optimizations
|
|
|
|
Revision 1.8 1998/06/15 15:15:13 daniel
|
|
* Brought my policy into practive that the RTL should output only runtime
|
|
errors and no other texts when things go wrong.
|
|
|
|
Revision 1.7 1998/05/30 15:01:28 peter
|
|
* this needs also direct mode :(
|
|
|
|
Revision 1.6 1998/05/25 10:40:48 peter
|
|
* remake3 works again on tflily
|
|
|
|
Revision 1.4 1998/04/21 10:22:48 peter
|
|
+ heapblocks
|
|
|
|
Revision 1.3 1998/04/09 08:32:14 daniel
|
|
* Optimized some code.
|
|
}
|