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

+ patch from Benito van der Zander to enable heaptrc to dump leaked or faulty memory blocks (function disabled by default), resolves #19691

Browse Source 
git-svn-id: trunk@18231 -
This commit is contained in:
florian 2011-08-16 20:47:15 +00:00
parent 8bc94610c7
commit 0cc53cc5df
1 changed files with 44 additions and 0 deletions
Show Stats Download Patch File Download Diff File Expand all files Collapse all files

44
rtl/inc/heaptrc.pp
View File

@ -80,6 +80,9 @@ const
this allows to test for writing into that part }
usecrc : boolean = true;
printleakedblock: boolean = false;
printfaultyblock: boolean = false;
maxprintedblocklength: integer = 128;
implementation
@ -255,14 +258,50 @@ function InternalFreeMemSize(loc_info: pheap_info; p: pointer; pp: pheap_mem_inf
size: ptruint; release_todo_lock: boolean): ptruint; forward;
function TraceFreeMem(p: pointer): ptruint; forward;
procedure printhex(p : pointer; const size : PtrUInt; var ptext : text);
var s: PtrUInt;
i: Integer;
begin
s := size;
if s > maxprintedblocklength then
s := maxprintedblocklength;
for i:=0 to s-1 do
write(ptext, hexstr(pbyte(p + i)^,2));
if size > maxprintedblocklength then
writeln(ptext,'.. - ')
else
writeln(ptext, ' - ');
for i:=0 to s-1 do
if pchar(p + sizeof(theap_mem_info) + i)^ < ' ' then
write(ptext, ' ')
else
write(ptext, pchar(p + i)^);
if size > maxprintedblocklength then
writeln(ptext,'..')
else
writeln(ptext);
end;
procedure call_stack(pp : pheap_mem_info;var ptext : text);
var
i : ptruint;
s: PtrUInt;
begin
writeln(ptext,'Call trace for block $',hexstr(pointer(pp)+sizeof(theap_mem_info)),' size ',pp^.size);
if printleakedblock then
begin
write(ptext, 'Block content: ');
printhex(pointer(pp) + sizeof(theap_mem_info), pp^.size, ptext);
end;
for i:=1 to tracesize do
if pp^.calls[i]<>nil then
writeln(ptext,BackTraceStrFunc(pp^.calls[i]));
{ the check is done to be sure that the procvar is not overwritten }
if assigned(pp^.extra_info) and
(pp^.extra_info^.check=$12345678) and
@ -303,6 +342,11 @@ procedure dump_error(p : pheap_mem_info;var ptext : text);
begin
Writeln(ptext,'Marked memory at $',HexStr(pointer(p)+sizeof(theap_mem_info)),' invalid');
Writeln(ptext,'Wrong signature $',hexstr(p^.sig,8),' instead of ',hexstr(calculate_sig(p),8));
if printfaultyblock then
begin
write(ptext, 'Block content: ');
printhex(pointer(p) + sizeof(theap_mem_info), p^.size, ptext);
end;
dump_stack(ptext,get_caller_frame(get_frame));
end;