* get_addr function renamed to get_pc_addr

 + get_caller_stackinfo procedure added.

git-svn-id: trunk@21707 -

rtl/i386/i386.inc

@@ -1061,8 +1061,8 @@ end;
 {$ENDIF not INTERNAL_BACKTRACE}
 
 
-{$define FPC_SYSTEM_HAS_GET_ADDR}
-Function Get_addr : Pointer;assembler;nostackframe;
+{$define FPC_SYSTEM_HAS_GET_PC_ADDR}
+Function Get_pc_addr : Pointer;assembler;nostackframe;
 asm
         movl    (%esp),%eax
 end;

rtl/inc/heaptrc.pp

@@ -331,14 +331,21 @@ end;
 
 
 procedure dump_already_free(p : pheap_mem_info;var ptext : text);
+var
+  bp, pcaddr : pointer;
 begin
   Writeln(ptext,'Marked memory at $',HexStr(pointer(p)+sizeof(theap_mem_info)),' released');
   call_free_stack(p,ptext);
   Writeln(ptext,'freed again at');
-  dump_stack(ptext,get_caller_frame(get_frame));
+  bp:=get_frame;
+  pcaddr:=get_pc_addr;
+  get_caller_stackinfo(bp,pcaddr);
+  dump_stack(ptext,bp,pcaddr);
 end;
 
 procedure dump_error(p : pheap_mem_info;var ptext : text);
+var
+  bp, pcaddr : pointer;
 begin
   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));
@@ -347,7 +354,10 @@ begin
       write(ptext, 'Block content: ');
       printhex(pointer(p) + sizeof(theap_mem_info), p^.size, ptext);
     end;
-  dump_stack(ptext,get_caller_frame(get_frame));
+  bp:=get_frame;
+  pcaddr:=get_pc_addr;
+  get_caller_stackinfo(bp,pcaddr);
+  dump_stack(ptext,bp,pcaddr);
 end;
 
 {$ifdef EXTRA}
@@ -367,10 +377,15 @@ end;
 {$endif EXTRA}
 
 procedure dump_wrong_size(p : pheap_mem_info;size : ptruint;var ptext : text);
+var
+  bp, pcaddr : pointer;
 begin
   Writeln(ptext,'Marked memory at $',HexStr(pointer(p)+sizeof(theap_mem_info)),' invalid');
   Writeln(ptext,'Wrong size : ',p^.size,' allocated ',size,' freed');
-  dump_stack(ptext,get_caller_frame(get_frame));
+  bp:=get_frame;
+  pcaddr:=get_pc_addr;
+  get_caller_stackinfo(bp,pcaddr);
+  dump_stack(ptext,bp,pcaddr);
   { the check is done to be sure that the procvar is not overwritten }
   if assigned(p^.extra_info) and
      (p^.extra_info^.check=$12345678) and
@@ -445,7 +460,7 @@ Function TraceGetMem(size:ptruint):pointer;
 var
   allocsize,i : ptruint;
   oldbp,
-  bp : pointer;
+  bp,pcaddr : pointer;
   pl : pdword;
   p  : pointer;
   pp : pheap_mem_info;
