paweld/fpc
1
0
Fork 0
mirror of https://gitlab.com/freepascal.org/fpc/source.git synced 2025-09-02 11:10:36 +02:00
Code Issues Packages Projects Releases Wiki Activity

* patch by Anton Kavalenka: heaptrc: Improve tracing by printing actual

Browse Source 
module name (ether EXE or DLL), resolves #36130

git-svn-id: trunk@43710 -
This commit is contained in:
florian 2019-12-22 22:51:53 +00:00
parent 2f374a37b7
commit 99680eb88c
1 changed files with 53 additions and 2 deletions
Show Stats Download Patch File Download Diff File Expand all files Collapse all files

55
rtl/inc/heaptrc.pp
View File

@ -14,7 +14,6 @@
**********************************************************************} **********************************************************************}
{$checkpointer off} {$checkpointer off}
unit heaptrc; unit heaptrc;
interface interface
@ -1239,6 +1238,58 @@ begin
DumpHeap(GlobalSkipIfNoLeaks); DumpHeap(GlobalSkipIfNoLeaks);
end; end;
const
{$ifdef BSD} // dlopen is in libc on FreeBSD.
LibDL = 'c';
{$else}
{$ifdef HAIKU}
LibDL = 'root';
{$else}
LibDL = 'dl';
{$endif}
{$endif}
{$if defined(LINUX) or defined(BSD)}
type
Pdl_info = ^dl_info;
dl_info = record
dli_fname : Pchar;
dli_fbase : pointer;
dli_sname : Pchar;
dli_saddr : pointer;
end;
function _dladdr(Lib:pointer; info: Pdl_info): Longint; cdecl; external LibDL name 'dladdr';
{$elseif defined(MSWINDOWS)}
function _GetModuleFileNameA(hModule:HModule;lpFilename:PAnsiChar;nSize:cardinal):cardinal;stdcall; external 'kernel32' name 'GetModuleFileNameA';
{$endif}
function GetModuleName:string;
var
{$ifdef MSWINDOWS}
sz:cardinal;
buf:array[0..8191] of char;
{$endif}
{$if defined(LINUX) or defined(BSD)}
res:integer;
dli:dl_info;
{$endif}
begin
GetModuleName:='';
{$if defined(LINUX) or defined(BSD)}
res:=_dladdr(@ParamStr,@dli); { get any non-eliminated address in SO space }
if res<=0 then
exit;
if Assigned(dli.dli_fname) then
GetModuleName:=PAnsiChar(dli.dli_fname);
{$elseif defined(MSWINDOWS)}
sz:=_GetModuleFileNameA(hInstance,PChar(@buf),sizeof(buf));
if sz>0 then
setstring(GetModuleName,PAnsiChar(@buf),sz)
{$else}
Result:=ParamStr(0);
{$endif}
end;
procedure dumpheap(SkipIfNoLeaks : Boolean); procedure dumpheap(SkipIfNoLeaks : Boolean);
var var
pp : pheap_mem_info; pp : pheap_mem_info;
@ -1256,7 +1307,7 @@ begin
pp:=loc_info^.heap_mem_root; pp:=loc_info^.heap_mem_root;
if ((loc_info^.getmem_size-loc_info^.freemem_size)=0) and SkipIfNoLeaks then if ((loc_info^.getmem_size-loc_info^.freemem_size)=0) and SkipIfNoLeaks then
exit; exit;
Writeln(ptext^,'Heap dump by heaptrc unit of '+ParamStr(0)); Writeln(ptext^,'Heap dump by heaptrc unit of "'+GetModuleName()+'"');
Writeln(ptext^,loc_info^.getmem_cnt, ' memory blocks allocated : ', Writeln(ptext^,loc_info^.getmem_cnt, ' memory blocks allocated : ',
loc_info^.getmem_size,'/',loc_info^.getmem8_size); loc_info^.getmem_size,'/',loc_info^.getmem8_size);
Writeln(ptext^,loc_info^.freemem_cnt,' memory blocks freed : ', Writeln(ptext^,loc_info^.freemem_cnt,' memory blocks freed : ',