X-Git-Url: http://repo.macrolet.net/gitweb/?a=blobdiff_plain;f=src%2Fcode%2Fdebug-int.lisp;h=320c7c3f5b15d971a8f19d36791c0995b467a4ab;hb=4281f3b99891120fea5cabbc3a9d091b19f45995;hp=d05a3dab8a10234ffdc0eeebc138915fce58ace7;hpb=9c9c68bd6e5e3c6d02e9f1bfd583b87bb9e85eea;p=sbcl.git diff --git a/src/code/debug-int.lisp b/src/code/debug-int.lisp index d05a3da..320c7c3 100644 --- a/src/code/debug-int.lisp +++ b/src/code/debug-int.lisp @@ -542,11 +542,9 @@ (sap> control-stack-end x) (zerop (logand (sap-int x) #b11))))) -#!+x86 (sb!alien:define-alien-routine component-ptr-from-pc (system-area-pointer) (pc system-area-pointer)) -#!+x86 (defun component-from-component-ptr (component-ptr) (declare (type system-area-pointer component-ptr)) (make-lisp-obj (logior (sap-int component-ptr) @@ -782,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 @@ -828,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")) @@ -873,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")) @@ -950,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 + "~@" + :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 @@ -977,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. @@ -1580,24 +1613,25 @@ (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 @@ -3236,11 +3270,8 @@ (trap-loc (foreign-symbol-address "fun_end_breakpoint_trap")) (length (sap- src-end src-start)) (code-object - (%primitive - #!-(and x86 gencgc) sb!c:allocate-code-object - #!+(and x86 gencgc) sb!c::allocate-dynamic-code-object - (1+ bogus-lra-constants) - length)) + (%primitive sb!c:allocate-code-object (1+ bogus-lra-constants) + length)) (dst-start (code-instructions code-object))) (declare (type system-area-pointer src-start src-end dst-start trap-loc)