@@ -509,15 +524,16 @@ begin
   { clear the memory }
   fillchar(p^,size,#255);
   { retrieve backtrace info }
-  bp:=get_caller_frame(get_frame);
-
+  bp:=get_frame;
+  pcaddr:=get_pc_addr;
+  get_caller_stackinfo(bp,pcaddr);
   { valid bp? }
   if (bp>=StackBottom) and (bp<(StackBottom + StackLength)) then
     for i:=1 to tracesize do
      begin
-       pp^.calls[i]:=get_caller_addr(bp);
        oldbp:=bp;
-       bp:=get_caller_frame(bp);
+       get_caller_stackinfo(bp,pcaddr);
+       pp^.calls[i]:=pcaddr;
        if (bp<oldbp) or (bp>(StackBottom + StackLength)) then
          break;
      end;
@@ -553,7 +569,7 @@ function CheckFreeMemSize(loc_info: pheap_info; pp: pheap_mem_info;
   size, ppsize: ptruint): boolean; inline;
 var
   i: ptruint;
-  bp : pointer;
+  bp,pcaddr : pointer;
   ptext : ^text;
 {$ifdef EXTRA}
   pp2 : pheap_mem_info;
@@ -612,12 +628,15 @@ begin
     end
   else
     begin
-       bp:=get_caller_frame(get_frame);
+       bp:=get_frame;
+       pcaddr:=get_pc_addr;
+       get_caller_stackinfo(bp,pcaddr);
+
        if (bp>=StackBottom) and (bp<(StackBottom + StackLength)) then
          for i:=(tracesize div 2)+1 to tracesize do
           begin
-            pp^.calls[i]:=get_caller_addr(bp);
-            bp:=get_caller_frame(bp);
+            get_caller_stackinfo(bp,pcaddr);
+            pp^.calls[i]:=pcaddr;
             if not((bp>=StackBottom) and (bp<(StackBottom + StackLength))) then
               break;
           end;
@@ -775,7 +794,8 @@ var
   movesize,
   i  : ptruint;
   oldbp,
-  bp : pointer;
+  bp,
+  pcaddr : pointer;
   pl : pdword;
   pp : pheap_mem_info;
   oldsize,
@@ -890,13 +910,15 @@ begin
   inc(loc_info^.getmem_size,size);
   inc(loc_info^.getmem8_size,(size+7) and not 7);
   { generate new backtrace }
-  bp:=get_caller_frame(get_frame);
+  bp:=get_frame;
+  pcaddr:=get_pc_addr;
+  get_caller_stackinfo(bp,pcaddr);
   if (bp>=StackBottom) and (bp<(StackBottom + StackLength)) then
     for i:=1 to tracesize do
      begin
-       pp^.calls[i]:=get_caller_addr(bp);
        oldbp:=bp;
-       bp:=get_caller_frame(bp);
+       get_caller_stackinfo(bp,pcaddr);
+       pp^.calls[i]:=pcaddr;
        if (bp<oldbp) or (bp>(StackBottom + StackLength)) then
          break;
      end;
@@ -979,6 +1001,7 @@ var
 {$ifdef morphos}
   stack_top: longword;
 {$endif morphos}
+  bp,pcaddr : pointer;
   ptext : ^text;
 label
   _exit;
@@ -1136,7 +1159,10 @@ begin
       end;
    end;
   writeln(ptext^,'pointer $',hexstr(p),' does not point to valid memory block');
-  dump_stack(ptext^,get_caller_frame(get_frame));
+  bp:=get_frame;
+  pcaddr:=get_pc_addr;
+  get_caller_stackinfo(bp,pcaddr);
+  dump_stack(ptext^,bp,pcaddr);
   runerror(204);
 _exit:
 end;

rtl/inc/system.inc

@@ -669,43 +669,60 @@ End;
                              Miscellaneous
 *****************************************************************************}
 
-{$ifndef FPC_SYSTEM_HAS_GET_ADDR}
+{$ifndef FPC_SYSTEM_HAS_GET_PC_ADDR}
   { This provides a dummy implementation
-    of get_addr function, for CPU's that don't need
+    of get_pc_addr function, for CPU's that don't need
     the instruction address to walk the stack. }
-function get_addr : pointer;
+function get_pc_addr : pointer;
 begin
-  get_addr:=nil;
+  get_pc_addr:=nil;
 end;
-{$endif ndef FPC_SYSTEM_HAS_GET_ADDR}
+{$endif ndef FPC_SYSTEM_HAS_GET_PC_ADDR}
+
+{$ifndef FPC_SYSTEM_HAS_GET_CALLER_STACKINFO}
+  { This provides a simpel implementation
+    of get_caller_stackinfo procedure,
+    using get_caller_addr and get_caller_frame
+    functions. }
+procedure get_caller_stackinfo(var framebp,addr : pointer);
+var
+  nextbp,nextaddr : pointer;
+begin
+  nextbp:=get_caller_frame(framebp,addr);
+  nextaddr:=get_caller_addr(framebp,addr);
+  framebp:=nextbp;
+  addr:=nextaddr;
+end;
+{$endif ndef FPC_SYSTEM_HAS_GET_CALLER_STACKINFO}
+
 
 procedure fpc_rangeerror;[public,alias:'FPC_RANGEERROR']; compilerproc;
 begin
