X-Git-Url: http://repo.macrolet.net/gitweb/?a=blobdiff_plain;f=src%2Fcode%2Fdebug-int.lisp;h=a7856e97bb7e116e0aa34515c6cdf00aa1ab3b8e;hb=212ef8043aeaceaa627f2924e04554fbc37b8ee1;hp=b06b89ce4e32947e676b0a6bf6c0e736a597118c;hpb=b27034c44f6f8465fd19964525794615a34b5d41;p=sbcl.git diff --git a/src/code/debug-int.lisp b/src/code/debug-int.lisp index b06b89c..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 @@ -2474,13 +2470,13 @@ ;; 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 + (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-start val (* sb!vm:*static-space-free-pointer* sb!vm:word-bytes)) - (< (sb!vm:current-dynamic-space-start) val + (< sb!vm:dynamic-space-start val (sap-int (dynamic-space-free-pointer)))))) (make-lisp-obj val) :invalid-object)) @@ -3518,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" @@ -3541,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*) @@ -3583,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" @@ -3597,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 @@ -3622,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) @@ -3633,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