paweld/fpc
1
0
Fork 0
mirror of https://gitlab.com/freepascal.org/fpc/source.git synced 2025-08-21 21:50:07 +02:00
Code Issues Packages Projects Releases Wiki Activity

* patch by Cyrax for easy redirection of heaptrc output, resolves #22168

Browse Source 
git-svn-id: trunk@22922 -
This commit is contained in:
florian 2012-11-04 14:07:57 +00:00
parent 0b30b0fd5a
commit ddc054be79
1 changed files with 27 additions and 12 deletions
Show Stats Download Patch File Download Diff File Expand all files Collapse all files

39
rtl/inc/heaptrc.pp
View File

@ -47,7 +47,8 @@ type
procedure SetHeapExtraInfo(size : ptruint;fillproc : tfillextrainfoproc;displayproc : tdisplayextrainfoproc); procedure SetHeapExtraInfo(size : ptruint;fillproc : tfillextrainfoproc;displayproc : tdisplayextrainfoproc);
{ Redirection of the output to a file } { Redirection of the output to a file }
procedure SetHeapTraceOutput(const name : string); procedure SetHeapTraceOutput(const name : string);overload;
procedure SetHeapTraceOutput(var ATextOutput : Text);overload;
const const
{ tracing level { tracing level
@ -154,7 +155,7 @@ type
end; end;
var var
useownfile : boolean; useownfile, useowntextoutput : boolean;
ownfile : text; ownfile : text;
{$ifdef EXTRA} {$ifdef EXTRA}
error_file : text; error_file : text;
@ -163,6 +164,7 @@ var
main_relo_todolist: ppheap_mem_info; main_relo_todolist: ppheap_mem_info;
orphaned_info: theap_info; orphaned_info: theap_info;
todo_lock: trtlcriticalsection; todo_lock: trtlcriticalsection;
textoutput : ^text;
threadvar threadvar
heap_info: theap_info; heap_info: theap_info;
@ -411,7 +413,7 @@ begin
if useownfile then if useownfile then
writeln(ownfile,'error in linked list of heap_mem_info') writeln(ownfile,'error in linked list of heap_mem_info')
else else
writeln(stderr,'error in linked list of heap_mem_info'); writeln(textoutput^,'error in linked list of heap_mem_info');
RunError(204); RunError(204);
end; end;
if pp=p then if pp=p then
@ -422,7 +424,7 @@ begin
if useownfile then if useownfile then
writeln(ownfile,'error in linked list of heap_mem_info') writeln(ownfile,'error in linked list of heap_mem_info')
else else
writeln(stderr,'error in linked list of heap_mem_info'); writeln(textoutput^,'error in linked list of heap_mem_info');
end; end;
end; end;
@ -578,7 +580,7 @@ begin
if useownfile then if useownfile then
ptext:=@ownfile ptext:=@ownfile
else else
ptext:=@stderr; ptext:=textoutput;
inc(loc_info^.freemem_size,size); inc(loc_info^.freemem_size,size);
inc(loc_info^.freemem8_size,(size+7) and not 7); inc(loc_info^.freemem8_size,(size+7) and not 7);
if not quicktrace then if not quicktrace then
@ -773,7 +775,7 @@ begin
if useownfile then if useownfile then
dump_wrong_size(pp,l,ownfile) dump_wrong_size(pp,l,ownfile)
else else
dump_wrong_size(pp,l,stderr); dump_wrong_size(pp,l,textoutput^);
{$ifdef EXTRA} {$ifdef EXTRA}
dump_wrong_size(pp,l,error_file); dump_wrong_size(pp,l,error_file);
@ -832,7 +834,7 @@ begin
if useownfile then if useownfile then
dump_error(pp,ownfile) dump_error(pp,ownfile)
else else
dump_error(pp,stderr); dump_error(pp,textoutput^);
{$ifdef EXTRA} {$ifdef EXTRA}
dump_error(pp,error_file); dump_error(pp,error_file);
{$endif EXTRA} {$endif EXTRA}
@ -1014,7 +1016,7 @@ begin
if useownfile then if useownfile then
ptext:=@ownfile ptext:=@ownfile
else else
ptext:=@stderr; ptext:=textoutput;
{$ifdef go32v2} {$ifdef go32v2}
if ptruint(p)<$1000 then if ptruint(p)<$1000 then
@ -1184,7 +1186,7 @@ begin
if useownfile then if useownfile then
ptext:=@ownfile ptext:=@ownfile
else else
ptext:=@stderr; ptext:=textoutput;
pp:=loc_info^.heap_mem_root; pp:=loc_info^.heap_mem_root;
Writeln(ptext^,'Heap dump by heaptrc unit'); Writeln(ptext^,'Heap dump by heaptrc unit');
Writeln(ptext^,loc_info^.getmem_cnt, ' memory blocks allocated : ', Writeln(ptext^,loc_info^.getmem_cnt, ' memory blocks allocated : ',
@ -1366,7 +1368,7 @@ begin
Rewrite(ownfile); Rewrite(ownfile);
if IOResult<>0 then if IOResult<>0 then
begin begin
Writeln(stderr,'[heaptrc] Unable to open "',name,'", writing output to stderr instead.'); Writeln(textoutput^,'[heaptrc] Unable to open "',name,'", writing output to stderr instead.');
useownfile:=false; useownfile:=false;
exit; exit;
end; end;
@ -1378,6 +1380,12 @@ begin
writeln(ownfile); writeln(ownfile);
end; end;
procedure SetHeapTraceOutput(var ATextOutput : Text);
Begin
useowntextoutput := True;
textoutput := @ATextOutput;
end;
procedure SetHeapExtraInfo( size : ptruint;fillproc : tfillextrainfoproc;displayproc : tdisplayextrainfoproc); procedure SetHeapExtraInfo( size : ptruint;fillproc : tfillextrainfoproc;displayproc : tdisplayextrainfoproc);
begin begin
{ the total size must stay multiple of 8, also allocate 2 pointers for { the total size must stay multiple of 8, also allocate 2 pointers for
@ -1411,6 +1419,8 @@ const
procedure TraceInit; procedure TraceInit;
begin begin
textoutput := @stderr;
useowntextoutput := false;
MakeCRC32Tbl; MakeCRC32Tbl;
main_orig_todolist := @heap_info.heap_free_todo; main_orig_todolist := @heap_info.heap_free_todo;
main_relo_todolist := nil; main_relo_todolist := nil;
@ -1454,8 +1464,8 @@ begin
end end
else else
begin begin
Writeln(stderr,'No heap dump by heaptrc unit'); Writeln(textoutput^,'No heap dump by heaptrc unit');
Writeln(stderr,'Exitcode = ',exitcode); Writeln(textoutput^,'Exitcode = ',exitcode);
end; end;
if useownfile then if useownfile then
begin begin
@ -1478,6 +1488,11 @@ begin
useownfile:=false; useownfile:=false;
close(ownfile); close(ownfile);
end; end;
if useowntextoutput then
begin
useowntextoutput := false;
close(textoutput^);
end;
end; end;
{$if defined(win32) or defined(win64)} {$if defined(win32) or defined(win64)}