From 0cc53cc5dfdb768981953ee4ebef543608aa0c4b Mon Sep 17 00:00:00 2001
From: florian <florian@freepascal.org>
Date: Tue, 16 Aug 2011 20:47:15 +0000
Subject: [PATCH] + patch from Benito van der Zander to enable heaptrc to dump
leaked or faulty memory blocks (function disabled by default), resolves
#19691
git-svn-id: trunk@18231 -
---
rtl/inc/heaptrc.pp | 44 ++++++++++++++++++++++++++++++++++++++++++++
1 file changed, 44 insertions(+)
diff --git a/rtl/inc/heaptrc.pp b/rtl/inc/heaptrc.pp
index b84aec1ae6..12168d13d8 100644
--- a/rtl/inc/heaptrc.pp
+++ b/rtl/inc/heaptrc.pp
@@ -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;