#!+sb-doc
(:documentation "There is no usable debugging information available.")
(:report (lambda (condition stream)
- (declare (ignore condition))
(fresh-line stream)
(format stream
"no debug information available for ~S~%"
;;;; data structures created by the compiler. Whenever comments
;;;; preface an object or type with "compiler", they refer to the
;;;; internal compiler thing, not to the object or type with the same
-;;;; name in the "DI" package.
+;;;; name in the "SB-DI" package.
;;;; DEBUG-VARs
;;; lists of DEBUG-BLOCKs. Then look up our argument IR1-BLOCK to find
;;; its DEBUG-BLOCK since we know we have it now.
(defun make-interpreted-debug-block (ir1-block)
- (check-type ir1-block sb!c::cblock)
+ (declare (type sb!c::cblock ir1-block))
(let ((res (gethash ir1-block *ir1-block-debug-block*)))
(or res
(let ((lambda (sb!c::block-home-lambda ir1-block)))
code (1+ real-lra-slot)))
(setq code (code-header-ref code real-lra-slot))
; (format t "ccf3 :bogus-lra ~S ~S~%" code pc-offset)
- (assert code)))
+ (aver code)))
(t
;; Not escaped
(multiple-value-setq (pc-offset code)
(if up-frame (1+ (frame-number up-frame)) 0)
escaped)))))
-#!-(or gengc x86)
-;;; FIXME: The original CMU CL code had support for this case, but it
-;;; must have been fairly stale even in CMU CL, since it had
-;;; references to the MIPS package, and there have been enough
-;;; relevant changes in SBCL (particularly using
-;;; POSIX/SIGACTION0-style signal context instead of BSD-style
-;;; sigcontext) that this code is unmaintainable (since as of
-;;; sbcl-0.6.7, and for the foreseeable future, we can't test it,
-;;; since we only support X86 and its gencgc).
-;;;
-;;; If we restore this case, the best approach would be to go back to
-;;; the original CMU CL code and start from there.
-(eval-when (:compile-toplevel :load-toplevel :execute)
- (error "hopelessly stale"))
#!+x86
(defun find-escaped-frame (frame-pointer)
(declare (type system-area-pointer frame-pointer))
- (dotimes (index sb!impl::*free-interrupt-context-index* (values nil 0 nil))
+ (dotimes (index *free-interrupt-context-index* (values nil 0 nil))
(sb!alien:with-alien
((lisp-interrupt-contexts (array (* os-context-t) nil)
:extern))
(return
(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:word-bytes))
+ (pc-offset
+ (- (sap-int (sb!vm:context-pc scp))
+ (- (get-lisp-obj-address code)
+ sb!vm:other-pointer-type)
+ 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:word-bytes))
+ (unless (<= 0 pc-offset
+ (* (code-header-ref code sb!vm:code-code-size-slot)
+ sb!vm: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
;;; undefined-function.
code-locations at which execution would continue with frame as the top
frame if someone threw to the corresponding tag."
(let ((catch
- #!-gengc (descriptor-sap sb!impl::*current-catch-block*)
+ #!-gengc (descriptor-sap *current-catch-block*)
#!+gengc (mutator-current-catch-block))
(res nil)
(fp (frame-pointer (frame-real-frame frame))))
0))
(sc-offset (if deleted 0 (geti)))
(save-sc-offset (if save (geti) nil)))
- (assert (not (and args-minimal (not minimal))))
+ (aver (not (and args-minimal (not minimal))))
(vector-push-extend (make-compiled-debug-var symbol
id
live
invalid. This is SETF'able."
(etypecase debug-var
(compiled-debug-var
- (check-type frame compiled-frame)
+ (aver (typep frame 'compiled-frame))
(let ((res (access-compiled-debug-var-slot debug-var frame)))
(if (indirect-value-cell-p res)
(sb!c:value-cell-ref res)
res)))
(interpreted-debug-var
- (check-type frame interpreted-frame)
+ (aver (typep frame 'interpreted-frame))
(sb!eval::leaf-value-lambda-var
(interpreted-code-location-ir1-node (frame-code-location frame))
(interpreted-debug-var-ir1-var debug-var)
;;; DEBUG-VAR relative to the FRAME. This may be an indirect value
;;; cell if the variable is both closed over and set.
(defun access-compiled-debug-var-slot (debug-var frame)
+ (declare (optimize (speed 1)))
(let ((escaped (compiled-frame-escaped frame)))
(if escaped
- (sub-access-debug-var-slot
- (frame-pointer frame)
- (compiled-debug-var-sc-offset debug-var)
- escaped)
- (sub-access-debug-var-slot
- (frame-pointer frame)
- (or (compiled-debug-var-save-sc-offset debug-var)
- (compiled-debug-var-sc-offset debug-var))))))
+ (sub-access-debug-var-slot
+ (frame-pointer frame)
+ (compiled-debug-var-sc-offset debug-var)
+ escaped)
+ (sub-access-debug-var-slot
+ (frame-pointer frame)
+ (or (compiled-debug-var-save-sc-offset debug-var)
+ (compiled-debug-var-sc-offset debug-var))))))
;;; a helper function for working with possibly-invalid values:
;;; Do (MAKE-LISP-OBJ VAL) only if the value looks valid.
(make-lisp-obj val)
:invalid-object))
-;;; CMU CL had
-;;; (DEFUN SUB-ACCESS-DEBUG-VAR-SLOT (FP SC-OFFSET &OPTIONAL ESCAPED) ..)
-;;; code for this case.
#!-x86
-(eval-when (:compile-toplevel :load-toplevel :execute)
- (error "hopelessly stale"))
+(defun sub-access-debug-var-slot (fp sc-offset &optional escaped)
+ (macrolet ((with-escaped-value ((var) &body forms)
+ `(if escaped
+ (let ((,var (sb!vm:context-register
+ escaped
+ (sb!c:sc-offset-offset sc-offset))))
+ ,@forms)
+ :invalid-value-for-unescaped-register-storage))
+ (escaped-float-value (format)
+ `(if escaped
+ (sb!vm:context-float-register
+ escaped
+ (sb!c:sc-offset-offset sc-offset)
+ ',format)
+ :invalid-value-for-unescaped-register-storage))
+ (with-nfp ((var) &body body)
+ `(let ((,var (if escaped
+ (sb!sys:int-sap
+ (sb!vm:context-register escaped
+ sb!vm::nfp-offset))
+ #!-alpha
+ (sb!sys:sap-ref-sap fp (* sb!vm::nfp-save-offset
+ sb!vm:word-bytes))
+ #!+alpha
+ (sb!vm::make-number-stack-pointer
+ (sb!sys:sap-ref-32 fp (* sb!vm::nfp-save-offset
+ sb!vm:word-bytes))))))
+ ,@body)))
+ (ecase (sb!c:sc-offset-scn sc-offset)
+ ((#.sb!vm:any-reg-sc-number
+ #.sb!vm:descriptor-reg-sc-number
+ #!+rt #.sb!vm:word-pointer-reg-sc-number)
+ (sb!sys:without-gcing
+ (with-escaped-value (val) (sb!kernel:make-lisp-obj val))))
+
+ (#.sb!vm:base-char-reg-sc-number
+ (with-escaped-value (val)
+ (code-char val)))
+ (#.sb!vm:sap-reg-sc-number
+ (with-escaped-value (val)
+ (sb!sys:int-sap val)))
+ (#.sb!vm:signed-reg-sc-number
+ (with-escaped-value (val)
+ (if (logbitp (1- sb!vm:word-bits) val)
+ (logior val (ash -1 sb!vm:word-bits))
+ val)))
+ (#.sb!vm:unsigned-reg-sc-number
+ (with-escaped-value (val)
+ val))
+ (#.sb!vm:non-descriptor-reg-sc-number
+ (error "Local non-descriptor register access?"))
+ (#.sb!vm:interior-reg-sc-number
+ (error "Local interior register access?"))
+ (#.sb!vm:single-reg-sc-number
+ (escaped-float-value single-float))
+ (#.sb!vm:double-reg-sc-number
+ (escaped-float-value double-float))
+ #!+long-float
+ (#.sb!vm:long-reg-sc-number
+ (escaped-float-value long-float))
+ (#.sb!vm:complex-single-reg-sc-number
+ (if escaped
+ (complex
+ (sb!vm:context-float-register
+ escaped (sb!c:sc-offset-offset sc-offset) 'single-float)
+ (sb!vm:context-float-register
+ escaped (1+ (sb!c:sc-offset-offset sc-offset)) 'single-float))
+ :invalid-value-for-unescaped-register-storage))
+ (#.sb!vm:complex-double-reg-sc-number
+ (if escaped
+ (complex
+ (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)
+ 'double-float))
+ :invalid-value-for-unescaped-register-storage))
+ #!+long-float
+ (#.sb!vm:complex-long-reg-sc-number
+ (if escaped
+ (complex
+ (sb!vm:context-float-register
+ escaped (sb!c:sc-offset-offset sc-offset) 'long-float)
+ (sb!vm:context-float-register
+ escaped (+ (sb!c:sc-offset-offset sc-offset) #!+sparc 4)
+ 'long-float))
+ :invalid-value-for-unescaped-register-storage))
+ (#.sb!vm:single-stack-sc-number
+ (with-nfp (nfp)
+ (sb!sys:sap-ref-single nfp (* (sb!c:sc-offset-offset sc-offset)
+ sb!vm:word-bytes))))
+ (#.sb!vm:double-stack-sc-number
+ (with-nfp (nfp)
+ (sb!sys:sap-ref-double nfp (* (sb!c:sc-offset-offset sc-offset)
+ sb!vm:word-bytes))))
+ #!+long-float
+ (#.sb!vm:long-stack-sc-number
+ (with-nfp (nfp)
+ (sb!sys:sap-ref-long nfp (* (sb!c:sc-offset-offset sc-offset)
+ sb!vm:word-bytes))))
+ (#.sb!vm:complex-single-stack-sc-number
+ (with-nfp (nfp)
+ (complex
+ (sb!sys:sap-ref-single nfp (* (sb!c:sc-offset-offset sc-offset)
+ sb!vm:word-bytes))
+ (sb!sys:sap-ref-single nfp (* (1+ (sb!c:sc-offset-offset sc-offset))
+ sb!vm:word-bytes)))))
+ (#.sb!vm:complex-double-stack-sc-number
+ (with-nfp (nfp)
+ (complex
+ (sb!sys:sap-ref-double nfp (* (sb!c:sc-offset-offset sc-offset)
+ sb!vm:word-bytes))
+ (sb!sys:sap-ref-double nfp (* (+ (sb!c:sc-offset-offset sc-offset) 2)
+ sb!vm:word-bytes)))))
+ #!+long-float
+ (#.sb!vm:complex-long-stack-sc-number
+ (with-nfp (nfp)
+ (complex
+ (sb!sys:sap-ref-long nfp (* (sb!c:sc-offset-offset sc-offset)
+ sb!vm:word-bytes))
+ (sb!sys:sap-ref-long nfp (* (+ (sb!c:sc-offset-offset sc-offset)
+ #!+sparc 4)
+ sb!vm:word-bytes)))))
+ (#.sb!vm:control-stack-sc-number
+ (sb!kernel:stack-ref fp (sb!c:sc-offset-offset sc-offset)))
+ (#.sb!vm:base-char-stack-sc-number
+ (with-nfp (nfp)
+ (code-char (sb!sys:sap-ref-32 nfp (* (sb!c:sc-offset-offset sc-offset)
+ sb!vm:word-bytes)))))
+ (#.sb!vm:unsigned-stack-sc-number
+ (with-nfp (nfp)
+ (sb!sys:sap-ref-32 nfp (* (sb!c:sc-offset-offset sc-offset)
+ sb!vm:word-bytes))))
+ (#.sb!vm:signed-stack-sc-number
+ (with-nfp (nfp)
+ (sb!sys:signed-sap-ref-32 nfp (* (sb!c:sc-offset-offset sc-offset)
+ sb!vm:word-bytes))))
+ (#.sb!vm:sap-stack-sc-number
+ (with-nfp (nfp)
+ (sb!sys:sap-ref-sap nfp (* (sb!c:sc-offset-offset sc-offset)
+ sb!vm:word-bytes)))))))
#!+x86
(defun sub-access-debug-var-slot (fp sc-offset &optional escaped)
(defun %set-debug-var-value (debug-var frame value)
(etypecase debug-var
(compiled-debug-var
- (check-type frame compiled-frame)
+ (aver (typep frame 'compiled-frame))
(let ((current-value (access-compiled-debug-var-slot debug-var frame)))
(if (indirect-value-cell-p current-value)
(sb!c:value-cell-set current-value value)
(set-compiled-debug-var-slot debug-var frame value))))
(interpreted-debug-var
- (check-type frame interpreted-frame)
+ (aver (typep frame 'interpreted-frame))
(sb!eval::set-leaf-value-lambda-var
(interpreted-code-location-ir1-node (frame-code-location frame))
(interpreted-debug-var-ir1-var debug-var)
sb!vm::nfp-offset))
#!-alpha
(sap-ref-sap fp
- (* sb!vm::nfp-save-offset
- sb!vm:word-bytes))
+ (* sb!vm::nfp-save-offset
+ sb!vm:word-bytes))
#!+alpha
- (%alpha::make-number-stack-pointer
+ (sb!vm::make-number-stack-pointer
(sap-ref-32 fp
- (* sb!vm::nfp-save-offset
- sb!vm:word-bytes))))))
+ (* sb!vm::nfp-save-offset
+ sb!vm:word-bytes))))))
,@body)))
(ecase (sb!c:sc-offset-scn sc-offset)
((#.sb!vm:any-reg-sc-number
(compiled-debug-var
(compiled-debug-var-validity debug-var basic-code-location))
(interpreted-debug-var
- (check-type basic-code-location interpreted-code-location)
+ (aver (typep basic-code-location 'interpreted-code-location))
(let ((validp (rassoc (interpreted-debug-var-ir1-var debug-var)
(sb!c::lexenv-variables
(sb!c::node-lexenv
;;; This is the method for DEBUG-VAR-VALIDITY for COMPILED-DEBUG-VARs.
;;; For safety, make sure basic-code-location is what we think.
(defun compiled-debug-var-validity (debug-var basic-code-location)
- (check-type basic-code-location compiled-code-location)
+ (declare (type compiled-code-location basic-code-location))
(cond ((debug-var-alive-p debug-var)
(let ((debug-fun (code-location-debug-function basic-code-location)))
(if (>= (compiled-code-location-pc basic-code-location)
(t
(let ((pos (position debug-var
(debug-function-debug-vars
- (code-location-debug-function basic-code-location)))))
+ (code-location-debug-function
+ basic-code-location)))))
(unless pos
(error 'unknown-debug-var
:debug-var debug-var
:debug-function
(code-location-debug-function basic-code-location)))
;; There must be live-set info since basic-code-location is known.
- (if (zerop (sbit (compiled-code-location-live-set basic-code-location)
+ (if (zerop (sbit (compiled-code-location-live-set
+ basic-code-location)
pos))
:invalid
:valid)))))
;;; Given the DEFUN, 3 gets you the LET, 1 gets you the bindings, 0
;;; gets the first binding, and 1 gets the AREF form.
-;;; Temporary buffer used to build form-number => source-path translation in
-;;; FORM-NUMBER-TRANSLATIONS.
+;;; temporary buffer used to build form-number => source-path translation in
+;;; FORM-NUMBER-TRANSLATIONS
(defvar *form-number-temp* (make-array 10 :fill-pointer 0 :adjustable t))
-;;; Table used to detect CAR circularities in FORM-NUMBER-TRANSLATIONS.
+;;; table used to detect CAR circularities in FORM-NUMBER-TRANSLATIONS
(defvar *form-number-circularity-table* (make-hash-table :test 'eq))
+;;; This returns a table mapping form numbers to source-paths. A source-path
+;;; indicates a descent into the top-level-form form, going directly to the
+;;; subform corressponding to the form number.
+;;;
;;; The vector elements are in the same format as the compiler's
-;;; NODE-SOUCE-PATH; that is, the first element is the form number and the last
-;;; is the top-level-form number.
+;;; NODE-SOURCE-PATH; that is, the first element is the form number and
+;;; the last is the top-level-form number.
(defun form-number-translations (form tlf-number)
- #!+sb-doc
- "This returns a table mapping form numbers to source-paths. A source-path
- indicates a descent into the top-level-form form, going directly to the
- subform corressponding to the form number."
(clrhash *form-number-circularity-table*)
(setf (fill-pointer *form-number-temp*) 0)
(sub-translate-form-numbers form (list tlf-number))
(frob)
(setq trail (cdr trail)))))))
+;;; FORM is a top-level form, and path is a source-path into it. This
+;;; returns the form indicated by the source-path. Context is the
+;;; number of enclosing forms to return instead of directly returning
+;;; the source-path form. When context is non-zero, the form returned
+;;; contains a marker, #:****HERE****, immediately before the form
+;;; indicated by path.
(defun source-path-context (form path context)
- #!+sb-doc
- "Form is a top-level form, and path is a source-path into it. This returns
- the form indicated by the source-path. Context is the number of enclosing
- forms to return instead of directly returning the source-path form. When
- context is non-zero, the form returned contains a marker, #:****HERE****,
- immediately before the form indicated by path."
(declare (type unsigned-byte context))
;; Get to the form indicated by path or the enclosing form indicated
;; by context and path.
\f
;;;; PREPROCESS-FOR-EVAL and EVAL-IN-FRAME
-;;; Create a SYMBOL-MACROLET for each variable valid at the location which
-;;; accesses that variable from the frame argument.
+;;; Return a function of one argument that evaluates form in the
+;;; lexical context of the basic-code-location loc.
+;;; PREPROCESS-FOR-EVAL signals a no-debug-vars condition when the
+;;; loc's debug-function has no debug-var information available. The
+;;; returned function takes the frame to get values from as its
+;;; argument, and it returns the values of form. The returned function
+;;; signals the following conditions: invalid-value,
+;;; ambiguous-variable-name, and frame-function-mismatch.
(defun preprocess-for-eval (form loc)
- #!+sb-doc
- "Return a function of one argument that evaluates form in the lexical
- context of the basic-code-location loc. PREPROCESS-FOR-EVAL signals a
- no-debug-vars condition when the loc's debug-function has no
- debug-var information available. The returned function takes the frame
- to get values from as its argument, and it returns the values of form.
- The returned function signals the following conditions: invalid-value,
- ambiguous-variable-name, and frame-function-mismatch"
(declare (type code-location loc))
(let ((n-frame (gensym))
(fun (code-location-debug-function loc)))
(when (code-location-unknown-p what)
(error "cannot make a breakpoint at an unknown code location: ~S"
what))
- (assert (eq kind :code-location))
+ (aver (eq kind :code-location))
(let ((bpt (%make-breakpoint hook-function what kind info)))
(etypecase what
(interpreted-code-location
offset))
(let ((breakpoints (breakpoint-data-breakpoints data)))
(when breakpoints
- (assert (eq (breakpoint-kind (car breakpoints)) :function-end))
+ (aver (eq (breakpoint-kind (car breakpoints)) :function-end))
(handle-function-end-breakpoint-aux breakpoints data context)))))
;;; Either HANDLE-BREAKPOINT calls this for :FUNCTION-END breakpoints
projects / sbcl.git / blobdiff