From 0bccbc5fde8e03c0ef1f4df81f25f31c26e5c61f Mon Sep 17 00:00:00 2001 From: pierre Date: Tue, 6 Oct 1998 17:09:13 +0000 Subject: [PATCH] + added trace of first dispose for errors --- rtl/inc/heaptrc.pp | 125 +++++++++++++++++++++++++++++++++++++-------- 1 file changed, 103 insertions(+), 22 deletions(-) diff --git a/rtl/inc/heaptrc.pp b/rtl/inc/heaptrc.pp index 86e2c05599..19a6452713 100644 --- a/rtl/inc/heaptrc.pp +++ b/rtl/inc/heaptrc.pp @@ -19,15 +19,22 @@ interface procedure dump_heap; procedure mark_heap; +const + tracesize = 8; + quicktrace : boolean=true; + keepreleased : boolean=true; + implementation -const - tracesize = 4; - quicktrace : boolean=true; - type pheap_mem_info = ^theap_mem_info; + { warning the size of theap_mem_info + must be a multiple of 8 + because otherwise you will get + problems when releasing the usual memory part !! + sizeof(theap_mem_info = 16+tracesize*4 so + tracesize must be even !! PM } theap_mem_info = record next, previous : pheap_mem_info; @@ -40,28 +47,52 @@ var heap_mem_root : pheap_mem_info; getmem_cnt, freemem_cnt : longint; + getmem_size, + freemem_size : longint; {***************************************************************************** Helpers *****************************************************************************} -procedure call_stack(p : pointer); +procedure call_stack(pp : pheap_mem_info); var i : longint; - pp : pheap_mem_info; begin - pp:=pheap_mem_info(p-sizeof(theap_mem_info)); - writeln(stderr,'Call trace for block 0x',hexstr(longint(p),8),' size ',pp^.size); + writeln(stderr,'Call trace for block 0x',hexstr(longint(pp+sizeof(theap_mem_info)),8),' size ',pp^.size); for i:=1 to tracesize do - writeln(stderr,i,' 0x',hexstr(pp^.calls[i],8)); + if pp^.calls[i]<>0 then + writeln(stderr,' 0x',hexstr(pp^.calls[i],8)); +end; + +procedure call_free_stack(pp : pheap_mem_info); +var + i : longint; + +begin + writeln(stderr,'Call trace for block 0x',hexstr(longint(pp+sizeof(theap_mem_info)),8),' size ',pp^.size); + for i:=1 to tracesize div 2 do + if pp^.calls[i]<>0 then + writeln(stderr,' 0x',hexstr(pp^.calls[i],8)); + writeln(stderr,' was released at '); + for i:=(tracesize div 2)+1 to tracesize do + if pp^.calls[i]<>0 then + writeln(stderr,' 0x',hexstr(pp^.calls[i],8)); end; -procedure dump_free(p : pheap_mem_info); +procedure dump_already_free(p : pheap_mem_info); begin - Writeln(stderr,'Marked memory at ',HexStr(longint(p),8),' released'); - call_stack(p+sizeof(theap_mem_info)); + Writeln(stderr,'Marked memory at ',HexStr(longint(p+sizeof(theap_mem_info)),8),' released'); + call_free_stack(p); + Writeln(stderr,'freed again at'); + dump_stack(get_caller_frame(get_frame)); +end; + +procedure dump_error(p : pheap_mem_info); +begin + Writeln(stderr,'Marked memory at ',HexStr(longint(p+sizeof(theap_mem_info)),8),' invalid'); + Writeln(stderr,'Wrong signature $',hexstr(p^.sig,8)); dump_stack(get_caller_frame(get_frame)); end; @@ -99,6 +130,7 @@ procedure TraceGetMem(var p:pointer;size:longint); var i,bp : longint; begin + inc(getmem_size,size); { Do the real GetMem, but alloc also for the info block } SysGetMem(p,size+sizeof(theap_mem_info)); { Create the info block } @@ -127,20 +159,47 @@ end; *****************************************************************************} procedure TraceFreeMem(var p:pointer;size:longint); + + var i,bp : longint; + pp : pheap_mem_info; begin + inc(freemem_size,size); inc(size,sizeof(theap_mem_info)); dec(p,sizeof(theap_mem_info)); + pp:=pheap_mem_info(p); if not quicktrace and not(is_in_getmem_list(p)) then RunError(204); - if pheap_mem_info(p)^.sig=$AAAAAAAA then - dump_free(p); - if pheap_mem_info(p)^.next<>nil then - pheap_mem_info(p)^.next^.previous:=pheap_mem_info(p)^.previous; - if pheap_mem_info(p)^.previous<>nil then - pheap_mem_info(p)^.previous^.next:=pheap_mem_info(p)^.next; - if pheap_mem_info(p)=heap_mem_root then - heap_mem_root:=heap_mem_root^.previous; + if pp^.sig=$AAAAAAAA then + dump_already_free(pp) + else if pp^.sig<>$DEADBEEF then + begin + dump_error(pp); + { don't release anything in this case !! } + exit; + end; + { now it is released !! } + pp^.sig:=$AAAAAAAA; + if not keepreleased then + begin + if pp^.next<>nil then + pp^.next^.previous:=pp^.previous; + if pp^.previous<>nil then + pp^.previous^.next:=pp^.next; + if pp=heap_mem_root then + heap_mem_root:=heap_mem_root^.previous; + end; + bp:=get_caller_frame(get_frame); + for i:=(tracesize div 2)+1 to tracesize do + begin + pp^.calls[i]:=get_caller_addr(bp); + bp:=get_caller_frame(bp); + end; inc(freemem_cnt); + { release the normal memory at least !! } + { this way we keep all info about all released memory !! } + dec(size,sizeof(theap_mem_info)); + inc(p,sizeof(theap_mem_info)); + SysFreeMem(p,size); end; @@ -151,11 +210,30 @@ end; procedure dump_heap; var pp : pheap_mem_info; + i : longint; begin pp:=heap_mem_root; + Writeln(stderr,'Heap dump by heaptrc unit'); + Writeln(stderr,getmem_cnt,' memory blocks allocated : ',getmem_size); + Writeln(stderr,freemem_cnt,' memory blocks allocated : ',freemem_size); + Writeln(stderr,'Unfreed memory size : ',getmem_size-freemem_size); + i:=getmem_cnt-freemem_cnt; while pp<>nil do begin - call_stack(pp+sizeof(theap_mem_info)); + if i<0 then + begin + Writeln(stderr,'Error in heap memory list'); + Writeln(stderr,'More memory blocks than expected'); + exit; + end; + if pp^.sig=$DEADBEEF then + begin + { this one was not released !! } + call_stack(pp); + dec(i); + end + else if pp^.sig<>$AAAAAAAA then + dump_error(pp); pp:=pp^.previous; end; end; @@ -201,7 +279,10 @@ begin end. { $Log$ - Revision 1.2 1998-10-02 10:35:38 peter + Revision 1.3 1998-10-06 17:09:13 pierre + + added trace of first dispose for errors + + Revision 1.2 1998/10/02 10:35:38 peter + quicktrace Revision 1.1 1998/10/01 14:54:20 peter