;;;; 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.
#!-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)
(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
"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"))
"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"))
(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))
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
(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
;; (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)))))
projects / sbcl.git / blobdiff