paweld/fpc
1
0
Fork 0
mirror of https://gitlab.com/freepascal.org/fpc/source.git synced 2025-04-20 04:59:26 +02:00
Code Issues Packages Projects Releases Wiki Activity

* heap manager: handle freeing of block owned by exited thread

Browse Source 
* heap trace: ditto

git-svn-id: trunk@7649 -
This commit is contained in:
micha 2007-06-13 20:27:42 +00:00
parent c7037df254
commit c226f6fd44
2 changed files with 485 additions and 228 deletions
Show Stats Download Patch File Download Diff File Expand all files Collapse all files

307
rtl/inc/heap.inc
View File

@ -134,8 +134,10 @@ type
poschunk = ^toschunk;
toschunk = record
size : ptrint;
next : poschunk;
used : ptrint;
next_free : poschunk;
prev_any : poschunk;
next_any : poschunk;
used : ptrint; { 0: free, >0: fixed, -1: var }
freelists : pfreelists;
{ padding inserted automatically by alloc_oschunk }
end;
@ -178,8 +180,9 @@ type
tfixedfreelists = array[1..maxblockindex] of pmemchunk_fixed;
tfreelists = record
oslist : poschunk;
oscount : dword;
oslist : poschunk; { os chunks free, available for use }
oscount : dword; { number of os chunks on oslist }
oslist_all : poschunk; { all os chunks allocated }
fixedlists : tfixedfreelists;
varlist : pmemchunk_var;
{ chunks waiting to be freed from other thread }
@ -205,6 +208,8 @@ const
var
main_orig_freelists : pfreelists;
main_relo_freelists : pfreelists;
orphaned_freelists : tfreelists;
orphaned_oslist_lock : trtlcriticalsection;
threadvar
freelists : tfreelists;
@ -398,6 +403,14 @@ end;
{$endif}
{*****************************************************************************
Forwards
*****************************************************************************}
procedure finish_waitfixedlist(loc_freelists: pfreelists); forward;
procedure finish_waitvarlist(loc_freelists: pfreelists); forward;
function try_finish_waitfixedlist(loc_freelists: pfreelists): boolean; forward;
procedure try_finish_waitvarlist(loc_freelists: pfreelists); forward;
{*****************************************************************************
List adding/removal
@ -453,12 +466,19 @@ begin
freelists.varlist := pmc^.next_var;
end;
procedure remove_all_from_list_fixed(chunksize: ptrint; poc: poschunk);
procedure remove_freed_fixed_chunks(poc: poschunk);
{ remove all fixed chunks from the fixed free list, as this os chunk
is going to be used for other purpose }
var
pmc, pmc_end: pmemchunk_fixed;
fixedlist: ppmemchunk_fixed;
chunksize: ptrint;
begin
{ exit if this is a var size os chunk, function only applicable to fixed size }
if poc^.used < 0 then
exit;
pmc := pmemchunk_fixed(pointer(poc)+fixedfirstoffset);
chunksize := pmc^.size and fixedsizemask;
pmc_end := pmemchunk_fixed(pointer(poc)+(poc^.size and sizemask)-chunksize);
fixedlist := @poc^.freelists^.fixedlists[chunksize shr blockshift];
repeat
@ -467,9 +487,24 @@ begin
until pmc > pmc_end;
end;
procedure append_to_oslist(poc: poschunk; chunksize: ptrint);
procedure free_oschunk(loc_freelists: pfreelists; poc: poschunk);
var
pocsize: ptrint;
begin
remove_freed_fixed_chunks(poc);
if assigned(poc^.prev_any) then
poc^.prev_any^.next_any := poc^.next_any
else
loc_freelists^.oslist_all := poc^.next_any;
if assigned(poc^.next_any) then
poc^.next_any^.prev_any := poc^.prev_any;
pocsize := poc^.size and sizemask;
dec(loc_freelists^.internal_status.currheapsize, pocsize);
SysOSFree(poc, pocsize);
end;
procedure append_to_oslist(poc: poschunk);
var
loc_freelists: pfreelists;
begin
loc_freelists := poc^.freelists;
@ -482,32 +517,22 @@ begin
end;
{ decide whether to free block or add to list }
{$ifdef HAS_SYSOSFREE}
pocsize := poc^.size and sizemask;
if (loc_freelists^.oscount >= MaxKeptOSChunks) or
(pocsize > growheapsize2) then
((poc^.size and sizemask) > growheapsize2) then
begin
if chunksize <> 0 then
remove_all_from_list_fixed(chunksize, poc);
dec(loc_freelists^.internal_status.currheapsize, pocsize);
SysOSFree(poc, pocsize);
free_oschunk(loc_freelists, poc);
end
else
begin
{$endif}
poc^.next := loc_freelists^.oslist;
poc^.next_free := loc_freelists^.oslist;
loc_freelists^.oslist := poc;
inc(loc_freelists^.oscount);
{$ifdef HAS_SYSOSFREE}
end;
end;
{$endif}
end;
procedure clear_oschunk_on_freelist_fixed_flag(poc: poschunk); inline;
{ prevent thinking this os chunk is on the fixed freelists }
begin
pmemchunk_fixed(pointer(poc) + fixedfirstoffset)^.size := 0;
end;
procedure append_to_oslist_var(pmc: pmemchunk_var);
var
poc: poschunk;
@ -515,8 +540,42 @@ begin
// block eligable for freeing
poc := pointer(pmc)-varfirstoffset;
remove_from_list_var(pmc);
clear_oschunk_on_freelist_fixed_flag(poc);
append_to_oslist(poc, 0);
append_to_oslist(poc);
end;
procedure modify_oschunk_freelists(poc: poschunk; new_freelists: pfreelists);
var
pmcv: pmemchunk_var;
begin
poc^.freelists := new_freelists;
{ only if oschunk contains var memchunks, we need additional assignments }
if poc^.used <> -1 then exit;
pmcv := pmemchunk_var(pointer(poc)+varfirstoffset);
repeat
pmcv^.freelists := new_freelists;
if (pmcv^.size and lastblockflag) <> 0 then
break;
pmcv := pmemchunk_var(pointer(pmcv)+(pmcv^.size and sizemask));
until false;
end;
function modify_freelists(loc_freelists, new_freelists: pfreelists): poschunk;
var
poc: poschunk;
begin
poc := loc_freelists^.oslist_all;
if assigned(poc) then
begin
repeat
{ fixed and var freelist for orphaned freelists do not need maintenance }
{ we assume the heap is not severely fragmented at thread exit }
modify_oschunk_freelists(poc, new_freelists);
if not assigned(poc^.next_any) then
exit(poc);
poc := poc^.next_any;
until false;
end;
modify_freelists := nil;
end;
{*****************************************************************************
@ -627,6 +686,47 @@ end;
Grow Heap
*****************************************************************************}
function find_free_oschunk(loc_freelists: pfreelists;
minsize, maxsize: ptrint; var size: ptrint): poschunk;
var
pmc: pmemchunk_fixed;
prev_poc, poc: poschunk;
pocsize: ptrint;
begin
poc := loc_freelists^.oslist;
prev_poc := nil;
while poc <> nil do
begin
if (poc^.size and ocrecycleflag) <> 0 then
begin
{ oops! we recycled this chunk; remove it from list }
poc^.size := poc^.size and not ocrecycleflag;
poc := poc^.next_free;
if prev_poc = nil then
loc_freelists^.oslist := poc
else
prev_poc^.next_free := poc;
continue;
end;
pocsize := poc^.size and sizemask;
if (pocsize >= minsize) and
(pocsize <= maxsize) then
begin
size := pocsize;
if prev_poc = nil then
loc_freelists^.oslist := poc^.next_free
else
prev_poc^.next_free := poc^.next_free;
dec(loc_freelists^.oscount);
remove_freed_fixed_chunks(poc);
break;
end;
prev_poc := poc;
poc := poc^.next_free;
end;
result := poc;
end;
function alloc_oschunk(loc_freelists: pfreelists; chunkindex, size: ptrint): pointer;
var
pmc,
@ -650,38 +750,35 @@ begin
else
maxsize := high(ptrint);
{ blocks available in freelist? }
poc := loc_freelists^.oslist;
prev_poc := nil;
while poc <> nil do
poc := find_free_oschunk(loc_freelists, minsize, maxsize, size);
if not assigned(poc) and (assigned(orphaned_freelists.waitfixed)
or assigned(orphaned_freelists.waitvar) or (orphaned_freelists.oscount > 0)) then
begin
if (poc^.size and ocrecycleflag) <> 0 then
begin
{ oops! we recycled this chunk; remove it from list }
poc^.size := poc^.size and not ocrecycleflag;
poc := poc^.next;
if prev_poc = nil then
loc_freelists^.oslist := poc
else
prev_poc^.next := poc;
continue;
end;
pocsize := poc^.size and sizemask;
if (pocsize >= minsize) and
(pocsize <= maxsize) then
entercriticalsection(orphaned_oslist_lock);
try_finish_waitfixedlist(@orphaned_freelists);
try_finish_waitvarlist(@orphaned_freelists);
if orphaned_freelists.oscount > 0 then
begin
size := pocsize;
if prev_poc = nil then
loc_freelists^.oslist := poc^.next
else
prev_poc^.next := poc^.next;
dec(loc_freelists^.oscount);
pmc := pmemchunk_fixed(pointer(poc)+fixedfirstoffset);
if pmc^.size <> 0 then
remove_all_from_list_fixed(pmc^.size and fixedsizemask, poc);
break;
{ blocks available in orphaned freelist ? }
poc := find_free_oschunk(@orphaned_freelists, minsize, maxsize, size);
if assigned(poc) then
begin
{ adopt this os chunk }
poc^.freelists := loc_freelists;
if assigned(poc^.prev_any) then
poc^.prev_any^.next_any := poc^.next_any
else
orphaned_freelists.oslist_all := poc^.next_any;
if assigned(poc^.next_any) then
poc^.next_any^.prev_any := poc^.prev_any;
poc^.next_any := loc_freelists^.oslist_all;
if assigned(loc_freelists^.oslist_all) then
loc_freelists^.oslist_all^.prev_any := poc;
poc^.prev_any := nil;
loc_freelists^.oslist_all := poc;
end;
end;
prev_poc := poc;
poc := poc^.next;
leavecriticalsection(orphaned_oslist_lock);
end;
if poc = nil then
begin
@ -730,10 +827,13 @@ begin
HandleError(203);
end;
end;
{ prevent thinking this os chunk is on some freelist }
clear_oschunk_on_freelist_fixed_flag(poc);
poc^.next := nil;
poc^.next_free := nil;
poc^.freelists := loc_freelists;
poc^.prev_any := nil;
poc^.next_any := loc_freelists^.oslist_all;
if assigned(loc_freelists^.oslist_all) then
loc_freelists^.oslist_all^.prev_any := poc;
loc_freelists^.oslist_all := poc;
{ set the total new heap size }
status := @loc_freelists^.internal_status;
inc(status^.currheapsize, size);
@ -741,10 +841,10 @@ begin
status^.maxheapsize := status^.currheapsize;
end;
{ initialize os-block }
poc^.used := 0;
poc^.size := size;
if chunkindex<>0 then
begin
poc^.used := 0;
{ chop os chunk in fixedsize parts,
maximum of $ffff elements are allowed, otherwise
there will be an overflow }
@ -774,6 +874,7 @@ begin
end
else
begin
poc^.used := -1;
{ we need to align the user pointers to 8 byte at least for
mmx/sse and doubles on sparc, align to 16 bytes }
result := pointer(poc)+varfirstoffset;
@ -789,9 +890,6 @@ end;
SysGetMem
*****************************************************************************}
function finish_waitfixedlist(loc_freelists: pfreelists): boolean; forward;
procedure finish_waitvarlist(loc_freelists: pfreelists); forward;
function SysGetMem_Fixed(chunksize: ptrint): pointer;
var
pmc, pmc_next: pmemchunk_fixed;
@ -814,7 +912,7 @@ begin
dec(loc_freelists^.oscount);
end;
end
else if finish_waitfixedlist(loc_freelists) then
else if try_finish_waitfixedlist(loc_freelists) then
{ freed some to-be freed chunks, retry allocation }
exit(SysGetMem_Fixed(chunksize))
else
@ -856,7 +954,7 @@ begin
result:=nil;
{ free pending items }
loc_freelists := @freelists;
finish_waitvarlist(loc_freelists);
try_finish_waitvarlist(loc_freelists);
pbest := nil;
pcurr := loc_freelists^.varlist;
iter := high(longint);
@ -893,7 +991,6 @@ begin
size := split_block(pcurr, size);
{ flag block as used }
pcurr^.size := pcurr^.size or usedflag;
pcurr^.freelists := loc_freelists;
{ statistics }
with loc_freelists^.internal_status do
begin
@ -999,10 +1096,10 @@ begin
if poc^.used <= 0 then
begin
{ decrease used blocks count }
if poc^.used=-1 then
if poc^.used<0 then
HandleError(204);
{ osblock can be freed? }
append_to_oslist(poc, chunksize);
append_to_oslist(poc);
end;
result := chunksize;
end;
@ -1064,14 +1161,11 @@ begin
result := sysfreemem_fixed(pmc);
end;
function finish_waitfixedlist(loc_freelists: pfreelists): boolean;
procedure finish_waitfixedlist(loc_freelists: pfreelists);
{ free to-be-freed chunks, return whether we freed anything }
var
pmc: pmemchunk_fixed;
begin
if loc_freelists^.waitfixed = nil then
exit(false);
entercriticalsection(loc_freelists^.lockfixed);
while loc_freelists^.waitfixed <> nil do
begin
{ keep next_fixed, might be destroyed }
@ -1079,6 +1173,14 @@ begin
loc_freelists^.waitfixed := pmc^.next_fixed;
SysFreeMem_Fixed(pmc);
end;
end;
function try_finish_waitfixedlist(loc_freelists: pfreelists): boolean;
begin
if loc_freelists^.waitfixed = nil then
exit(false);
entercriticalsection(loc_freelists^.lockfixed);
finish_waitfixedlist(loc_freelists);
leavecriticalsection(loc_freelists^.lockfixed);
result := true;
end;
@ -1088,10 +1190,6 @@ procedure finish_waitvarlist(loc_freelists: pfreelists);
var
pmcv: pmemchunk_var;
begin
loc_freelists := @freelists;
if loc_freelists^.waitvar = nil then
exit;
entercriticalsection(loc_freelists^.lockvar);
while loc_freelists^.waitvar <> nil do
begin
{ keep next_var, might be destroyed }
@ -1099,6 +1197,14 @@ begin
loc_freelists^.waitvar := pmcv^.next_var;
SysFreeMem_Var(pmcv);
end;
end;
procedure try_finish_waitvarlist(loc_freelists: pfreelists);
begin
if loc_freelists^.waitvar = nil then
exit;
entercriticalsection(loc_freelists^.lockvar);
finish_waitvarlist(loc_freelists);
leavecriticalsection(loc_freelists^.lockvar);
end;
@ -1344,6 +1450,7 @@ begin
not loaded yet }
loc_freelists := @freelists;
fillchar(loc_freelists^,sizeof(tfreelists),0);
fillchar(orphaned_freelists,sizeof(orphaned_freelists),0);
{ main freelist will be copied in memory }
main_orig_freelists := loc_freelists;
end;
@ -1358,21 +1465,64 @@ begin
main_relo_freelists := loc_freelists;
initcriticalsection(loc_freelists^.lockfixed);
initcriticalsection(loc_freelists^.lockvar);
initcriticalsection(orphaned_freelists.lockfixed);
initcriticalsection(orphaned_freelists.lockvar);
initcriticalsection(orphaned_oslist_lock);
modify_freelists(loc_freelists, main_relo_freelists);
if MemoryManager.RelocateHeap <> nil then
MemoryManager.RelocateHeap();
end;
procedure FinalizeHeap;
var
poc : poschunk;
poc, poc_next: poschunk;
i : longint;
loc_freelists: pfreelists;
begin
loc_freelists := @freelists;
finish_waitfixedlist(loc_freelists);
finish_waitvarlist(loc_freelists);
if main_relo_freelists <> nil then
begin
entercriticalsection(loc_freelists^.lockfixed);
finish_waitfixedlist(loc_freelists);
entercriticalsection(loc_freelists^.lockvar);
finish_waitvarlist(loc_freelists);
{$ifdef HAS_SYSOSFREE}
end;
poc := loc_freelists^.oslist;
while assigned(poc) do
begin
poc_next := poc^.next_free;
{ check if this os chunk was 'recycled' i.e. taken in use again }
if (poc^.size and ocrecycleflag) = 0 then
free_oschunk(loc_freelists, poc);
poc := poc_next;
end;
loc_freelists^.oslist := nil;
loc_freelists^.oscount := 0;
if main_relo_freelists <> nil then
begin
{$endif HAS_SYSOSFREE}
if main_relo_freelists = loc_freelists then
begin
donecriticalsection(orphaned_freelists.lockfixed);
donecriticalsection(orphaned_freelists.lockvar);
donecriticalsection(orphaned_oslist_lock);
end else begin
entercriticalsection(orphaned_oslist_lock);
entercriticalsection(orphaned_freelists.lockfixed);
entercriticalsection(orphaned_freelists.lockvar);
poc := modify_freelists(loc_freelists, @orphaned_freelists);
if assigned(poc) then
begin
poc^.next_any := orphaned_freelists.oslist_all;
if assigned(orphaned_freelists.oslist_all) then
orphaned_freelists.oslist_all^.prev_any := poc;
orphaned_freelists.oslist_all := loc_freelists^.oslist_all;
end;
leavecriticalsection(orphaned_freelists.lockvar);
leavecriticalsection(orphaned_freelists.lockfixed);
leavecriticalsection(orphaned_oslist_lock);
end;
donecriticalsection(loc_freelists^.lockfixed);
donecriticalsection(loc_freelists^.lockvar);
end;
@ -1388,15 +1538,6 @@ begin
writeln('size >', sizeusagesize, ' usage ', maxsizeusage[sizeusageindex]);
flush(output);
{$endif}
{$ifdef HAS_SYSOSFREE}
while assigned(loc_freelists^.oslist) do
begin
poc:=loc_freelists^.oslist^.next;
SysOSFree(loc_freelists^.oslist, loc_freelists^.oslist^.size and sizemask);
dec(loc_freelists^.oscount);
loc_freelists^.oslist:=poc;
end;
{$endif HAS_SYSOSFREE}
end;
{$endif HAS_MEMORYMANAGER}

