0.8.13.17:

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

diff --git a/src/code/debug-int.lisp b/src/code/debug-int.lisp
index 7134607..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"))
@@ -998,19 +1002,13 @@
   "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
-         ;; This conditional logic should probably go into
-         ;; architecture specific files somehow.
-         #!+ppc (sap-int (sb!vm::context-lr scp))
-         #!-(or ppc) (- (sb!vm:context-register scp sb!vm::lra-offset)
-                        sb!vm:other-pointer-lowtag))
-        (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)))
+  (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