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

* Fix for 28578

Browse Source 
git-svn-id: trunk@31434 -
This commit is contained in:
michael 2015-08-28 08:06:36 +00:00
parent 621c9c357c
commit 1fd2735198
1 changed files with 13 additions and 0 deletions
Show Stats Download Patch File Download Diff File Expand all files Collapse all files

13
rtl/inc/heaptrc.pp
View File

@ -30,6 +30,7 @@ interface
{$endif}
Procedure DumpHeap;
Procedure DumpHeap(SkipIfNoLeaks : Boolean);
{ define EXTRA to add more
tests :
@ -85,6 +86,8 @@ const
printleakedblock: boolean = false;
printfaultyblock: boolean = false;
maxprintedblocklength: integer = 128;
GlobalSkipIfNoLeaks : Boolean = False;
implementation
@ -1106,6 +1109,12 @@ end;
*****************************************************************************}
procedure dumpheap;
begin
DumpHeap(GlobalSkipIfNoLeaks);
end;
procedure dumpheap(SkipIfNoLeaks : Boolean);
var
pp : pheap_mem_info;
i : ptrint;
@ -1120,6 +1129,8 @@ begin
else
ptext:=textoutput;
pp:=loc_info^.heap_mem_root;
if ((loc_info^.getmem_size-loc_info^.freemem_size)=0) and SkipIfNoLeaks then
exit;
Writeln(ptext^,'Heap dump by heaptrc unit');
Writeln(ptext^,loc_info^.getmem_cnt, ' memory blocks allocated : ',
loc_info^.getmem_size,'/',loc_info^.getmem8_size);
@ -1517,6 +1528,8 @@ begin
haltonerror:=false;
if pos('haltonnotreleased',s)>0 then
HaltOnNotReleased :=true;
if pos('skipifnoleaks',s)>0 then
GlobalSkipIfNoLeaks :=true;
i:=pos('log=',s);
if i>0 then
begin