X-Git-Url: http://repo.macrolet.net/gitweb/?a=blobdiff_plain;f=src%2Fcode%2Fdebug-int.lisp;h=83378bdcc2755380d0090a0969dc8f32bf3f9e5a;hb=aa2dc9529460ea0d9c99998dc87283fc1a43e808;hp=15622b2acb373ad1b41a01b7ae7e91a6c137909b;hpb=ce02ab2ecd9c6ae2e570abd8c93ebf3be55bbdad;p=sbcl.git diff --git a/src/code/debug-int.lisp b/src/code/debug-int.lisp index 15622b2..83378bd 100644 --- a/src/code/debug-int.lisp +++ b/src/code/debug-int.lisp @@ -47,7 +47,6 @@ #!+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~%" @@ -187,7 +186,7 @@ ;;;; 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 @@ -446,7 +445,7 @@ ;;; 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))) @@ -1078,7 +1077,7 @@ 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) @@ -1107,24 +1106,10 @@ (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)) @@ -1157,6 +1142,50 @@ (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. @@ -1263,7 +1292,7 @@ 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)))) @@ -1994,7 +2023,7 @@ 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 @@ -2437,13 +2466,13 @@ 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) @@ -2454,16 +2483,17 @@ ;;; 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. @@ -2498,12 +2528,148 @@ (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) @@ -2643,13 +2809,13 @@ (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) @@ -2698,13 +2864,13 @@ 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 @@ -2950,7 +3116,7 @@ (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 @@ -2961,7 +3127,7 @@ ;;; 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) @@ -2973,14 +3139,16 @@ (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))))) @@ -3004,21 +3172,21 @@ ;;; 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)) @@ -3046,13 +3214,13 @@ (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. @@ -3084,17 +3252,15 @@ ;;;; 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))) @@ -3182,7 +3348,7 @@ (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 @@ -3610,7 +3776,7 @@ 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