+ quicktrace

rtl/inc/heaptrc.pp

@@ -16,13 +16,15 @@
 unit heaptrc;
 interface
 
-procedure dump_heap(mark : boolean);
+procedure dump_heap;
+procedure mark_heap;
 
 
 implementation
 
 const
   tracesize = 4;
+  quicktrace : boolean=true;
 
 type
   pheap_mem_info = ^theap_mem_info;
@@ -30,7 +32,7 @@ type
     next,
     previous : pheap_mem_info;
     size     : longint;
-    sig      : longint; {dummy number for test }
+    sig      : longint;
     calls    : array [1..tracesize] of longint;
   end;
 
@@ -44,49 +46,49 @@ var
                                 Helpers
 *****************************************************************************}
 
-   procedure call_stack(p : pointer);
-     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);
-       for i:=1 to tracesize do
-        writeln(stderr,i,' 0x',hexstr(pp^.calls[i],8));
-     end;
-
-
-   procedure dump_free(p : pheap_mem_info);
-     begin
-       Writeln(stderr,'Marked memory at ',HexStr(longint(p),8),' released');
-       call_stack(p+sizeof(theap_mem_info));
-       dump_stack(get_caller_frame(get_frame));
-     end;
-
-
-   function is_in_getmem_list (p : pointer) : boolean;
-     var
-       i  : longint;
-       pp : pheap_mem_info;
-     begin
-       is_in_getmem_list:=false;
-       pp:=heap_mem_root;
-       i:=0;
-       while pp<>nil do
-        begin
-          if (pp^.sig<>$DEADBEEF) and (pp^.sig <> $AAAAAAAA) then
-           begin
-             writeln(stderr,'error in linked list of heap_mem_info');
-             RunError(204);
-           end;
-          if pp=p then
-            is_in_getmem_list:=true;
-          pp:=pp^.previous;
-          inc(i);
-          if i > getmem_cnt - freemem_cnt then
-            writeln(stderr,'error in linked list of heap_mem_info');
-        end;
-     end;
+procedure call_stack(p : pointer);
+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);
+  for i:=1 to tracesize do
+   writeln(stderr,i,' 0x',hexstr(pp^.calls[i],8));
+end;
+
+
+procedure dump_free(p : pheap_mem_info);
+begin
+  Writeln(stderr,'Marked memory at ',HexStr(longint(p),8),' released');
+  call_stack(p+sizeof(theap_mem_info));
+  dump_stack(get_caller_frame(get_frame));
+end;
+
+
+function is_in_getmem_list (p : pointer) : boolean;
+var
+  i  : longint;
+  pp : pheap_mem_info;
+begin
+  is_in_getmem_list:=false;
+  pp:=heap_mem_root;
+  i:=0;
+  while pp<>nil do
+   begin
+     if (pp^.sig<>$DEADBEEF) and (pp^.sig <> $AAAAAAAA) then
+      begin
+        writeln(stderr,'error in linked list of heap_mem_info');
+        RunError(204);
+      end;
+     if pp=p then
+      is_in_getmem_list:=true;
+     pp:=pp^.previous;
+     inc(i);
+     if i>getmem_cnt-freemem_cnt then
+      writeln(stderr,'error in linked list of heap_mem_info');
+   end;
+end;
 
 
 {*****************************************************************************
@@ -128,7 +130,7 @@ procedure TraceFreeMem(var p:pointer;size:longint);
 begin
   inc(size,sizeof(theap_mem_info));
   dec(p,sizeof(theap_mem_info));
-  if not (is_in_getmem_list(p)) then
+  if not quicktrace and not(is_in_getmem_list(p)) then
     RunError(204);
   if pheap_mem_info(p)^.sig=$AAAAAAAA then
     dump_free(p);
@@ -146,7 +148,7 @@ end;
                               Dump Heap
 *****************************************************************************}
 
-procedure dump_heap(mark : boolean);
+procedure dump_heap;
 var
   pp : pheap_mem_info;
 begin
@@ -154,8 +156,19 @@ begin
   while pp<>nil do
    begin
      call_stack(pp+sizeof(theap_mem_info));
-     if mark then
-       pp^.sig:=$AAAAAAAA;
+     pp:=pp^.previous;
+   end;
+end;
+
+
+procedure mark_heap;
+var
+  pp : pheap_mem_info;
+begin
+  pp:=heap_mem_root;
+  while pp<>nil do
+   begin
+     pp^.sig:=$AAAAAAAA;
      pp:=pp^.previous;
    end;
 end;
@@ -177,7 +190,7 @@ var
 procedure TraceExit;
 begin
   ExitProc:=SaveExit;
-  Dump_heap(false);
+  Dump_heap;
 end;
 
 
@@ -188,7 +201,10 @@ begin
 end.
 {
   $Log$
-  Revision 1.1  1998-10-01 14:54:20  peter
+  Revision 1.2  1998-10-02 10:35:38  peter
+    + quicktrace
+
+  Revision 1.1  1998/10/01 14:54:20  peter
     + first version
 
 }