(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?
\f
()
#!+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
"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
(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)))
\f
;;;; structures
;;;;
#!-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)
;; 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
(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)
(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
(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
(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
(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)))
(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
;; 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))
;;; 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"
;;; 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*)
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"
;;; [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
#!+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)
results)))
(nreverse results)))
-;;;; MAKE-BOGUS-LRA (used for :function-end breakpoints)
+;;;; MAKE-BOGUS-LRA (used for :FUNCTION-END breakpoints)
(defconstant
bogus-lra-constants
projects / sbcl.git / blobdiff