0.6.9.9:

[sbcl.git] / src / code / debug-int.lisp

diff --git a/src/code/debug-int.lisp b/src/code/debug-int.lisp
index e8f9ef5..a7856e9 100644 (file)
--- a/src/code/debug-int.lisp
+++ b/src/code/debug-int.lisp
@@ -12,9 +12,6 @@
 
 (in-package "SB!DI")
 
 
 (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
 ;;; 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

@@ -41,24 +38,27 @@
   ()
   #!+sb-doc
   (:documentation
   ()
   #!+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)
     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
   #!+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)
   (: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
 
 (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
     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."))
 
    "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"
   (: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
 
 (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)
    (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)
 ;;;
 ;;; ??? 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
 ;;;;
 \f
 ;;;; 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))
 #!-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))
   (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)))
              #!+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))
   (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)
        (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.
    ;; 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
 
 ;;; 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)))
          (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)
             (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))
               (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
                 (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)
   (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
      ((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)))))
                  (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
              (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* ((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)))
                                           (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))
       (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
                 (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
            ;; 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:*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:*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))
                   (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)
 ;;; 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"
   (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)
 ;;; 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*)
   (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)
                   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"
   (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)
 ;;; [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
   (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)))
                        #!+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 nil))
     (without-gcing
      (dotimes (arg-num nargs)

@@ -3633,7 +3633,7 @@
             results)))
     (nreverse results)))
 
             results)))
     (nreverse results)))
 

-;;;; MAKE-BOGUS-LRA (used for :function-end breakpoints)
+;;;; MAKE-BOGUS-LRA (used for :FUNCTION-END breakpoints)

 
 (defconstant
   bogus-lra-constants
 
 (defconstant
   bogus-lra-constants