X-Git-Url: http://repo.macrolet.net/gitweb/?a=blobdiff_plain;f=src%2Fcode%2Fdebug-int.lisp;h=9964063c1915c3314192dbe9b38bd45230033c7e;hb=77d94d36bcfd3d5eea73ad51e6ee621a8938f995;hp=db17f755f50f806b2210027a273dcd1a4c276d86;hpb=aca45f35fc54bc29e2c79397e3538ff27f6e0db9;p=sbcl.git diff --git a/src/code/debug-int.lisp b/src/code/debug-int.lisp index db17f75..9964063 100644 --- a/src/code/debug-int.lisp +++ b/src/code/debug-int.lisp @@ -41,17 +41,6 @@ "All DEBUG-CONDITIONs inherit from this type. These are serious conditions that must be handled, but they are not programmer errors.")) -(define-condition no-debug-info (debug-condition) - ((code-component :reader no-debug-info-code-component - :initarg :code-component)) - #!+sb-doc - (:documentation "There is no usable debugging information available.") - (:report (lambda (condition stream) - (fresh-line stream) - (format stream - "no debug information available for ~S~%" - (no-debug-info-code-component condition))))) - (define-condition no-debug-fun-returns (debug-condition) ((debug-fun :reader no-debug-fun-returns-debug-fun :initarg :debug-fun)) @@ -64,8 +53,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) @@ -507,7 +496,7 @@ ;;;; frames ;;; This is used in FIND-ESCAPED-FRAME and with the bogus components -;;; and LRAs used for :FUN-END breakpoints. When a components +;;; and LRAs used for :FUN-END breakpoints. When a component's ;;; debug-info slot is :BOGUS-LRA, then the REAL-LRA-SLOT contains the ;;; real component to continue executing, as opposed to the bogus ;;; component which appeared in some frame's LRA location. @@ -527,21 +516,24 @@ #!-sb-fluid (declaim (inline control-stack-pointer-valid-p)) (defun control-stack-pointer-valid-p (x) (declare (type system-area-pointer x)) - #!-stack-grows-downward-not-upward - (and (sap< x (current-sp)) - (sap<= (int-sap control-stack-start) - x) - (zerop (logand (sap-int x) #b11))) - #!+stack-grows-downward-not-upward - (and (sap>= x (current-sp)) - (sap> (int-sap control-stack-end) x) - (zerop (logand (sap-int x) #b11)))) + (let* (#!-stack-grows-downward-not-upward + (control-stack-start + (descriptor-sap *control-stack-start*)) + #!+stack-grows-downward-not-upward + (control-stack-end + (descriptor-sap *control-stack-end*))) + #!-stack-grows-downward-not-upward + (and (sap< x (current-sp)) + (sap<= control-stack-start x) + (zerop (logand (sap-int x) #b11))) + #!+stack-grows-downward-not-upward + (and (sap>= x (current-sp)) + (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) @@ -624,11 +616,11 @@ (format t "debug: both still valid ~S ~S ~S ~S~%" lisp-ocfp lisp-ra c-ocfp c-ra)) - #+freebsd + #!+freebsd (if (sap> lisp-ocfp c-ocfp) (values lisp-ra lisp-ocfp) (values c-ra c-ocfp)) - #-freebsd + #!-freebsd (values lisp-ra lisp-ocfp)) (lisp-path-fp ;; The lisp convention is looking good. @@ -711,7 +703,7 @@ (when (control-stack-pointer-valid-p fp) #!+x86 (multiple-value-bind (ra ofp) (x86-call-context fp) - (compute-calling-frame ofp ra frame)) + (and ra (compute-calling-frame ofp ra frame))) #!-x86 (compute-calling-frame #!-alpha @@ -777,6 +769,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 @@ -823,7 +821,8 @@ "undefined function")) (:foreign-function (make-bogus-debug-fun - "foreign function call land")) + (foreign-function-backtrace-name + (int-sap (get-lisp-obj-address lra))))) ((nil) (make-bogus-debug-fun "bogus stack frame")) @@ -844,7 +843,6 @@ (multiple-value-bind (code pc-offset escaped) (find-escaped-frame caller) (/noshow0 "at COND") (cond (code - (/noshow0 "in CODE clause") ;; If it's escaped it may be a function end breakpoint trap. (when (and (code-component-p code) (eq (%code-debug-info code) :bogus-lra)) @@ -853,23 +851,19 @@ code (1+ real-lra-slot))) (setq code (code-header-ref code real-lra-slot)) (aver code))) - (t - (/noshow0 "in T clause") - ;; not escaped + ((not escaped) (multiple-value-setq (pc-offset code) (compute-lra-data-from-pc ra)) (unless code (setf code :foreign-function - pc-offset 0 - escaped nil)))) - + pc-offset 0)))) (let ((d-fun (case code (:undefined-function (make-bogus-debug-fun "undefined function")) (:foreign-function (make-bogus-debug-fun - "foreign function call land")) + (foreign-function-backtrace-name ra))) ((nil) (make-bogus-debug-fun "bogus stack frame")) @@ -882,15 +876,20 @@ (if up-frame (1+ (frame-number up-frame)) 0) escaped))))) +(defun nth-interrupt-context (n) + (declare (type (unsigned-byte 32) n) + (optimize (speed 3) (safety 0))) + (sb!alien:sap-alien (sb!vm::current-thread-offset-sap + (+ sb!vm::thread-interrupt-contexts-offset n)) + (* os-context-t))) + #!+x86 (defun find-escaped-frame (frame-pointer) (declare (type system-area-pointer frame-pointer)) (/noshow0 "entering FIND-ESCAPED-FRAME") (dotimes (index *free-interrupt-context-index* (values nil 0 nil)) - (sb!alien:with-alien - ((lisp-interrupt-contexts (array (* os-context-t) nil) :extern)) (/noshow0 "at head of WITH-ALIEN") - (let ((context (sb!alien:deref lisp-interrupt-contexts index))) + (let ((context (nth-interrupt-context index))) (/noshow0 "got CONTEXT") (when (= (sap-int frame-pointer) (sb!vm:context-register context sb!vm::cfp-offset)) @@ -922,51 +921,80 @@ pc-offset code)) (/noshow0 "returning from FIND-ESCAPED-FRAME") (return - (values code pc-offset context)))))))))) + (values code pc-offset context))))))))) #!-x86 (defun find-escaped-frame (frame-pointer) (declare (type system-area-pointer frame-pointer)) (dotimes (index *free-interrupt-context-index* (values nil 0 nil)) - (sb!alien:with-alien - ((lisp-interrupt-contexts (array (* os-context-t) nil) :extern)) - (let ((scp (sb!alien:deref lisp-interrupt-contexts index))) - (when (= (sap-int frame-pointer) - (sb!vm:context-register scp sb!vm::cfp-offset)) - (without-gcing - (let ((code (code-object-from-bits - (sb!vm:context-register scp sb!vm::code-offset)))) - (when (symbolp code) - (return (values code 0 scp))) - (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))) - ;; Check to see whether we were executing in a branch - ;; delay slot. - #!+(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))) - (return - (if (eq (%code-debug-info code) :bogus-lra) - (let ((real-lra (code-header-ref code - real-lra-slot))) - (values (lra-code-header real-lra) - (get-header-data real-lra) - nil)) - (values code pc-offset scp))))))))))) + (let ((scp (nth-interrupt-context index))) + (when (= (sap-int frame-pointer) + (sb!vm:context-register scp sb!vm::cfp-offset)) + (without-gcing + (let ((code (code-object-from-bits + (sb!vm:context-register scp sb!vm::code-offset)))) + (when (symbolp code) + (return (values code 0 scp))) + (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))) + ;; Check to see whether we were executing in a branch + ;; delay slot. + #!+(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)) + (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 + real-lra-slot))) + (values (lra-code-header real-lra) + (get-header-data real-lra) + 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 @@ -997,8 +1025,11 @@ (defun debug-fun-from-pc (component pc) (let ((info (%code-debug-info component))) (cond - ((not info) - (debug-signal 'no-debug-info :code-component component)) + ((not info) + ;; FIXME: It seems that most of these (at least on x86) are + ;; actually assembler routines, and could be named by looking + ;; at the sb-fasl:*assembler-routines*. + (make-bogus-debug-fun "no debug information for frame")) ((eq info :bogus-lra) (make-bogus-debug-fun "function end breakpoint")) (t @@ -1181,8 +1212,7 @@ (fun-debug-fun (%closure-fun fun))) (#.sb!vm:funcallable-instance-header-widetag (fun-debug-fun (funcallable-instance-fun fun))) - ((#.sb!vm:simple-fun-header-widetag - #.sb!vm:closure-fun-header-widetag) + (#.sb!vm:simple-fun-header-widetag (let* ((name (%simple-fun-name fun)) (component (fun-code-header fun)) (res (find-if @@ -1513,19 +1543,18 @@ (list successors)) (dotimes (k (ldb sb!c::compiled-debug-block-nsucc-byte succ-and-flags)) - (push (sb!c::read-var-integer blocks i) successors)) + (push (sb!c:read-var-integer blocks i) successors)) (let* ((locations - (dotimes (k (sb!c::read-var-integer blocks i) + (dotimes (k (sb!c:read-var-integer blocks i) (result locations-buffer)) (let ((kind (svref sb!c::*compiled-code-location-kinds* (aref+ blocks i))) (pc (+ last-pc - (sb!c::read-var-integer blocks i))) + (sb!c:read-var-integer blocks i))) (tlf-offset (or tlf-number - (sb!c::read-var-integer blocks - i))) - (form-number (sb!c::read-var-integer blocks i)) - (live-set (sb!c::read-packed-bit-vector + (sb!c:read-var-integer blocks i))) + (form-number (sb!c:read-var-integer blocks i)) + (live-set (sb!c:read-packed-bit-vector live-set-len blocks i))) (vector-push-extend (make-known-code-location pc debug-fun tlf-offset @@ -1573,24 +1602,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 @@ -1957,7 +1987,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 @@ -2012,7 +2042,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 @@ -2051,7 +2081,7 @@ (sb!vm:context-float-register escaped (sb!c:sc-offset-offset sc-offset) 'double-float) (sb!vm:context-float-register - escaped (+ (sb!c:sc-offset-offset sc-offset) #!+sparc 2 #-sparc 1) + escaped (+ (sb!c:sc-offset-offset sc-offset) #!+sparc 2 #!-sparc 1) 'double-float)) :invalid-value-for-unescaped-register-storage)) #!+long-float @@ -2102,7 +2132,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))))) @@ -2147,7 +2177,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 @@ -2206,7 +2236,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))))) @@ -2287,7 +2317,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))) @@ -2386,7 +2416,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)) @@ -2421,7 +2451,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))) @@ -2485,7 +2515,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)))) @@ -2773,7 +2803,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))) @@ -2861,7 +2891,7 @@ (do ((frame frame (frame-down frame))) ((not frame) nil) (when (and (compiled-frame-p frame) - (#-x86 eq #+x86 sap= + (#!-x86 eq #!+x86 sap= lra (get-context-value frame lra-save-offset lra-sc-offset))) (return t))))) @@ -3139,9 +3169,9 @@ (breakpoint-do-displaced-inst signal-context (breakpoint-data-instruction data)) ;; Some platforms have no usable sigreturn() call. If your - ;; implementation of arch_do_displaced_inst() doesn't sigreturn(), - ;; add it to this list. - #!-(or hpux irix x86 alpha) + ;; implementation of arch_do_displaced_inst() _does_ sigreturn(), + ;; it's polite to warn here + #!+(and sparc solaris) (error "BREAKPOINT-DO-DISPLACED-INST returned?")))) (defun invoke-breakpoint-hooks (breakpoints component offset) @@ -3224,16 +3254,15 @@ ;;; 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")) (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) @@ -3283,14 +3312,3 @@ ;; (There used to be more cases back before sbcl-0.7.0, when ;; we did special tricks to debug the IR1 interpreter.) )) - -(defun print-code-locations (function) - (let ((debug-fun (fun-debug-fun function))) - (do-debug-fun-blocks (block debug-fun) - (do-debug-block-locations (loc block) - (fill-in-code-location loc) - (format t "~S code location at ~W" - (compiled-code-location-kind loc) - (compiled-code-location-pc loc)) - (sb!debug::print-code-location-source-form loc 0) - (terpri)))))