-  HandleErrorAddrFrame(201,get_addr,get_frame);
+  HandleErrorAddrFrame(201,get_pc_addr,get_frame);
 end;
 
 
 procedure fpc_divbyzero;[public,alias:'FPC_DIVBYZERO']; compilerproc;
 begin
-  HandleErrorAddrFrame(200,get_addr,get_frame);
+  HandleErrorAddrFrame(200,get_pc_addr,get_frame);
 end;
 
 
 procedure fpc_overflow;[public,alias:'FPC_OVERFLOW']; compilerproc;
 begin
-  HandleErrorAddrFrame(215,get_addr,get_frame);
+  HandleErrorAddrFrame(215,get_pc_addr,get_frame);
 end;
 
 
 procedure fpc_threaderror; [public,alias:'FPC_THREADERROR'];
 begin
-  HandleErrorAddrFrame(6,get_addr,get_frame);
+  HandleErrorAddrFrame(6,get_pc_addr,get_frame);
 end;
 
 
 procedure fpc_invalidpointer; [public,alias:'FPC_INVALIDPOINTER'];
 begin
-  HandleErrorAddrFrame(216,get_addr,get_frame);
+  HandleErrorAddrFrame(216,get_pc_addr,get_frame);
 end;
 
 
@@ -719,7 +736,7 @@ begin
    begin
      l:=HInOutRes^;
      HInOutRes^:=0;
-     HandleErrorAddrFrame(l,get_addr,get_frame);
+     HandleErrorAddrFrame(l,get_pc_addr,get_frame);
    end;
 end;
 
@@ -748,7 +765,7 @@ begin
     begin
       if assigned(SafeCallErrorProc) then
         SafeCallErrorProc(res,get_frame);
-      HandleErrorAddrFrame(229,get_addr,get_frame);
+      HandleErrorAddrFrame(229,get_pc_addr,get_frame);
     end;
   result:=res;
 end;
@@ -1035,15 +1052,20 @@ Procedure HandleError (Errno : longint);[public,alias : 'FPC_HANDLEERROR'];
   Internal function should ALWAYS call HandleError instead of RunError.
 }
 begin
-  HandleErrorAddrFrame(Errno,get_frame,get_addr);
+  HandleErrorAddrFrame(Errno,get_pc_addr,get_frame);
 end;
 
 
 procedure RunError(w : word);[alias: 'FPC_RUNERROR'];
+var
+  bp,pcaddr : pointer;
 begin
   errorcode:=w;
-  erroraddr:=get_caller_addr(get_frame,get_addr);
-  errorbase:=get_caller_frame(get_frame,get_addr);
+  pcaddr:=get_pc_addr;
+  bp:=get_frame;
+  get_caller_stackinfo(bp,pcaddr);
+  erroraddr:=pcaddr;
+  errorbase:=bp;
   Halt(errorcode);
 end;
 
