X-Git-Url: http://repo.macrolet.net/gitweb/?a=blobdiff_plain;f=src%2Fcode%2Fdebug-int.lisp;h=9dbacc830d53b6eba9952672c4c32bc7e8459925;hb=d656401927393487e28e1b765f868822370c1be3;hp=d261c82a4c13c024b03f2e11cc351ed46d2e50a5;hpb=cab2c71bb1bb8a575d9eebdae335e731daa64183;p=sbcl.git diff --git a/src/code/debug-int.lisp b/src/code/debug-int.lisp index d261c82..9dbacc8 100644 --- a/src/code/debug-int.lisp +++ b/src/code/debug-int.lisp @@ -527,15 +527,19 @@ #!-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* ((control-stack-start + (descriptor-sap sb!vm::*control-stack-start*)) + (control-stack-end + (descriptor-sap sb!vm::*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) @@ -624,11 +628,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 +715,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 @@ -882,15 +886,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 +931,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 +1520,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 @@ -2051,7 +2057,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 @@ -2861,7 +2867,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)))))