+ added trace of first dispose for errors

rtl/inc/heaptrc.pp

@@ -19,15 +19,22 @@ interface
 procedure dump_heap;
 procedure mark_heap;
 
-
-implementation
-
 const
-  tracesize = 4;
+  tracesize = 8;
   quicktrace : boolean=true;
+  keepreleased : boolean=true;
+
+
+implementation
 
 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