X-Git-Url: http://repo.macrolet.net/gitweb/?a=blobdiff_plain;f=src%2Fcode%2Fdebug-int.lisp;h=d839476360d4a4fce98ebd30ec320e1fe68b4d99;hb=15d6e7c9a2c3234f95dfe278046fa2fee1b0c007;hp=eb0a3953a76178ee3c8b200bcd55837d154e7d6b;hpb=ff92598854bf7cae8d57fe49cef4d9a98e1ab345;p=sbcl.git

diff --git a/src/code/debug-int.lisp b/src/code/debug-int.lisp
index eb0a395..d839476 100644
--- a/src/code/debug-int.lisp
+++ b/src/code/debug-int.lisp
@@ -780,6 +780,12 @@
 	  (#.lra-save-offset
 	   (setf (sap-ref-sap pointer (- (* (1+ stack-slot) 4))) value))))))
 
+(defun foreign-function-backtrace-name (sap)
+  (let ((name (foreign-symbol-in-address sap)))
+    (if name
+	(format nil "foreign function: ~A" name)
+	(format nil "foreign function: #x~X" (sap-int sap)))))
+
 ;;; This returns a frame for the one existing in time immediately
 ;;; prior to the frame referenced by current-fp. This is current-fp's
 ;;; caller or the next frame down the control stack. If there is no
@@ -826,7 +832,8 @@
 			   "undefined function"))
 			 (:foreign-function
 			  (make-bogus-debug-fun
-			   (format nil "foreign function call land:")))
+			   (foreign-function-backtrace-name
+			    (int-sap (get-lisp-obj-address lra)))))
 			 ((nil)
 			  (make-bogus-debug-fun
 			   "bogus stack frame"))
@@ -872,8 +879,7 @@
 		       "undefined function"))
 		     (:foreign-function
 		      (make-bogus-debug-fun
-		       (format nil "foreign function call land: ra=#x~X"
-				   (sap-int ra))))
+		       (foreign-function-backtrace-name ra)))
 		     ((nil)
 		      (make-bogus-debug-fun
 		       "bogus stack frame"))
@@ -948,24 +954,42 @@
 	   (let* ((code-header-len (* (get-header-data code)
 				      sb!vm:n-word-bytes))
 		  (pc-offset
-                    (- (sap-int (sb!vm:context-pc scp))
-                       (- (get-lisp-obj-address code)
-                          sb!vm:other-pointer-lowtag)
-                       code-header-len)))
+                   (- (sap-int (sb!vm:context-pc scp))
+                      (- (get-lisp-obj-address code)
+                         sb!vm:other-pointer-lowtag)
+                      code-header-len)))
 	     ;; Check to see whether we were executing in a branch
 	     ;; delay slot.
-	     #!+(or pmax sgi) ; pmax only (and broken anyway)
+	     #!+(or pmax sgi)          ; pmax only (and broken anyway)
 	     (when (logbitp 31 (sb!alien:slot scp '%mips::sc-cause))
 	       (incf pc-offset sb!vm:n-word-bytes))
-	     (unless (<= 0 pc-offset
-			 (* (code-header-ref code sb!vm:code-code-size-slot)
-			    sb!vm:n-word-bytes))
-	       ;; We were in an assembly routine. Therefore, use the
-	       ;; LRA as the pc.
-	       (setf pc-offset
-		     (- (sb!vm:context-register scp sb!vm::lra-offset)
-			(get-lisp-obj-address code)
-			code-header-len)))
+	     (let ((code-size (* (code-header-ref code 
+                                                  sb!vm:code-code-size-slot)
+                                 sb!vm:n-word-bytes)))
+               (unless (<= 0 pc-offset code-size)
+                 ;; We were in an assembly routine.
+                 (multiple-value-bind (new-pc-offset computed-return)
+                     (find-pc-from-assembly-fun code scp)
+                   (setf pc-offset new-pc-offset)
+                   (unless (<= 0 pc-offset code-size)
+                     (cerror
+		      "Set PC-OFFSET to zero and continue backtrace."
+		      'bug
+		      :format-control
+		      "~@<PC-OFFSET (~D) not in code object. Frame details:~
+                       ~2I~:@_PC: #X~X~:@_CODE: ~S~:@_CODE FUN: ~S~:@_LRA: ~
+                       #X~X~:@_COMPUTED RETURN: #X~X.~:>"
+		      :format-arguments
+		      (list pc-offset
+			    (sap-int (sb!vm:context-pc scp))
+			    code
+			    (%code-entry-points code)
+			    (sb!vm:context-register scp sb!vm::lra-offset)
+			    computed-return))
+                     ;; We failed to pinpoint where PC is, but set
+                     ;; pc-offset to 0 to keep the backtrace from
+                     ;; exploding.
+		     (setf pc-offset 0)))))
 	     (return
 	       (if (eq (%code-debug-info code) :bogus-lra)
 		   (let ((real-lra (code-header-ref code
@@ -975,6 +999,19 @@
 			     nil))
 		   (values code pc-offset scp))))))))))
 
+#!-x86
+(defun find-pc-from-assembly-fun (code scp)
+  "Finds the PC for the return from an assembly routine properly.
+For some architectures (such as PPC) this will not be the $LRA
+register."
+  (let ((return-machine-address (sb!vm::return-machine-address scp))
+        (code-header-len (* (get-header-data code) sb!vm:n-word-bytes)))
+    (values (- return-machine-address
+	       (- (get-lisp-obj-address code)
+		  sb!vm:other-pointer-lowtag) 
+	       code-header-len)
+	    return-machine-address)))
+
 ;;; Find the code object corresponding to the object represented by
 ;;; bits and return it. We assume bogus functions correspond to the
 ;;; undefined-function.
@@ -3230,6 +3267,8 @@
 ;;; instruction.
 (defun make-bogus-lra (real-lra &optional known-return-p)
   (without-gcing
+   ;; These are really code labels, not variables: but this way we get
+   ;; their addresses.
    (let* ((src-start (foreign-symbol-address "fun_end_breakpoint_guts"))
 	  (src-end (foreign-symbol-address "fun_end_breakpoint_end"))
 	  (trap-loc (foreign-symbol-address "fun_end_breakpoint_trap"))