(#.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
"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"))
(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"))
(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
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.
(let* ((len (length vars))
(width (length (format nil "~W" (1- len)))))
(dotimes (i len)
- (setf (compiled-debug-var-symbol (svref vars i))
- (intern (format nil "ARG-~V,'0D" width i)
- ;; KLUDGE: It's somewhat nasty to have a bare
- ;; package name string here. It would be
- ;; nicer to have #.(FIND-PACKAGE "SB!DEBUG")
- ;; instead, since then at least it would transform
- ;; correctly under package renaming and stuff.
- ;; However, genesis can't handle dumped packages..
- ;; -- WHN 20000129
- ;;
- ;; FIXME: Maybe this could be fixed by moving the
- ;; whole debug-int.lisp file to warm init? (after
- ;; which dumping a #.(FIND-PACKAGE ..) expression
- ;; would work fine) If this is possible, it would
- ;; probably be a good thing, since minimizing the
- ;; amount of stuff in cold init is basically good.
- (or (find-package "SB-DEBUG")
- (find-package "SB!DEBUG")))))))
+ (without-package-locks
+ (setf (compiled-debug-var-symbol (svref vars i))
+ (intern (format nil "ARG-~V,'0D" width i)
+ ;; KLUDGE: It's somewhat nasty to have a bare
+ ;; package name string here. It would be
+ ;; nicer to have #.(FIND-PACKAGE "SB!DEBUG")
+ ;; instead, since then at least it would transform
+ ;; correctly under package renaming and stuff.
+ ;; However, genesis can't handle dumped packages..
+ ;; -- WHN 20000129
+ ;;
+ ;; FIXME: Maybe this could be fixed by moving the
+ ;; whole debug-int.lisp file to warm init? (after
+ ;; which dumping a #.(FIND-PACKAGE ..) expression
+ ;; would work fine) If this is possible, it would
+ ;; probably be a good thing, since minimizing the
+ ;; amount of stuff in cold init is basically good.
+ (or (find-package "SB-DEBUG")
+ (find-package "SB!DEBUG"))))))))
;;; Parse the packed representation of DEBUG-VARs from
;;; DEBUG-FUN's SB!C::COMPILED-DEBUG-FUN, returning a vector
projects / sbcl.git / blobdiff