@@ -1283,7 +1305,7 @@ procedure fpc_AbstractErrorIntern;compilerproc;[public,alias : 'FPC_ABSTRACTERRO
 begin
   If pointer(AbstractErrorProc)<>nil then
     AbstractErrorProc();
-  HandleErrorAddrFrame(211,get_addr,get_frame);
+  HandleErrorAddrFrame(211,get_pc_addr,get_frame);
 end;
 
 
@@ -1293,7 +1315,7 @@ begin
   if pointer(AssertErrorProc)<>nil then
     AssertErrorProc(Msg,FName,LineNo,ErrorAddr)
   else
-    HandleErrorAddrFrame(227,get_addr,get_frame);
+    HandleErrorAddrFrame(227,get_pc_addr,get_frame);
 end;
 
 

rtl/inc/systemh.inc

@@ -1066,10 +1066,11 @@ function get_caller_frame(framebp:pointer;addr:pointer=nil):pointer;[INTERNPROC:
 function get_frame:pointer;{$ifdef SYSTEMINLINE}inline;{$endif}
 {$ENDIF}
 
-Function Get_addr : Pointer;
+Function Get_pc_addr : Pointer;
 
 function get_caller_addr(framebp:pointer;addr:pointer=nil):pointer;
 function get_caller_frame(framebp:pointer;addr:pointer=nil):pointer;
+procedure get_caller_stackinfo(var framebp,addr : pointer);
 
 Function IOResult:Word;
 Function Sptr:Pointer;[internconst:fpc_in_const_ptr];

rtl/mips/mips.inc

@@ -74,21 +74,96 @@ function get_frame:pointer;assembler;nostackframe;
   end;
 
 
-{$define FPC_SYSTEM_HAS_GET_CALLER_ADDR}
-function get_caller_addr(framebp:pointer;addr:pointer=nil):pointer;assembler;nostackframe;
-  asm
-    // lw $2,4($4) // #movl    4(%eax),%eax
-    lui $2,0
+{ Try to find previous $fp,$ra register pair
+  reset both to nil if failure }
+{$define FPC_SYSTEM_HAS_GET_CALLER_STACKINFO}
+procedure get_caller_stackinfo(var framebp,addr : pointer);
+const
+  instr_size = 4;
+  MAX_INSTRUCTIONS = 64000;
+type
+  instr_p = pdword;
+  reg_p = ppointer;
+var
+  instr,stackpos : dword;
+  i,LocalSize : longint;
+  ra_offset, s8_offset : longint;
+  current_ra : pointer;
+begin
+  { Here we need to use GDB approach,
+    starting at addr
+    go back to lower $ra values until we find a
+    position with ADDIU $sp,$sp,-LocalSize
+  }
+  Try
+    current_ra:=addr;
+    ra_offset:=-1;
+    s8_offset:=-1;
+    i:=0;
+    LocalSize:=0;
+    repeat
+      inc(i);
+      dec(current_ra,4);
+      instr:=instr_p(current_ra)^;
+      if (instr shr 16 = $27bd) then
+        begin
+          { we found the instruction,
+            local size is the lo part }
+          LocalSize:=smallint(instr and $ffff);
+          break;
+        end;
+    until i> MAX_INSTRUCTIONS;
+    if LocalSize <> 0 then
+      begin
+        repeat
+          inc(current_ra,4);
+          instr:=instr_p(current_ra)^;
+          if (instr shr 16 = $afbf) then
+            ra_offset:=smallint(instr and $ffff)
+          else if (instr shr 16 = $afbe) then
+            s8_offset:=smallint(instr and $ffff);
+        until (current_ra >= addr)
+          or ((ra_offset<>-1) and (s8_offset<>-1));
+        if ra_offset<>-1 then
+          begin
+            stackpos:=dword(framebp+LocalSize+ra_offset);
+            addr:=reg_p(stackpos)^;
+          end
+        else
+          addr:=nil;
+        if s8_offset<>-1 then
+          begin
+            stackpos:=dword(framebp+LocalSize+s8_offset);
+            framebp:=reg_p(stackpos)^;
+          end
+        else
+          framebp:=nil;
+      end;
+  Except
+    framebp:=nil;
+    addr:=nil;
   end;
+end;
+
+{$define FPC_SYSTEM_HAS_GET_PC_ADDR}
+function get_pc_addr : pointer;assembler;nostackframe;
+asm
+  move $2,$31
+end;
 
+{$define FPC_SYSTEM_HAS_GET_CALLER_ADDR}
+function get_caller_addr(framebp:pointer;addr:pointer=nil):pointer;
+begin
+  get_caller_stackinfo(framebp,addr);
+  get_caller_addr:=addr;
+end;
 
 {$define FPC_SYSTEM_HAS_GET_CALLER_FRAME}
-function get_caller_frame(framebp:pointer;addr:pointer=nil):pointer;assembler;nostackframe;
-  asm
-    // lw $2,0($4) // #movl    (%eax),%eax
-    lui $2,0
-  end;
-
+function get_caller_frame(framebp:pointer;addr:pointer=nil):pointer;
+begin
+  get_caller_stackinfo(framebp,addr);
+  get_caller_frame:=framebp;
+end;
 
 {$define FPC_SYSTEM_HAS_SPTR}
 function Sptr:Pointer;assembler;nostackframe;

rtl/x86_64/x86_64.inc

@@ -35,8 +35,8 @@ asm
 end;
 {$ENDIF not INTERNAL_BACKTRACE}
 
-{$define FPC_SYSTEM_HAS_GET_ADDR}
-function get_addr:pointer;assembler;
+{$define FPC_SYSTEM_HAS_GET_PC_ADDR}
+function get_pc_addr:pointer;assembler;
 asm
         movq    (%rsp),%rax
 end;