X-Git-Url: http://repo.macrolet.net/gitweb/?a=blobdiff_plain;ds=sidebyside;f=src%2Fcode%2Fdebug-int.lisp;h=67d0a59933847b9d233c7ebde10e286cfea4326e;hb=129b26c117d41c21663f07e9017871b56fafa501;hp=eb0a3953a76178ee3c8b200bcd55837d154e7d6b;hpb=ff92598854bf7cae8d57fe49cef4d9a98e1ab345;p=sbcl.git diff --git a/src/code/debug-int.lisp b/src/code/debug-int.lisp index eb0a395..67d0a59 100644 --- a/src/code/debug-int.lisp +++ b/src/code/debug-int.lisp @@ -64,8 +64,8 @@ (no-debug-fun-returns-debug-fun condition)))) (format stream "~&Cannot return values from ~:[frame~;~:*~S~] since ~ - the debug information lacks details about returning ~ - values here." + the debug information lacks details about returning ~ + values here." fun))))) (define-condition no-debug-blocks (debug-condition) @@ -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 + "~@" + :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. @@ -1963,7 +2000,7 @@ (zerop (logand val 3)) ;; character (and (zerop (logand val #xffff0000)) ; Top bits zero - (= (logand val #xff) sb!vm:base-char-widetag)) ; char tag + (= (logand val #xff) sb!vm:character-widetag)) ; char tag ;; unbound marker (= val sb!vm:unbound-marker-widetag) ;; pointer @@ -2018,7 +2055,7 @@ (sb!sys:without-gcing (with-escaped-value (val) (sb!kernel:make-lisp-obj val)))) - (#.sb!vm:base-char-reg-sc-number + (#.sb!vm:character-reg-sc-number (with-escaped-value (val) (code-char val))) (#.sb!vm:sap-reg-sc-number @@ -2108,7 +2145,7 @@ sb!vm:n-word-bytes))))) (#.sb!vm:control-stack-sc-number (sb!kernel:stack-ref fp (sb!c:sc-offset-offset sc-offset))) - (#.sb!vm:base-char-stack-sc-number + (#.sb!vm:character-stack-sc-number (with-nfp (nfp) (code-char (sb!sys:sap-ref-32 nfp (* (sb!c:sc-offset-offset sc-offset) sb!vm:n-word-bytes))))) @@ -2153,7 +2190,7 @@ (without-gcing (with-escaped-value (val) (make-valid-lisp-obj val)))) - (#.sb!vm:base-char-reg-sc-number + (#.sb!vm:character-reg-sc-number (with-escaped-value (val) (code-char val))) (#.sb!vm:sap-reg-sc-number @@ -2212,7 +2249,7 @@ sb!vm:n-word-bytes))))) (#.sb!vm:control-stack-sc-number (stack-ref fp (sb!c:sc-offset-offset sc-offset))) - (#.sb!vm:base-char-stack-sc-number + (#.sb!vm:character-stack-sc-number (code-char (sap-ref-32 fp (- (* (1+ (sb!c:sc-offset-offset sc-offset)) sb!vm:n-word-bytes))))) @@ -2293,7 +2330,7 @@ (without-gcing (set-escaped-value (get-lisp-obj-address value)))) - (#.sb!vm:base-char-reg-sc-number + (#.sb!vm:character-reg-sc-number (set-escaped-value (char-code value))) (#.sb!vm:sap-reg-sc-number (set-escaped-value (sap-int value))) @@ -2392,7 +2429,7 @@ (the long-float (realpart value))))) (#.sb!vm:control-stack-sc-number (setf (stack-ref fp (sb!c:sc-offset-offset sc-offset)) value)) - (#.sb!vm:base-char-stack-sc-number + (#.sb!vm:character-stack-sc-number (with-nfp (nfp) (setf (sap-ref-32 nfp (* (sb!c:sc-offset-offset sc-offset) sb!vm:n-word-bytes)) @@ -2427,7 +2464,7 @@ (without-gcing (set-escaped-value (get-lisp-obj-address value)))) - (#.sb!vm:base-char-reg-sc-number + (#.sb!vm:character-reg-sc-number (set-escaped-value (char-code value))) (#.sb!vm:sap-reg-sc-number (set-escaped-value (sap-int value))) @@ -2491,7 +2528,7 @@ (imagpart (the (complex long-float) value)))) (#.sb!vm:control-stack-sc-number (setf (stack-ref fp (sb!c:sc-offset-offset sc-offset)) value)) - (#.sb!vm:base-char-stack-sc-number + (#.sb!vm:character-stack-sc-number (setf (sap-ref-32 fp (- (* (1+ (sb!c:sc-offset-offset sc-offset)) sb!vm:n-word-bytes))) (char-code (the character value)))) @@ -2779,7 +2816,7 @@ (compiled-debug-fun-compiler-debug-fun what)) :standard) (error ":FUN-END breakpoints are currently unsupported ~ - for the known return convention.")) + for the known return convention.")) (let* ((bpt (%make-breakpoint hook-fun what kind info)) (starter (compiled-debug-fun-end-starter what))) @@ -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"))