X-Git-Url: http://repo.macrolet.net/gitweb/?a=blobdiff_plain;f=src%2Fcode%2Fdebug-int.lisp;h=ac460c3fc88a91797b20291d2726f75153d4e63a;hb=f3491f128307938cc56367f739b8fbf9e5d503b6;hp=f0e34f8a7e026bae84a68093300b72477d3b81eb;hpb=c2404a2f430ecf57897a795202625dff4764c18d;p=sbcl.git diff --git a/src/code/debug-int.lisp b/src/code/debug-int.lisp index f0e34f8..ac460c3 100644 --- a/src/code/debug-int.lisp +++ b/src/code/debug-int.lisp @@ -527,17 +527,19 @@ #!-stack-grows-downward-not-upward (and (sap< x (current-sp)) (sap<= control-stack-start x) - (or (not aligned) (zerop (logand (sap-int x) sb!vm:fixnum-tag-mask)))) + (or (not aligned) (zerop (logand (sap-int x) + (1- (ash 1 sb!vm:word-shift)))))) #!+stack-grows-downward-not-upward (and (sap>= x (current-sp)) (sap> control-stack-end x) - (or (not aligned) (zerop (logand (sap-int x) sb!vm:fixnum-tag-mask)))))) + (or (not aligned) (zerop (logand (sap-int x) + (1- (ash 1 sb!vm:word-shift)))))))) (declaim (inline component-ptr-from-pc)) (sb!alien:define-alien-routine component-ptr-from-pc (system-area-pointer) (pc system-area-pointer)) -#!+gencgc +(declaim (inline valid-lisp-pointer-p)) (sb!alien:define-alien-routine valid-lisp-pointer-p sb!alien:int (pointer system-area-pointer)) @@ -634,7 +636,8 @@ (when saved-fp (compute-calling-frame (descriptor-sap saved-fp) (descriptor-sap saved-pc) - up-frame)))) + up-frame + t)))) ;;; Return the frame immediately below FRAME on the stack; or when ;;; FRAME is the bottom of the stack, return NIL. @@ -788,13 +791,14 @@ escaped)))))) #!+(or x86 x86-64) -(defun compute-calling-frame (caller ra up-frame) +(defun compute-calling-frame (caller ra up-frame &optional savedp) (declare (type system-area-pointer caller ra)) (/noshow0 "entering COMPUTE-CALLING-FRAME") (when (control-stack-pointer-valid-p caller) (/noshow0 "in WHEN") ;; First check for an escaped frame. - (multiple-value-bind (code pc-offset escaped) (find-escaped-frame caller) + (multiple-value-bind (code pc-offset escaped off-stack) + (find-escaped-frame caller) (/noshow0 "at COND") (cond (code ;; If it's escaped it may be a function end breakpoint trap. @@ -828,7 +832,11 @@ (code-location-from-pc d-fun pc-offset escaped) (if up-frame (1+ (frame-number up-frame)) 0) - escaped))))) + ;; If we have an interrupt-context that's not on + ;; our stack at all, and we're computing the + ;; from from a saved FP, we're probably looking + ;; at an interrupted syscall. + (or escaped (and savedp off-stack))))))) (defun nth-interrupt-context (n) (declare (type (unsigned-byte 32) n) @@ -844,101 +852,101 @@ (declare (type system-area-pointer frame-pointer)) (/noshow0 "entering FIND-ESCAPED-FRAME") (dotimes (index *free-interrupt-context-index* (values nil 0 nil)) - (/noshow0 "at head of WITH-ALIEN") - (let ((context (nth-interrupt-context index))) - (/noshow0 "got CONTEXT") - (when (= (sap-int frame-pointer) - (sb!vm:context-register context sb!vm::cfp-offset)) - (without-gcing - (/noshow0 "in WITHOUT-GCING") - (let* ((component-ptr (component-ptr-from-pc - (sb!vm:context-pc context))) - (code (unless (sap= component-ptr (int-sap #x0)) - (component-from-component-ptr component-ptr)))) - (/noshow0 "got CODE") - (when (null code) - (return (values code 0 context))) - (let* ((code-header-len (* (get-header-data code) - sb!vm:n-word-bytes)) - (pc-offset + (let* ((context (nth-interrupt-context index)) + (cfp (int-sap (sb!vm:context-register context sb!vm::cfp-offset)))) + (/noshow0 "got CONTEXT") + (unless (control-stack-pointer-valid-p cfp) + (return (values nil nil nil t))) + (when (sap= frame-pointer cfp) + (without-gcing + (/noshow0 "in WITHOUT-GCING") + (let* ((component-ptr (component-ptr-from-pc + (sb!vm:context-pc context))) + (code (unless (sap= component-ptr (int-sap #x0)) + (component-from-component-ptr component-ptr)))) + (/noshow0 "got CODE") + (when (null code) + (return (values code 0 context))) + (let* ((code-header-len (* (get-header-data code) + sb!vm:n-word-bytes)) + (pc-offset (- (sap-int (sb!vm:context-pc context)) (- (get-lisp-obj-address code) sb!vm:other-pointer-lowtag) code-header-len))) - (/noshow "got PC-OFFSET") - (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. - ;; - ;; FIXME: Should this be WARN or ERROR or what? - (format t "** pc-offset ~S not in code obj ~S?~%" - pc-offset code)) - (/noshow0 "returning from FIND-ESCAPED-FRAME") - (return - (values code pc-offset context))))))))) + (/noshow "got PC-OFFSET") + (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. + ;; + ;; FIXME: Should this be WARN or ERROR or what? + (format t "** pc-offset ~S not in code obj ~S?~%" + pc-offset code)) + (/noshow0 "returning from FIND-ESCAPED-FRAME") + (return + (values code pc-offset context))))))))) #!-(or x86 x86-64) (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)) - (/noshow0 "at head of WITH-ALIEN") (let ((scp (nth-interrupt-context index))) - (/noshow0 "got SCP") + (/noshow0 "got SCP") (when (= (sap-int frame-pointer) (sb!vm:context-register scp sb!vm::cfp-offset)) (without-gcing - (/noshow0 "in WITHOUT-GCING") - (let ((code (code-object-from-bits - (sb!vm:context-register scp sb!vm::code-offset)))) - (/noshow0 "got CODE") - (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))) - (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))))) - (/noshow0 "returning from FIND-ESCAPED-FRAME") - (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)))))))))) + :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))))) + (/noshow0 "returning from FIND-ESCAPED-FRAME") + (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)))))))))) #!-(or x86 x86-64) (defun find-pc-from-assembly-fun (code scp) @@ -1978,21 +1986,7 @@ register." ;; unbound marker (= val sb!vm:unbound-marker-widetag) ;; pointer - #!+gencgc - (not (zerop (valid-lisp-pointer-p (int-sap val)))) - ;; FIXME: There is no fundamental reason not to use the above - ;; function on other platforms as well, but I didn't have - ;; others available while doing this. --NS 2007-06-21 - #!-gencgc - (and (logbitp 0 val) - (or (< sb!vm:read-only-space-start val - (* sb!vm:*read-only-space-free-pointer* - sb!vm:n-word-bytes)) - (< sb!vm:static-space-start val - (* sb!vm:*static-space-free-pointer* - sb!vm:n-word-bytes)) - (< (current-dynamic-space-start) val - (sap-int (dynamic-space-free-pointer)))))) + (not (zerop (valid-lisp-pointer-p (int-sap val))))) (values (%make-lisp-obj val) t) (if errorp (error "~S is not a valid argument to ~S" @@ -3143,20 +3137,10 @@ register." #!-(or x86 x86-64) (let ((new-lra (make-lisp-obj (+ (sap-int dst-start) sb!vm:other-pointer-lowtag)))) - #!-(or gencgc ppc) - (progn - ;; Set the offset from the LRA to the enclosing component. - ;; This does not need to be done on GENCGC targets, as the - ;; pointer validation done in MAKE-LISP-OBJ requires that it - ;; already have been set before we get here. It does not - ;; need to be done on CHENEYGC PPC as it's easier to use the - ;; same fun_end_breakpoint_guts on both, including the LRA - ;; header. - (set-header-data - new-lra - (logandc2 (+ sb!vm:code-constants-offset bogus-lra-constants 1) - 1)) - (sb!vm:sanctify-for-execution code-object)) + ;; We used to set the header value of the LRA here to the + ;; offset from the enclosing component to the LRA header, but + ;; MAKE-LISP-OBJ actually checks the value before we get a + ;; chance to set it, so it's now done in arch-assem.S. (values new-lra code-object (sap- trap-loc src-start)))))) ;;;; miscellaneous