Browse Source

+ Overloaded procedure dump_stack that calls CaptureBacktrace, thus encapsulating internals of stack traversing.
* Use this new procedure in heaptrc unit.

git-svn-id: trunk@29713 -

sergei 10 years ago
parent
commit
7666cd5c0e
3 changed files with 27 additions and 27 deletions
  1. 4 27
      rtl/inc/heaptrc.pp
  2. 22 0
      rtl/inc/system.inc
  3. 1 0
      rtl/inc/systemh.inc

+ 4 - 27
rtl/inc/heaptrc.pp

@@ -334,23 +334,14 @@ end;
 
 
 
 
 procedure dump_already_free(p : pheap_mem_info;var ptext : text);
 procedure dump_already_free(p : pheap_mem_info;var ptext : text);
-var
-  bp : pointer;
-  pcaddr : codepointer;
 begin
 begin
   Writeln(ptext,'Marked memory at $',HexStr(pointer(p)+sizeof(theap_mem_info)),' released');
   Writeln(ptext,'Marked memory at $',HexStr(pointer(p)+sizeof(theap_mem_info)),' released');
   call_free_stack(p,ptext);
   call_free_stack(p,ptext);
   Writeln(ptext,'freed again at');
   Writeln(ptext,'freed again at');
-  bp:=get_frame;
-  pcaddr:=get_pc_addr;
-  get_caller_stackinfo(bp,pcaddr);
-  dump_stack(ptext,bp,pcaddr);
+  dump_stack(ptext,1);
 end;
 end;
 
 
 procedure dump_error(p : pheap_mem_info;var ptext : text);
 procedure dump_error(p : pheap_mem_info;var ptext : text);
-var
-  bp : pointer;
-  pcaddr : codepointer;
 begin
 begin
   Writeln(ptext,'Marked memory at $',HexStr(pointer(p)+sizeof(theap_mem_info)),' invalid');
   Writeln(ptext,'Marked memory at $',HexStr(pointer(p)+sizeof(theap_mem_info)),' invalid');
   Writeln(ptext,'Wrong signature $',hexstr(p^.sig,8),' instead of ',hexstr(calculate_sig(p),8));
   Writeln(ptext,'Wrong signature $',hexstr(p^.sig,8),' instead of ',hexstr(calculate_sig(p),8));
@@ -359,10 +350,7 @@ begin
       write(ptext, 'Block content: ');
       write(ptext, 'Block content: ');
       printhex(pointer(p) + sizeof(theap_mem_info), p^.size, ptext);
       printhex(pointer(p) + sizeof(theap_mem_info), p^.size, ptext);
     end;
     end;
-  bp:=get_frame;
-  pcaddr:=get_pc_addr;
-  get_caller_stackinfo(bp,pcaddr);
-  dump_stack(ptext,bp,pcaddr);
+  dump_stack(ptext,1);
 end;
 end;
 
 
 {$ifdef EXTRA}
 {$ifdef EXTRA}
@@ -382,16 +370,10 @@ end;
 {$endif EXTRA}
 {$endif EXTRA}
 
 
 procedure dump_wrong_size(p : pheap_mem_info;size : ptruint;var ptext : text);
 procedure dump_wrong_size(p : pheap_mem_info;size : ptruint;var ptext : text);
-var
-  bp : pointer;
-  pcaddr : codepointer;
 begin
 begin
   Writeln(ptext,'Marked memory at $',HexStr(pointer(p)+sizeof(theap_mem_info)),' invalid');
   Writeln(ptext,'Marked memory at $',HexStr(pointer(p)+sizeof(theap_mem_info)),' invalid');
   Writeln(ptext,'Wrong size : ',p^.size,' allocated ',size,' freed');
   Writeln(ptext,'Wrong size : ',p^.size,' allocated ',size,' freed');
-  bp:=get_frame;
-  pcaddr:=get_pc_addr;
-  get_caller_stackinfo(bp,pcaddr);
-  dump_stack(ptext,bp,pcaddr);
+  dump_stack(ptext,1);
   { the check is done to be sure that the procvar is not overwritten }
   { the check is done to be sure that the procvar is not overwritten }
   if assigned(p^.extra_info) and
   if assigned(p^.extra_info) and
      (p^.extra_info^.check=$12345678) and
      (p^.extra_info^.check=$12345678) and
@@ -961,8 +943,6 @@ var
 {$ifdef windows}
 {$ifdef windows}
   datap : pointer;
   datap : pointer;
 {$endif windows}
 {$endif windows}
-  bp : pointer;
-  pcaddr : codepointer;
   ptext : ^text;
   ptext : ^text;
 begin
 begin
   if p=nil then
   if p=nil then
@@ -1117,10 +1097,7 @@ begin
       end;
       end;
    end;
    end;
   writeln(ptext^,'pointer $',hexstr(p),' does not point to valid memory block');
   writeln(ptext^,'pointer $',hexstr(p),' does not point to valid memory block');
-  bp:=get_frame;
-  pcaddr:=get_pc_addr;
-  get_caller_stackinfo(bp,pcaddr);
-  dump_stack(ptext^,bp,pcaddr);
+  dump_stack(ptext^,1);
   runerror(204);
   runerror(204);
 end;
 end;
 
 

+ 22 - 0
rtl/inc/system.inc

@@ -1212,6 +1212,28 @@ Begin
 End;
 End;
 
 
 
 
+procedure dump_stack(var f: text; skipframes: longint);
+var
+  i,count: longint;
+  frames: array [0..255] of codepointer;
+begin
+  if do_isdevice(textrec(f).handle) then
+    count:=max_frame_dump
+  else
+    count:=255;
+{$ifdef FPC_HAS_FEATURE_EXCEPTIONS}
+  try
+{$endif FPC_HAS_FEATURE_EXCEPTIONS}
+    count:=CaptureBacktrace(skipframes+1,count,@frames[0]);
+    for i:=0 to count-1 do
+      writeln(f,BackTraceStrFunc(frames[i]));
+{$ifdef FPC_HAS_FEATURE_EXCEPTIONS}
+  except
+  end;
+{$endif FPC_HAS_FEATURE_EXCEPTIONS}
+end;
+
+
 {$ifdef FPC_HAS_FEATURE_EXCEPTIONS}
 {$ifdef FPC_HAS_FEATURE_EXCEPTIONS}
 procedure DumpExceptionBackTrace(var f:text);
 procedure DumpExceptionBackTrace(var f:text);
 var
 var

+ 1 - 0
rtl/inc/systemh.inc

@@ -1385,6 +1385,7 @@ Function  ParamStr(l:Longint):string;
 {$endif FPC_HAS_FEATURE_COMMANDARGS}
 {$endif FPC_HAS_FEATURE_COMMANDARGS}
 
 
 Procedure Dump_Stack(var f : text;fp:pointer;addr : codepointer = nil);
 Procedure Dump_Stack(var f : text;fp:pointer;addr : codepointer = nil);
+procedure Dump_Stack(var f : text;skipframes : longint);
 {$ifdef FPC_HAS_FEATURE_EXCEPTIONS}
 {$ifdef FPC_HAS_FEATURE_EXCEPTIONS}
 procedure DumpExceptionBackTrace(var f:text);
 procedure DumpExceptionBackTrace(var f:text);
 {$endif FPC_HAS_FEATURE_EXCEPTIONS}
 {$endif FPC_HAS_FEATURE_EXCEPTIONS}