X-Git-Url: http://repo.macrolet.net/gitweb/?a=blobdiff_plain;f=src%2Fcode%2Fdebug-int.lisp;h=a7856e97bb7e116e0aa34515c6cdf00aa1ab3b8e;hb=212ef8043aeaceaa627f2924e04554fbc37b8ee1;hp=3482adf7fc6f54a61facae130e0d26212355ae6d;hpb=a530bbe337109d898d5b4a001fc8f1afa3b5dc39;p=sbcl.git diff --git a/src/code/debug-int.lisp b/src/code/debug-int.lisp index 3482adf..a7856e9 100644 --- a/src/code/debug-int.lisp +++ b/src/code/debug-int.lisp @@ -12,9 +12,6 @@ (in-package "SB!DI") -(file-comment - "$Header$") - ;;; FIXME: There are an awful lot of package prefixes in this code. ;;; Couldn't we have SB-DI use the SB-C and SB-VM packages? @@ -41,24 +38,27 @@ () #!+sb-doc (:documentation - "All debug-conditions inherit from this type. These are serious conditions + "All DEBUG-CONDITIONs inherit from this type. These are serious conditions that must be handled, but they are not programmer errors.")) (define-condition no-debug-info (debug-condition) - () + ((code-component :reader no-debug-info-code-component + :initarg :code-component)) #!+sb-doc - (:documentation "There is absolutely no debugging information available.") + (:documentation "There is no usable debugging information available.") (:report (lambda (condition stream) (declare (ignore condition)) (fresh-line stream) - (write-line "No debugging information available." stream)))) + (format stream + "no debug information available for ~S~%" + (no-debug-info-code-component condition))))) (define-condition no-debug-function-returns (debug-condition) ((debug-function :reader no-debug-function-returns-debug-function :initarg :debug-function)) #!+sb-doc (:documentation - "The system could not return values from a frame with debug-function since + "The system could not return values from a frame with DEBUG-FUNCTION since it lacked information about returning values.") (:report (lambda (condition stream) (let ((fun (debug-function-function @@ -130,11 +130,11 @@ "All programmer errors from using the interface for building debugging tools inherit from this type.")) -(define-condition unhandled-condition (debug-error) - ((condition :reader unhandled-condition-condition :initarg :condition)) +(define-condition unhandled-debug-condition (debug-error) + ((condition :reader unhandled-debug-condition-condition :initarg :condition)) (:report (lambda (condition stream) (format stream "~&unhandled DEBUG-CONDITION:~%~A" - (unhandled-condition-condition condition))))) + (unhandled-debug-condition-condition condition))))) (define-condition unknown-code-location (debug-error) ((code-location :reader unknown-code-location-code-location @@ -165,20 +165,21 @@ (frame :reader frame-function-mismatch-frame :initarg :frame) (form :reader frame-function-mismatch-form :initarg :form)) (:report (lambda (condition stream) - (format stream - "~&Form was preprocessed for ~S,~% but called on ~S:~% ~S" - (frame-function-mismatch-code-location condition) - (frame-function-mismatch-frame condition) - (frame-function-mismatch-form condition))))) - -;;; This signals debug-conditions. If they go unhandled, then signal an -;;; unhandled-condition error. + (format + stream + "~&Form was preprocessed for ~S,~% but called on ~S:~% ~S" + (frame-function-mismatch-code-location condition) + (frame-function-mismatch-frame condition) + (frame-function-mismatch-form condition))))) + +;;; This signals debug-conditions. If they go unhandled, then signal +;;; an UNHANDLED-DEBUG-CONDITION error. ;;; ;;; ??? Get SIGNAL in the right package! (defmacro debug-signal (datum &rest arguments) `(let ((condition (make-condition ,datum ,@arguments))) (signal condition) - (error 'unhandled-condition :condition condition))) + (error 'unhandled-debug-condition :condition condition))) ;;;; structures ;;;; @@ -674,18 +675,15 @@ #!-sb-fluid (declaim (inline cstack-pointer-valid-p)) (defun cstack-pointer-valid-p (x) (declare (type system-area-pointer x)) - #!-x86 + #!-x86 ; stack grows toward high address values (and (sap< x (current-sp)) - (sap<= #!-gengc (sb!alien:alien-sap - (sb!alien:extern-alien "control_stack" (* t))) + (sap<= #!-gengc (int-sap control-stack-start) #!+gengc (mutator-control-stack-base) x) (zerop (logand (sap-int x) #b11))) - #!+x86 ;; stack grows to low address values + #!+x86 ; stack grows toward low address values (and (sap>= x (current-sp)) - (sap> (sb!alien:alien-sap (sb!alien:extern-alien "control_stack_end" - (* t))) - x) + (sap> (int-sap control-stack-end) x) (zerop (logand (sap-int x) #b11)))) #!+(or gengc x86) @@ -729,9 +727,7 @@ ;; Not the first page which is unmapped. (>= (sap-int ra) 4096) ;; Not a Lisp stack pointer. - (or (sap< ra (current-sp)) - (sap>= ra (sb!alien:alien-sap - (sb!alien:extern-alien "control_stack_end" (* t))))))) + (not (cstack-pointer-valid-p ra)))) ;;; Try to find a valid previous stack. This is complex on the x86 as ;;; it can jump between C and Lisp frames. To help find a valid frame @@ -1116,9 +1112,8 @@ (without-gcing (let* ((component-ptr (component-ptr-from-pc (sb!vm:context-pc context))) - (code (if (sap= component-ptr (int-sap #x0)) - nil ; FIXME: UNLESS might be clearer than IF. - (component-from-component-ptr component-ptr)))) + (code (unless (sap= component-ptr (int-sap #x0)) + (component-from-component-ptr component-ptr)))) (when (null code) (return (values code 0 context))) (let* ((code-header-len (* (get-header-data code) @@ -1131,8 +1126,10 @@ (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. + ;; We were in an assembly routine. Therefore, use the + ;; LRA as the pc. + ;; + ;; FIXME: Should this be WARN or ERROR or what? (format t "** pc-offset ~S not in code obj ~S?~%" pc-offset code)) (return @@ -1195,7 +1192,7 @@ (let ((info (%code-debug-info component))) (cond ((not info) - (debug-signal 'no-debug-info)) + (debug-signal 'no-debug-info :code-component component)) ((eq info :bogus-lra) (make-bogus-debug-function "function end breakpoint")) (t @@ -1208,8 +1205,7 @@ (elsewhere-p (>= pc (sb!c::compiled-debug-function-elsewhere-pc (svref function-map 0))))) - ;; FIXME: I don't think SB!C is the home package of INDEX. - (declare (type sb!c::index i)) + (declare (type sb!int:index i)) (loop (when (or (= i len) (< pc (if elsewhere-p @@ -1817,7 +1813,7 @@ (let* ((locations (dotimes (k (sb!c::read-var-integer blocks i) (result locations-buffer)) - (let ((kind (svref sb!c::compiled-code-location-kinds + (let ((kind (svref sb!c::*compiled-code-location-kinds* (aref+ blocks i))) (pc (+ last-pc (sb!c::read-var-integer blocks i))) @@ -2007,7 +2003,7 @@ (if (logtest flags sb!c::minimal-debug-function-setf-bit) `(setf ,base) base)) - :kind (svref sb!c::minimal-debug-function-kinds + :kind (svref sb!c::*minimal-debug-function-kinds* (ldb sb!c::minimal-debug-function-kind-byte options)) :variables (when vars-p @@ -2452,6 +2448,39 @@ (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. +;;; +;;; (Such values can arise in registers on machines with conservative +;;; GC, and might also arise in debug variable locations when +;;; those variables are invalid.) +(defun make-valid-lisp-obj (val) + (/show0 "entering MAKE-VALID-LISP-OBJ, VAL=..") + #!+sb-show (%primitive print (sb!impl::hexstr val)) + (if (or + ;; fixnum + (zerop (logand val 3)) + ;; character + (and (zerop (logand val #xffff0000)) ; Top bits zero + (= (logand val #xff) sb!vm:base-char-type)) ; Char tag + ;; unbound marker + (= val sb!vm:unbound-marker-type) + ;; pointer + (and (logand val 1) + ;; Check that the pointer is valid. XXX Could do a better + ;; job. FIXME: e.g. by calling out to an is_valid_pointer + ;; routine in the C runtime support code + (or (< sb!vm:read-only-space-start val + (* sb!vm:*read-only-space-free-pointer* + sb!vm:word-bytes)) + (< sb!vm:static-space-start val + (* sb!vm:*static-space-free-pointer* + sb!vm:word-bytes)) + (< sb!vm:dynamic-space-start val + (sap-int (dynamic-space-free-pointer)))))) + (make-lisp-obj val) + :invalid-object)) + ;;; CMU CL had ;;; (DEFUN SUB-ACCESS-DEBUG-VAR-SLOT (FP SC-OFFSET &OPTIONAL ESCAPED) ..) ;;; code for this case. @@ -2462,102 +2491,100 @@ #!+x86 (defun sub-access-debug-var-slot (fp sc-offset &optional escaped) (declare (type system-area-pointer fp)) + (/show0 "entering SUB-ACCESS-DEBUG-VAR-SLOT, FP,SC-OFFSET,ESCAPED=..") + #!+sb-show (%primitive print (sb!impl::hexstr fp)) + #!+sb-show (%primitive print (sb!impl::hexstr sc-offset)) + #!+sb-show (%primitive print (sb!impl::hexstr 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)) + (let ((,var (sb!vm:context-register + escaped + (sb!c:sc-offset-offset sc-offset)))) + (/show0 "in escaped case, ,VAR value=..") + #!+sb-show (%primitive print (sb!impl::hexstr ,var)) + ,@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)) + (sb!vm:context-float-register + escaped (sb!c:sc-offset-offset sc-offset) ',format) + :invalid-value-for-unescaped-register-storage)) (escaped-complex-float-value (format) `(if escaped - (complex - (sb!vm:context-float-register - escaped (sb!c:sc-offset-offset sc-offset) ',format) - (sb!vm:context-float-register - escaped (1+ (sb!c:sc-offset-offset sc-offset)) ',format)) - :invalid-value-for-unescaped-register-storage)) - ;; The debug variable locations are not always valid, and - ;; on the x86 locations can contain raw values. To - ;; prevent later problems from invalid objects, they are - ;; filtered here. - (make-valid-lisp-obj (val) - `(if (or - ;; fixnum - (zerop (logand ,val 3)) - ;; character - (and (zerop (logand ,val #xffff0000)) ; Top bits zero - (= (logand ,val #xff) sb!vm:base-char-type)) ; Char tag - ;; unbound marker - (= ,val sb!vm:unbound-marker-type) - ;; pointer - (and (logand ,val 1) - ;; Check that the pointer is valid. XXX Could do a - ;; better job. - (or (< (sb!impl::read-only-space-start) ,val - (* sb!impl::*read-only-space-free-pointer* - sb!vm:word-bytes)) - (< (sb!impl::static-space-start) ,val - (* sb!impl::*static-space-free-pointer* - sb!vm:word-bytes)) - (< (sb!impl::current-dynamic-space-start) ,val - (sap-int (dynamic-space-free-pointer)))))) - (make-lisp-obj ,val) - :invalid-object))) + (complex + (sb!vm:context-float-register + escaped (sb!c:sc-offset-offset sc-offset) ',format) + (sb!vm:context-float-register + escaped (1+ (sb!c:sc-offset-offset sc-offset)) ',format)) + :invalid-value-for-unescaped-register-storage))) (ecase (sb!c:sc-offset-scn sc-offset) ((#.sb!vm:any-reg-sc-number #.sb!vm:descriptor-reg-sc-number) + (/show0 "case of ANY-REG-SC-NUMBER or DESCRIPTOR-REG-SC-NUMBER") (without-gcing (with-escaped-value (val) + (/show0 "VAL=..") + #!+sb-show (%primitive print (sb!impl::hexstr val)) (make-valid-lisp-obj val)))) (#.sb!vm:base-char-reg-sc-number + (/show0 "case of BASE-CHAR-REG-SC-NUMBER") (with-escaped-value (val) (code-char val))) (#.sb!vm:sap-reg-sc-number + (/show0 "case of SAP-REG-SC-NUMBER") (with-escaped-value (val) (int-sap val))) (#.sb!vm:signed-reg-sc-number + (/show0 "case of 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 + (/show0 "case of UNSIGNED-REG-SC-NUMBER") (with-escaped-value (val) val)) (#.sb!vm:single-reg-sc-number + (/show0 "case of SINGLE-REG-SC-NUMBER") (escaped-float-value single-float)) (#.sb!vm:double-reg-sc-number + (/show0 "case of DOUBLE-REG-SC-NUMBER") (escaped-float-value double-float)) #!+long-float (#.sb!vm:long-reg-sc-number + (/show0 "case of LONG-REG-SC-NUMBER") (escaped-float-value long-float)) (#.sb!vm:complex-single-reg-sc-number + (/show0 "case of COMPLEX-SINGLE-REG-SC-NUMBER") (escaped-complex-float-value single-float)) (#.sb!vm:complex-double-reg-sc-number + (/show0 "case of COMPLEX-DOUBLE-REG-SC-NUMBER") (escaped-complex-float-value double-float)) #!+long-float (#.sb!vm:complex-long-reg-sc-number + (/show0 "case of COMPLEX-LONG-REG-SC-NUMBER") (escaped-complex-float-value long-float)) (#.sb!vm:single-stack-sc-number + (/show0 "case of SINGLE-STACK-SC-NUMBER") (sap-ref-single fp (- (* (1+ (sb!c:sc-offset-offset sc-offset)) sb!vm:word-bytes)))) (#.sb!vm:double-stack-sc-number + (/show0 "case of DOUBLE-STACK-SC-NUMBER") (sap-ref-double fp (- (* (+ (sb!c:sc-offset-offset sc-offset) 2) sb!vm:word-bytes)))) #!+long-float (#.sb!vm:long-stack-sc-number + (/show0 "case of LONG-STACK-SC-NUMBER") (sap-ref-long fp (- (* (+ (sb!c:sc-offset-offset sc-offset) 3) sb!vm:word-bytes)))) (#.sb!vm:complex-single-stack-sc-number + (/show0 "case of COMPLEX-STACK-SC-NUMBER") (complex (sap-ref-single fp (- (* (1+ (sb!c:sc-offset-offset sc-offset)) sb!vm:word-bytes))) (sap-ref-single fp (- (* (+ (sb!c:sc-offset-offset sc-offset) 2) sb!vm:word-bytes))))) (#.sb!vm:complex-double-stack-sc-number + (/show0 "case of COMPLEX-DOUBLE-STACK-SC-NUMBER") (complex (sap-ref-double fp (- (* (+ (sb!c:sc-offset-offset sc-offset) 2) sb!vm:word-bytes))) @@ -2565,24 +2592,30 @@ sb!vm:word-bytes))))) #!+long-float (#.sb!vm:complex-long-stack-sc-number + (/show0 "case of COMPLEX-LONG-STACK-SC-NUMBER") (complex (sap-ref-long fp (- (* (+ (sb!c:sc-offset-offset sc-offset) 3) sb!vm:word-bytes))) (sap-ref-long fp (- (* (+ (sb!c:sc-offset-offset sc-offset) 6) sb!vm:word-bytes))))) (#.sb!vm:control-stack-sc-number + (/show0 "case of CONTROL-STACK-SC-NUMBER") (stack-ref fp (sb!c:sc-offset-offset sc-offset))) (#.sb!vm:base-char-stack-sc-number + (/show0 "case of BASE-CHAR-STACK-SC-NUMBER") (code-char (sap-ref-32 fp (- (* (1+ (sb!c:sc-offset-offset sc-offset)) sb!vm:word-bytes))))) (#.sb!vm:unsigned-stack-sc-number + (/show0 "case of UNSIGNED-STACK-SC-NUMBER") (sap-ref-32 fp (- (* (1+ (sb!c:sc-offset-offset sc-offset)) sb!vm:word-bytes)))) (#.sb!vm:signed-stack-sc-number + (/show0 "case of SIGNED-STACK-SC-NUMBER") (signed-sap-ref-32 fp (- (* (1+ (sb!c:sc-offset-offset sc-offset)) sb!vm:word-bytes)))) (#.sb!vm:sap-stack-sc-number + (/show0 "case of SAP-STACK-SC-NUMBER") (sap-ref-sap fp (- (* (1+ (sb!c:sc-offset-offset sc-offset)) sb!vm:word-bytes))))))) @@ -3481,6 +3514,7 @@ ;;; debugging-tool break instruction. This does NOT handle all breaks; ;;; for example, it does not handle breaks for internal errors. (defun handle-breakpoint (offset component signal-context) + (/show0 "entering HANDLE-BREAKPOINT") (let ((data (breakpoint-data component offset nil))) (unless data (error "unknown breakpoint in ~S at offset ~S" @@ -3504,6 +3538,7 @@ ;;; This handles code-location and debug-function :FUNCTION-START ;;; breakpoints. (defun handle-breakpoint-aux (breakpoints data offset component signal-context) + (/show0 "entering HANDLE-BREAKPOINT-AUX") (unless breakpoints (error "internal error: breakpoint that nobody wants")) (unless (member data *executing-breakpoint-hooks*) @@ -3546,6 +3581,7 @@ bpt))))) (defun handle-function-end-breakpoint (offset component context) + (/show0 "entering HANDLE-FUNCTION-END-BREAKPOINT") (let ((data (breakpoint-data component offset nil))) (unless data (error "unknown breakpoint in ~S at offset ~S" @@ -3560,6 +3596,7 @@ ;;; [old C code] or HANDLE-FUNCTION-END-BREAKPOINT calls this directly ;;; [new C code]. (defun handle-function-end-breakpoint-aux (breakpoints data signal-context) + (/show0 "entering HANDLE-FUNCTION-END-BREAKPOINT-AUX") (delete-breakpoint-data data) (let* ((scp (locally @@ -3585,7 +3622,7 @@ #!+x86 sb!vm::ebx-offset))) (nargs (make-lisp-obj (sb!vm:context-register scp sb!vm::nargs-offset))) - (reg-arg-offsets '#.sb!vm::register-arg-offsets) + (reg-arg-offsets '#.sb!vm::*register-arg-offsets*) (results nil)) (without-gcing (dotimes (arg-num nargs) @@ -3596,7 +3633,7 @@ results))) (nreverse results))) -;;;; MAKE-BOGUS-LRA (used for :function-end breakpoints) +;;;; MAKE-BOGUS-LRA (used for :FUNCTION-END breakpoints) (defconstant bogus-lra-constants