X-Git-Url: http://repo.macrolet.net/gitweb/?a=blobdiff_plain;f=src%2Fcode%2Fdebug-int.lisp;h=270c9d9b8e17f0f25bb3d55c31d928ddd7cd5ea4;hb=2b596efa9a6b08a22bbdcdf88198c5d2af1d0335;hp=c0a1517a3ee459f1f7bf2cb2719d687db445e862;hpb=4df3887d4f74248fb2ce830b86eb07fd30986d8a;p=sbcl.git diff --git a/src/code/debug-int.lisp b/src/code/debug-int.lisp index c0a1517..270c9d9 100644 --- a/src/code/debug-int.lisp +++ b/src/code/debug-int.lisp @@ -507,7 +507,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,15 +527,20 @@ #!-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) @@ -711,7 +716,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 @@ -823,7 +828,7 @@ "undefined function")) (:foreign-function (make-bogus-debug-fun - "foreign function call land")) + (format nil "foreign function call land:"))) ((nil) (make-bogus-debug-fun "bogus stack frame")) @@ -869,7 +874,8 @@ "undefined function")) (:foreign-function (make-bogus-debug-fun - "foreign function call land")) + (format nil "foreign function call land: ra=#x~X" + (sap-int ra)))) ((nil) (make-bogus-debug-fun "bogus stack frame")) @@ -882,15 +888,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 +933,49 @@ 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 + (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)) - (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))))))))))) + ;; 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)))))))))) ;;; Find the code object corresponding to the object represented by ;;; bits and return it. We assume bogus functions correspond to the @@ -1513,19 +1522,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