(:include frame)
(:constructor make-compiled-frame
(pointer up debug-function code-location number
- #!+gengc saved-state-chain
&optional escaped))
(:copier nil))
;; This indicates whether someone interrupted the frame.
;; (unexported). If escaped, this is a pointer to the state that was
- ;; saved when we were interrupted. On the non-gengc system, this is
- ;; a pointer to an os_context_t, i.e. the third argument to an
- ;; SA_SIGACTION-style signal handler. On the gengc system, this is a
- ;; state pointer from SAVED-STATE-CHAIN.
- escaped
- ;; a list of SAPs to saved states. Each time we unwind past an
- ;; exception, we pop the next entry off this list. When we get to
- ;; the end of the list, there is nothing else on the stack.
- #!+gengc (saved-state-chain nil :type list))
+ ;; saved when we were interrupted, an os_context_t, i.e. the third
+ ;; argument to an SA_SIGACTION-style signal handler.
+ escaped)
(def!method print-object ((obj compiled-frame) str)
(print-unreadable-object (obj str :type t)
(format str
(declare (type system-area-pointer x))
#!-x86 ; stack grows toward high address values
(and (sap< x (current-sp))
- (sap<= #!-gengc (int-sap control-stack-start)
- #!+gengc (mutator-control-stack-base)
+ (sap<= (int-sap control-stack-start)
x)
(zerop (logand (sap-int x) #b11)))
#!+x86 ; stack grows toward low address values
;;; Return the top frame of the control stack as it was before calling
;;; this function.
(defun top-frame ()
+ (/show0 "entering TOP-FRAME")
(multiple-value-bind (fp pc) (%caller-frame-and-pc)
(possibly-an-interpreted-frame
- (compute-calling-frame (descriptor-sap fp)
- #!-gengc pc #!+gengc (descriptor-sap pc)
- nil)
+ (compute-calling-frame (descriptor-sap fp) pc nil)
nil)))
;;; Flush all of the frames above FRAME, and renumber all the frames
;;; Return the frame immediately below FRAME on the stack; or when
;;; FRAME is the bottom of the stack, return NIL.
(defun frame-down (frame)
+ (/show0 "entering FRAME-DOWN")
;; We have to access the old-fp and return-pc out of frame and pass
;; them to COMPUTE-CALLING-FRAME.
(let ((down (frame-%down frame)))
(if (eq down :unparsed)
(let* ((real (frame-real-frame frame))
(debug-fun (frame-debug-function real)))
+ (/show0 "in DOWN :UNPARSED case")
(setf (frame-%down frame)
(etypecase debug-fun
(compiled-debug-function
(get-context-value
real sb!vm::ocfp-save-offset
(sb!c::compiled-debug-function-old-fp c-d-f)))
- #!-gengc
(get-context-value
real sb!vm::lra-save-offset
(sb!c::compiled-debug-function-return-pc c-d-f))
- #!+gengc
- (descriptor-sap
- (get-context-value
- real sb!vm::ra-save-offset
- (sb!c::compiled-debug-function-return-pc c-d-f)))
frame)
frame)))
(bogus-debug-function
(sap-ref-32 fp (* sb!vm::ocfp-save-offset
sb!vm:word-bytes)))
- #!-gengc
(stack-ref fp sb!vm::lra-save-offset)
- #!+gengc
- (sap-ref-sap fp (* sb!vm::ra-save-offset
- sb!vm:word-bytes))
+
frame)))))))
down)))
;; new SBCL code, not ambitious enough to do anything tricky like
;; hiding the byte interpreter when debugging
(declare (ignore up-frame))
+ (/show "doing trivial POSSIBLY-AN-INTERPRETED-FRAME")
frame
- ;; old CMU CL code to hide IR1 interpreter when debugging
+ ;; old CMU CL code to hide IR1 interpreter when debugging:
;;
;;(if (or (not frame)
;; (not (eq (debug-function-name (frame-debug-function
#!+x86
(defun compute-calling-frame (caller ra up-frame)
(declare (type system-area-pointer caller ra))
+ (/show0 "entering COMPUTE-CALLING-FRAME")
(when (cstack-pointer-valid-p caller)
+ (/show0 "in WHEN")
;; First check for an escaped frame.
(multiple-value-bind (code pc-offset escaped) (find-escaped-frame caller)
- (cond (code
- ;; 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))
- ;; If :bogus-lra grab the real lra.
- (setq pc-offset (code-header-ref
- code (1+ real-lra-slot)))
- (setq code (code-header-ref code real-lra-slot))
- (aver code)))
- (t
- ;; 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))))
-
- (let ((d-fun (case code
- (:undefined-function
- (make-bogus-debug-function
- "undefined function"))
- (:foreign-function
- (make-bogus-debug-function
- "foreign function call land"))
- ((nil)
- (make-bogus-debug-function
- "bogus stack frame"))
- (t
- (debug-function-from-pc code pc-offset)))))
- (make-compiled-frame caller up-frame d-fun
- (code-location-from-pc d-fun pc-offset
- escaped)
- (if up-frame (1+ (frame-number up-frame)) 0)
- escaped)))))
+ (/show0 "at COND")
+ (cond (code
+ (/show0 "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))
+ ;; If :bogus-lra grab the real lra.
+ (setq pc-offset (code-header-ref
+ code (1+ real-lra-slot)))
+ (setq code (code-header-ref code real-lra-slot))
+ (aver code)))
+ (t
+ (/show0 "in T clause")
+ ;; 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))))
+
+ (let ((d-fun (case code
+ (:undefined-function
+ (make-bogus-debug-function
+ "undefined function"))
+ (:foreign-function
+ (make-bogus-debug-function
+ "foreign function call land"))
+ ((nil)
+ (make-bogus-debug-function
+ "bogus stack frame"))
+ (t
+ (debug-function-from-pc code pc-offset)))))
+ (/show0 "returning MAKE-COMPILED-FRAME from COMPUTE-CALLING-FRAME")
+ (make-compiled-frame caller up-frame d-fun
+ (code-location-from-pc d-fun pc-offset
+ escaped)
+ (if up-frame (1+ (frame-number up-frame)) 0)
+ escaped)))))
#!+x86
(defun find-escaped-frame (frame-pointer)
(declare (type system-area-pointer frame-pointer))
+ (/show0 "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))
+ ((lisp-interrupt-contexts (array (* os-context-t) nil) :extern))
+ (/show0 "at head of WITH-ALIEN")
(let ((context (sb!alien:deref lisp-interrupt-contexts index)))
+ (/show0 "got CONTEXT")
(when (= (sap-int frame-pointer)
(sb!vm:context-register context sb!vm::cfp-offset))
(without-gcing
+ (/show0 "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))))
+ (/show0 "got CODE")
(when (null code)
(return (values code 0 context)))
(let* ((code-header-len (* (get-header-data code)
(- (get-lisp-obj-address code)
sb!vm:other-pointer-type)
code-header-len)))
+ (/show "got PC-OFFSET")
(unless (<= 0 pc-offset
(* (code-header-ref code sb!vm:code-code-size-slot)
sb!vm:word-bytes))
;; FIXME: Should this be WARN or ERROR or what?
(format t "** pc-offset ~S not in code obj ~S?~%"
pc-offset code))
+ (/show0 "returning from FIND-ESCAPED-FRAME")
(return
(values code pc-offset context))))))))))
(lra-code-header object))
(t
nil))))))))
-
-;;; SB!KERNEL:*SAVED-STATE-CHAIN* -- maintained by the C code as a
-;;; list of SAPs, each SAP pointing to a saved exception state.
-#!+gengc
-(declaim (special *saved-state-chain*))
-
-;;; CMU CL had
-;;; (DEFUN LOOKUP-TRACE-TABLE-ENTRY (COMPONENT PC) ..)
-;;; for this case, but it hasn't been maintained in SBCL.
-#!+gengc
-(eval-when (:compile-toplevel :load-toplevel :execute)
- (error "hopelessly stale"))
-
-;;; CMU CL had
-;;; (DEFUN EXTRACT-INFO-FROM-STATE (STATE) ..)
-;;; for this case, but it hasn't been maintained in SBCL.
-#!+gengc
-(eval-when (:compile-toplevel :load-toplevel :execute)
- (error "hopelessly stale"))
-
-;;; CMU CL had
-;;; (DEFUN COMPUTE-CALLING-FRAME (OCFP RA UP-FRAME) ..)
-;;; for this case, but it hasn't been maintained in SBCL.
-#!+gengc
-(eval-when (:compile-toplevel :load-toplevel :execute)
- (error "hopelessly stale"))
\f
;;;; frame utilities
;;; CODE-LOCATIONs at which execution would continue with frame as the
;;; top frame if someone threw to the corresponding tag.
(defun frame-catches (frame)
- (let ((catch
- #!-gengc (descriptor-sap *current-catch-block*)
- #!+gengc (mutator-current-catch-block))
+ (let ((catch (descriptor-sap *current-catch-block*))
(res nil)
(fp (frame-pointer (frame-real-frame frame))))
(loop
(component (component-from-component-ptr
(component-ptr-from-pc ra)))
(offset
- #!-(or gengc x86)
+ #!-x86
(* (- (1+ (get-header-data lra))
(get-header-data component))
sb!vm:word-bytes)
- #!+gengc
- (+ (- (sap-int ra)
- (get-lisp-obj-address component)
- (get-header-data component))
- sb!vm:other-pointer-type)
#!+x86
(- (sap-int ra)
(- (get-lisp-obj-address component)
(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 probably be
- ;; better to have #.(FIND-PACKAGE "SB!DEBUG")
+ ;; 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..
;; 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.
- "SB-DEBUG")))))
+ (or (find-package "SB-DEBUG")
+ (find-package "SB!DEBUG")))))))
;;; Parse the packed representation of DEBUG-VARs from
;;; DEBUG-FUNCTION's SB!C::COMPILED-DEBUG-FUNCTION, returning a vector
;;; of DEBUG-VARs, or NIL if there was no information to parse.
(defun parse-compiled-debug-vars (debug-function)
- (let* ((cdebug-fun (compiled-debug-function-compiler-debug-fun debug-function))
+ (let* ((cdebug-fun (compiled-debug-function-compiler-debug-fun
+ debug-function))
(packed-vars (sb!c::compiled-debug-function-variables cdebug-fun))
(args-minimal (eq (sb!c::compiled-debug-function-arguments cdebug-fun)
:minimal)))
(let* ((flags (geti))
(minimal (logtest sb!c::compiled-debug-var-minimal-p flags))
(deleted (logtest sb!c::compiled-debug-var-deleted-p flags))
- (live (logtest sb!c::compiled-debug-var-environment-live flags))
+ (live (logtest sb!c::compiled-debug-var-environment-live
+ flags))
(save (logtest sb!c::compiled-debug-var-save-loc-p flags))
(symbol (if minimal nil (geti)))
(id (if (logtest sb!c::compiled-debug-var-id-p flags)
(multiple-value-bind (lra component offset)
(make-bogus-lra
(get-context-value frame
- #!-gengc sb!vm::lra-save-offset
- #!+gengc sb!vm::ra-save-offset
+ sb!vm::lra-save-offset
lra-sc-offset))
(setf (get-context-value frame
- #!-gengc sb!vm::lra-save-offset
- #!+gengc sb!vm::ra-save-offset
+ sb!vm::lra-save-offset
lra-sc-offset)
lra)
(let ((end-bpts (breakpoint-%info starter-bpt)))
(when (and (compiled-frame-p frame)
(eq lra
(get-context-value frame
- #!-gengc sb!vm::lra-save-offset
- #!+gengc sb!vm::ra-save-offset
+ sb!vm::lra-save-offset
lra-sc-offset)))
(return t)))))
\f
projects / sbcl.git / blobdiff