0.8.13.69:

[sbcl.git] / src / code / debug-int.lisp

diff --git a/src/code/debug-int.lisp b/src/code/debug-int.lisp
index eb0a395..320c7c3 100644 (file)
--- 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-debug-name (sap)
+  (multiple-value-bind (name file base offset) (foreign-symbol-in-address sap)
+    (if name
+       (format nil "foreign function: ~A [~A: #x~X + #x~X]" name file base offset)
+       (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,7 @@
                           "undefined function"))
                         (:foreign-function
                          (make-bogus-debug-fun
-                          (format nil "foreign function call land:")))
+                          (foreign-function-debug-name (int-sap (get-lisp-obj-address lra)))))
                         ((nil)
                          (make-bogus-debug-fun
                           "bogus stack frame"))
@@ -871,9 +877,7 @@
                      (make-bogus-debug-fun
                       "undefined function"))
                     (:foreign-function
-                     (make-bogus-debug-fun
-                      (format nil "foreign function call land: ra=#x~X"
-                                  (sap-int ra))))
+                     (make-bogus-debug-fun (foreign-function-debug-name ra)))
                     ((nil)
                      (make-bogus-debug-fun
                       "bogus stack frame"))
@@ -948,24 +952,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 +997,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.