406
rtl/inc/heaptrc.pp
View File

@ -21,6 +21,7 @@ interface
{$checkpointer off}
{$goto on}
{$typedpointer on}
{$if defined(win32) or defined(wince)}
{$define windows}
@ -105,6 +106,7 @@ type
end;
end;
ppheap_mem_info = ^pheap_mem_info;
pheap_mem_info = ^theap_mem_info;
pheap_todo = ^theap_todo;
@ -136,6 +138,24 @@ type
extra_info : pheap_extra_info;
end;
pheap_info = ^theap_info;
theap_info = record
{$ifdef EXTRA}
heap_valid_first,
heap_valid_last : pheap_mem_info;
{$endif EXTRA}
heap_mem_root : pheap_mem_info;
heap_free_todo : theap_todo;
getmem_cnt,
freemem_cnt : ptrint;
getmem_size,
freemem_size : ptrint;
getmem8_size,
freemem8_size : ptrint;
error_in_heap : boolean;
inside_trace_getmem : boolean;
end;
var
useownfile : boolean;
ownfile : text;
@ -144,22 +164,9 @@ var
{$endif EXTRA}
main_orig_todolist: pheap_todo;
main_relo_todolist: pheap_todo;
orphaned_info: theap_info;
threadvar
{$ifdef EXTRA}
heap_valid_first,
heap_valid_last : pheap_mem_info;
{$endif EXTRA}
heap_mem_root : pheap_mem_info;
heap_free_todo : theap_todo;
getmem_cnt,
freemem_cnt : ptrint;
getmem_size,
freemem_size : ptrint;
getmem8_size,
freemem8_size : ptrint;
error_in_heap : boolean;
inside_trace_getmem : boolean;
heap_info: theap_info;
{*****************************************************************************
Crc 32
@ -249,6 +256,8 @@ end;
Helpers
*****************************************************************************}
function InternalFreeMemSize(loc_info: pheap_info; p: pointer; pp: pheap_mem_info;
size: ptrint; release_orphaned_lock: boolean): ptrint; forward;
function TraceFreeMem(p: pointer): ptrint; forward;
procedure call_stack(pp : pheap_mem_info;var ptext : text);
@ -331,13 +340,13 @@ begin
call_stack(p,ptext);
end;
function is_in_getmem_list (p : pheap_mem_info) : boolean;
function is_in_getmem_list (loc_info: pheap_info; p : pheap_mem_info) : boolean;
var
i : ptrint;
pp : pheap_mem_info;
begin
is_in_getmem_list:=false;
pp:=heap_mem_root;
pp:=loc_info^.heap_mem_root;
i:=0;
while pp<>nil do
begin
@ -355,7 +364,7 @@ begin
is_in_getmem_list:=true;
pp:=pp^.previous;
inc(i);
if i>getmem_cnt-freemem_cnt then
if i>loc_info^.getmem_cnt-loc_info^.freemem_cnt then
if useownfile then
writeln(ownfile,'error in linked list of heap_mem_info')
else
@ -363,21 +372,31 @@ begin
end;
end;
procedure finish_heap_free_todo_list;
procedure finish_heap_free_todo_list(loc_info: pheap_info);
var
bp: pointer;
loc_list: pheap_todo;
pp: pheap_mem_info;
list: ppheap_mem_info;
begin
loc_list := @heap_free_todo;
if loc_list^.list <> nil then
list := @loc_info^.heap_free_todo.list;
repeat
pp := list^;
list^ := list^^.todonext;
bp := pointer(pp)+sizeof(theap_mem_info);
InternalFreeMemSize(loc_info,bp,pp,pp^.size,false);
//TraceFreeMem(bp);
until list^ = nil;
end;
procedure try_finish_heap_free_todo_list(loc_info: pheap_info);
var
bp: pointer;
begin
if loc_info^.heap_free_todo.list <> nil then
begin
entercriticalsection(loc_list^.lock);
repeat
bp := pointer(loc_list^.list)+sizeof(theap_mem_info);
loc_list^.list := loc_list^.list^.todonext;
TraceFreeMem(bp);
until loc_list^.list = nil;
leavecriticalsection(loc_list^.lock);
entercriticalsection(loc_info^.heap_free_todo.lock);
finish_heap_free_todo_list(loc_info);
leavecriticalsection(loc_info^.heap_free_todo.lock);
end;
end;
@ -394,10 +413,12 @@ var
pl : pdword;
p : pointer;
pp : pheap_mem_info;
loc_info: pheap_info;
begin
finish_heap_free_todo_list;
inc(getmem_size,size);
inc(getmem8_size,((size+7) div 8)*8);
loc_info := @heap_info;
try_finish_heap_free_todo_list(loc_info);
inc(loc_info^.getmem_size,size);
inc(loc_info^.getmem8_size,((size+7) div 8)*8);
{ Do the real GetMem, but alloc also for the info block }
{$ifdef cpuarm}
allocsize:=(size + 3) and not 3+sizeof(theap_mem_info)+extra_info_size;
@ -418,7 +439,7 @@ begin
inc(p,sizeof(theap_mem_info));
{ Create the info block }
pp^.sig:=$DEADBEEF;
pp^.todolist:=@heap_free_todo;
pp^.todolist:=@loc_info^.heap_free_todo;
pp^.todonext:=nil;
pp^.size:=size;
pp^.extra_info_size:=extra_info_size;
@ -437,9 +458,9 @@ begin
pp^.extra_info^.displayproc:=display_extra_info_proc;
if assigned(fill_extra_info_proc) then
begin
inside_trace_getmem:=true;
loc_info^.inside_trace_getmem:=true;
fill_extra_info_proc(@pp^.extra_info^.data);
inside_trace_getmem:=false;
loc_info^.inside_trace_getmem:=false;
end;
end
else
@ -466,21 +487,21 @@ begin
bp:=nil;
end;
{ insert in the linked list }
if heap_mem_root<>nil then
heap_mem_root^.next:=pp;
pp^.previous:=heap_mem_root;
if loc_info^.heap_mem_root<>nil then
loc_info^.heap_mem_root^.next:=pp;
pp^.previous:=loc_info^.heap_mem_root;
pp^.next:=nil;
{$ifdef EXTRA}
pp^.prev_valid:=heap_valid_last;
heap_valid_last:=pp;
if not assigned(heap_valid_first) then
heap_valid_first:=pp;
pp^.prev_valid:=loc_info^.heap_valid_last;
loc_info^.heap_valid_last:=pp;
if not assigned(loc_info^.heap_valid_first) then
loc_info^.heap_valid_first:=pp;
{$endif EXTRA}
heap_mem_root:=pp;
loc_info^.heap_mem_root:=pp;
{ must be changed before fill_extra_info is called
because checkpointer can be called from within
fill_extra_info PM }
inc(getmem_cnt);
inc(loc_info^.getmem_cnt);
{ update the signature }
if usecrc then
pp^.sig:=calculate_sig(pp);
@ -492,60 +513,37 @@ end;
TraceFreeMem
*****************************************************************************}
function TraceFreeMemSize(p:pointer;size:ptrint):ptrint;
function CheckFreeMemSize(loc_info: pheap_info; pp: pheap_mem_info;
size, ppsize: ptrint): boolean; inline;
var
i,ppsize : ptrint;
i: ptrint;
bp : pointer;
pp : pheap_mem_info;
ptext : ^text;
{$ifdef EXTRA}
pp2 : pheap_mem_info;
{$endif}
extra_size : ptrint;
ptext : ^text;
begin
if p=nil then
begin
TraceFreeMemSize:=0;
exit;
end;
pp:=pheap_mem_info(p-sizeof(theap_mem_info));
if @heap_free_todo <> pp^.todolist then
begin
if pp^.todolist = main_orig_todolist then
pp^.todolist := main_relo_todolist;
if @heap_free_todo <> pp^.todolist then
begin
entercriticalsection(pp^.todolist^.lock);
pp^.todonext := pp^.todolist^.list;
pp^.todolist^.list := pp;
leavecriticalsection(pp^.todolist^.lock);
exit(pp^.size);
end;
end;
if useownfile then
ptext:=@ownfile
else
ptext:=@stderr;
inc(freemem_size,size);
inc(freemem8_size,((size+7) div 8)*8);
ppsize:= size + sizeof(theap_mem_info)+pp^.extra_info_size;
if add_tail then
inc(ppsize,sizeof(ptrint));
inc(loc_info^.freemem_size,size);
inc(loc_info^.freemem8_size,((size+7) div 8)*8);
if not quicktrace then
begin
if not(is_in_getmem_list(pp)) then
if not(is_in_getmem_list(loc_info, pp)) then
RunError(204);
end;
if (pp^.sig=$AAAAAAAA) and not usecrc then
begin
error_in_heap:=true;
loc_info^.error_in_heap:=true;
dump_already_free(pp,ptext^);
if haltonerror then halt(1);
end
else if ((pp^.sig<>$DEADBEEF) or usecrc) and
((pp^.sig<>calculate_sig(pp)) or not usecrc) then
begin
error_in_heap:=true;
loc_info^.error_in_heap:=true;
dump_error(pp,ptext^);
{$ifdef EXTRA}
dump_error(pp,error_file);
@ -556,7 +554,7 @@ begin
end
else if pp^.size<>size then
begin
error_in_heap:=true;
loc_info^.error_in_heap:=true;
dump_wrong_size(pp,size,ptext^);
{$ifdef EXTRA}
dump_wrong_size(pp,size,error_file);
@ -565,8 +563,6 @@ begin
{ don't release anything in this case !! }
exit;
end;
{ save old values }
extra_size:=pp^.extra_info_size;
{ now it is released !! }
pp^.sig:=$AAAAAAAA;
if not keepreleased then
@ -575,8 +571,8 @@ begin
pp^.next^.previous:=pp^.previous;
if pp^.previous<>nil then
pp^.previous^.next:=pp^.next;
if pp=heap_mem_root then
heap_mem_root:=heap_mem_root^.previous;
if pp=loc_info^.heap_mem_root then
loc_info^.heap_mem_root:=loc_info^.heap_mem_root^.previous;
end
else
begin
@ -587,48 +583,102 @@ begin
bp:=get_caller_frame(bp);
end;
end;
inc(freemem_cnt);
{ clear the memory }
fillchar(p^,size,#240); { $F0 will lead to GFP if used as pointer ! }
inc(loc_info^.freemem_cnt);
{ clear the memory, $F0 will lead to GFP if used as pointer ! }
fillchar((pointer(pp)+sizeof(theap_mem_info))^,size,#240);
{ this way we keep all info about all released memory !! }
if keepreleased then
begin
{$ifdef EXTRA}
{ We want to check if the memory was changed after release !! }
pp^.release_sig:=calculate_release_sig(pp);
if pp=heap_valid_last then
if pp=loc_info^.heap_valid_last then
begin
heap_valid_last:=pp^.prev_valid;
if pp=heap_valid_first then
heap_valid_first:=nil;
TraceFreememsize:=size;
exit;
loc_info^.heap_valid_last:=pp^.prev_valid;
if pp=loc_info^.heap_valid_first then
loc_info^.heap_valid_first:=nil;
exit(false);
end;
pp2:=heap_valid_last;
pp2:=loc_info^.heap_valid_last;
while assigned(pp2) do
begin
if pp2^.prev_valid=pp then
begin
pp2^.prev_valid:=pp^.prev_valid;
if pp=heap_valid_first then
heap_valid_first:=pp2;
TraceFreememsize:=size;
exit;
if pp=loc_info^.heap_valid_first then
loc_info^.heap_valid_first:=pp2;
exit(false);
end
else
pp2:=pp2^.prev_valid;
end;
{$endif EXTRA}
TraceFreememsize:=size;
exit;
exit(false);
end;
{ release the normal memory at least }
i:=SysFreeMemSize(pp,ppsize);
{ return the correct size }
dec(i,sizeof(theap_mem_info)+extra_size);
if add_tail then
dec(i,sizeof(ptrint));
TraceFreeMemSize:=i;
CheckFreeMemSize:=true;
end;
function InternalFreeMemSize(loc_info: pheap_info; p: pointer; pp: pheap_mem_info;
size: ptrint; release_orphaned_lock: boolean): ptrint;
var
i,ppsize : ptrint;
bp : pointer;
extra_size: ptrint;
release_mem: boolean;
begin
{ save old values }
extra_size:=pp^.extra_info_size;
ppsize:= size+sizeof(theap_mem_info)+pp^.extra_info_size;
if add_tail then
inc(ppsize,sizeof(ptrint));
{ do various checking }
release_mem := CheckFreeMemSize(loc_info, pp, size, ppsize);
if release_orphaned_lock then
leavecriticalsection(orphaned_info.heap_free_todo.lock);
if release_mem then
begin
{ release the normal memory at least }
i:=SysFreeMemSize(pp,ppsize);
{ return the correct size }
dec(i,sizeof(theap_mem_info)+extra_size);
if add_tail then
dec(i,sizeof(ptrint));
InternalFreeMemSize:=i;
end else
InternalFreeMemSize:=size;
end;
function TraceFreeMemSize(p:pointer;size:ptrint):ptrint;
var
loc_info: pheap_info;
pp: pheap_mem_info;
begin
if p=nil then
begin
TraceFreeMemSize:=0;
exit;
end;
loc_info:=@heap_info;
pp:=pheap_mem_info(p-sizeof(theap_mem_info));
if @loc_info^.heap_free_todo <> pp^.todolist then
begin
if pp^.todolist = main_orig_todolist then
pp^.todolist := main_relo_todolist;
entercriticalsection(pp^.todolist^.lock);
if pp^.todolist = @orphaned_info.heap_free_todo then
begin
loc_info := @orphaned_info;
end else
if pp^.todolist <> @loc_info^.heap_free_todo then
begin
{ allocated in different heap, push to that todolist }
pp^.todonext := pp^.todolist^.list;
pp^.todolist^.list := pp;
leavecriticalsection(pp^.todolist^.lock);
exit(pp^.size);
end;
end;
TraceFreeMemSize:=InternalFreeMemSize(loc_info,p,pp,size,loc_info = @orphaned_info);
end;
@ -691,6 +741,7 @@ var
oldexactsize : ptrint;
old_fill_extra_info_proc : tfillextrainfoproc;
old_display_extra_info_proc : tdisplayextrainfoproc;
loc_info: pheap_info;
begin
{ Free block? }
if size=0 then
@ -709,12 +760,13 @@ begin
exit;
end;
{ Resize block }
loc_info:=@heap_info;
pp:=pheap_mem_info(p-sizeof(theap_mem_info));
{ test block }
if ((pp^.sig<>$DEADBEEF) or usecrc) and
((pp^.sig<>calculate_sig(pp)) or not usecrc) then
begin
error_in_heap:=true;
loc_info^.error_in_heap:=true;
if useownfile then
dump_error(pp,ownfile)
else
@ -795,10 +847,10 @@ begin
end;
{ adjust like a freemem and then a getmem, so you get correct
results in the summary display }
inc(freemem_size,oldsize);
inc(freemem8_size,((oldsize+7) div 8)*8);
inc(getmem_size,size);
inc(getmem8_size,((size+7) div 8)*8);
inc(loc_info^.freemem_size,oldsize);
inc(loc_info^.freemem8_size,((oldsize+7) div 8)*8);
inc(loc_info^.getmem_size,size);
inc(loc_info^.getmem8_size,((size+7) div 8)*8);
{ generate new backtrace }
bp:=get_caller_frame(get_frame);
for i:=1 to tracesize do
@ -862,6 +914,7 @@ procedure CheckPointer(p : pointer); [public, alias : 'FPC_CHECKPOINTER'];
var
i : ptrint;
pp : pheap_mem_info;
loc_info: pheap_info;
{$ifdef go32v2}
get_ebp,stack_top : longword;
data_end : longword;
@ -877,7 +930,7 @@ begin
runerror(204);
i:=0;
loc_info:=@heap_info;
if useownfile then
ptext:=@ownfile
else
@ -953,7 +1006,7 @@ begin
{ first try valid list faster }
{$ifdef EXTRA}
pp:=heap_valid_last;
pp:=loc_info^.heap_valid_last;
while pp<>nil do
begin
{ inside this valid block ! }
@ -965,8 +1018,8 @@ begin
if ((pp^.sig=$DEADBEEF) and not usecrc) or
((pp^.sig=calculate_sig(pp)) and usecrc) or
{ special case of the fill_extra_info call }
((pp=heap_valid_last) and usecrc and (pp^.sig=$DEADBEEF)
and inside_trace_getmem) then
((pp=loc_info^.heap_valid_last) and usecrc and (pp^.sig=$DEADBEEF)
and loc_info^.inside_trace_getmem) then
goto _exit
else
begin
@ -978,7 +1031,7 @@ begin
else
pp:=pp^.prev_valid;
inc(i);
if i>getmem_cnt-freemem_cnt then
if i>loc_info^.getmem_cnt-loc_info^.freemem_cnt then
begin
writeln(ptext^,'error in linked list of heap_mem_info');
halt(1);
@ -986,7 +1039,7 @@ begin
end;
i:=0;
{$endif EXTRA}
pp:=heap_mem_root;
pp:=loc_info^.heap_mem_root;
while pp<>nil do
begin
{ inside this block ! }
@ -1004,7 +1057,7 @@ begin
end;
pp:=pp^.previous;
inc(i);
if i>getmem_cnt then
if i>loc_info^.getmem_cnt then
begin
writeln(ptext^,'error in linked list of heap_mem_info');
halt(1);
@ -1027,16 +1080,21 @@ var
ExpectedHeapFree : ptrint;
status : TFPCHeapStatus;
ptext : ^text;
loc_info: pheap_info;
begin
loc_info:=@heap_info;
if useownfile then
ptext:=@ownfile
else
ptext:=@stderr;
pp:=heap_mem_root;
pp:=loc_info^.heap_mem_root;
Writeln(ptext^,'Heap dump by heaptrc unit');
Writeln(ptext^,getmem_cnt, ' memory blocks allocated : ',getmem_size,'/',getmem8_size);
Writeln(ptext^,freemem_cnt,' memory blocks freed : ',freemem_size,'/',freemem8_size);
Writeln(ptext^,getmem_cnt-freemem_cnt,' unfreed memory blocks : ',getmem_size-freemem_size);
Writeln(ptext^,loc_info^.getmem_cnt, ' memory blocks allocated : ',
loc_info^.getmem_size,'/',loc_info^.getmem8_size);
Writeln(ptext^,loc_info^.freemem_cnt,' memory blocks freed : ',
loc_info^.freemem_size,'/',loc_info^.freemem8_size);
Writeln(ptext^,loc_info^.getmem_cnt-loc_info^.freemem_cnt,
' unfreed memory blocks : ',loc_info^.getmem_size-loc_info^.freemem_size);
status:=SysGetFPCHeapStatus;
Write(ptext^,'True heap size : ',status.CurrHeapSize);
if EntryMemUsed > 0 then
@ -1044,11 +1102,13 @@ begin
else
Writeln(ptext^);
Writeln(ptext^,'True free heap : ',status.CurrHeapFree);
ExpectedHeapFree:=status.CurrHeapSize-(getmem8_size-freemem8_size)-
(getmem_cnt-freemem_cnt)*(sizeof(theap_mem_info)+extra_info_size)-EntryMemUsed;
ExpectedHeapFree:=status.CurrHeapSize
-(loc_info^.getmem8_size-loc_info^.freemem8_size)
-(loc_info^.getmem_cnt-loc_info^.freemem_cnt)*(sizeof(theap_mem_info)+extra_info_size)
-EntryMemUsed;
If ExpectedHeapFree<>status.CurrHeapFree then
Writeln(ptext^,'Should be : ',ExpectedHeapFree);
i:=getmem_cnt-freemem_cnt;
i:=loc_info^.getmem_cnt-loc_info^.freemem_cnt;
while pp<>nil do
begin
if i<0 then
@ -1071,20 +1131,20 @@ begin
{$ifdef EXTRA}
dump_error(pp,error_file);
{$endif EXTRA}
error_in_heap:=true;
loc_info^.error_in_heap:=true;
end
{$ifdef EXTRA}
else if pp^.release_sig<>calculate_release_sig(pp) then
begin
dump_change_after(pp,ptext^);
dump_change_after(pp,error_file);
error_in_heap:=true;
loc_info^.error_in_heap:=true;
end
{$endif EXTRA}
;
pp:=pp^.previous;
end;
if HaltOnNotReleased and (getmem_cnt<>freemem_cnt) then
if HaltOnNotReleased and (loc_info^.getmem_cnt<>loc_info^.freemem_cnt) then
exitcode:=203;
end;
@ -1104,38 +1164,93 @@ end;
*****************************************************************************}
procedure TraceInitThread;
var
loc_info: pheap_info;
begin
loc_info := @heap_info;
{$ifdef EXTRA}
heap_valid_first := nil;
heap_valid_last := nil;
loc_info^.heap_valid_first := nil;
loc_info^.heap_valid_last := nil;
{$endif}
heap_mem_root := nil;
getmem_cnt := 0;
freemem_cnt := 0;
getmem_size := 0;
freemem_size := 0;
getmem8_size := 0;
freemem8_size := 0;
error_in_heap := false;
inside_trace_getmem := false;
loc_info^.heap_mem_root := nil;
loc_info^.getmem_cnt := 0;
loc_info^.freemem_cnt := 0;
loc_info^.getmem_size := 0;
loc_info^.freemem_size := 0;
loc_info^.getmem8_size := 0;
loc_info^.freemem8_size := 0;
loc_info^.error_in_heap := false;
loc_info^.inside_trace_getmem := false;
EntryMemUsed := SysGetFPCHeapStatus.CurrHeapUsed;
if main_relo_todolist <> nil then
initcriticalsection(heap_free_todo.lock);
initcriticalsection(loc_info^.heap_free_todo.lock);
end;
procedure TraceRelocateHeap;
begin
main_relo_todolist := @heap_free_todo;
main_relo_todolist := @heap_info.heap_free_todo;
initcriticalsection(main_relo_todolist^.lock);
initcriticalsection(orphaned_info.heap_free_todo.lock);
end;
procedure move_heap_info(src_info, dst_info: pheap_info);
var
heap_mem: pheap_mem_info;
begin
if src_info^.heap_free_todo.list <> nil then
finish_heap_free_todo_list(src_info);
if dst_info^.heap_free_todo.list <> nil then
finish_heap_free_todo_list(dst_info);
heap_mem := src_info^.heap_mem_root;
if heap_mem <> nil then
begin
repeat
heap_mem^.todolist := @dst_info^.heap_free_todo;
if heap_mem^.previous = nil then break;
heap_mem := heap_mem^.previous;
until false;
heap_mem^.previous := dst_info^.heap_mem_root;
if dst_info^.heap_mem_root <> nil then
dst_info^.heap_mem_root^.next := heap_mem;
dst_info^.heap_mem_root := src_info^.heap_mem_root;
end;
inc(dst_info^.getmem_cnt, src_info^.getmem_cnt);
inc(dst_info^.getmem_size, src_info^.getmem_size);
inc(dst_info^.getmem8_size, src_info^.getmem8_size);
inc(dst_info^.freemem_cnt, src_info^.freemem_cnt);
inc(dst_info^.freemem_size, src_info^.freemem_size);
inc(dst_info^.freemem8_size, src_info^.freemem8_size);
dst_info^.error_in_heap := dst_info^.error_in_heap or src_info^.error_in_heap;
{$ifdef EXTRA}
if assigned(dst_info^.heap_valid_first) then
dst_info^.heap_valid_first^.prev_valid := src_info^.heap_valid_last
else
dst_info^.heap_valid_last := src_info^.heap_valid_last;
dst_info^.heap_valid_first := src_info^.heap_valid_first;
{$endif}
end;
procedure TraceExitThread;
var
loc_info: pheap_info;
heap_mem: pheap_mem_info;
begin
finish_heap_free_todo_list;
if main_relo_todolist <> nil then
donecriticalsection(heap_free_todo.lock);
if not error_in_heap then
loc_info := @heap_info;
entercriticalsection(loc_info^.heap_free_todo.lock);
entercriticalsection(orphaned_info.heap_free_todo.lock);
{ if not main thread exiting, move bookkeeping to orphaned heap }
if (@loc_info^.heap_free_todo <> main_orig_todolist)
and (@loc_info^.heap_free_todo <> main_relo_todolist) then
begin
move_heap_info(loc_info, @orphaned_info);
end else
if not loc_info^.error_in_heap then
begin
move_heap_info(@orphaned_info, loc_info);
Dumpheap;
end;
leavecriticalsection(orphaned_info.heap_free_todo.lock);
donecriticalsection(loc_info^.heap_free_todo.lock);
end;
function TraceGetHeapStatus:THeapStatus;
@ -1207,7 +1322,7 @@ const
procedure TraceInit;
begin
MakeCRC32Tbl;
main_orig_todolist := @heap_free_todo;
main_orig_todolist := @heap_info.heap_free_todo;
main_relo_todolist := nil;
TraceInitThread;
SetMemoryManager(TraceManager);
@ -1246,8 +1361,9 @@ begin
exit;
end;
TraceExitThread;
if error_in_heap and (exitcode=0) then
if heap_info.error_in_heap and (exitcode=0) then
exitcode:=203;
donecriticalsection(orphaned_info.heap_free_todo.lock);
{$ifdef EXTRA}
Close(error_file);
{$endif EXTRA}