0.pre7.86.flaky7:

[sbcl.git] / src / code / ntrace.lisp

diff --git a/src/code/ntrace.lisp b/src/code/ntrace.lisp
index 9e54bf2..cdf1660 100644 (file)
--- a/src/code/ntrace.lisp
+++ b/src/code/ntrace.lisp
@@ -9,7 +9,7 @@
 ;;;; provided with absolutely no warranty. See the COPYING and CREDITS
 ;;;; files for more information.
 
 ;;;; provided with absolutely no warranty. See the COPYING and CREDITS
 ;;;; files for more information.
 

-(in-package "SB-DEBUG")
+(in-package "SB-DEBUG") ; (SB-, not SB!, since we're built in warm load.)

 
 ;;; FIXME: Why, oh why, doesn't the SB-DEBUG package use the SB-DI
 ;;; package? That would let us get rid of a whole lot of stupid
 
 ;;; FIXME: Why, oh why, doesn't the SB-DEBUG package use the SB-DI
 ;;; package? That would let us get rid of a whole lot of stupid

@@ -81,7 +81,7 @@
   ;; list of null environment forms
   (print-after () :type list))
 
   ;; list of null environment forms
   (print-after () :type list))
 

-;;; This is a list of conses (function-end-cookie . condition-satisfied),
+;;; This is a list of conses (fun-end-cookie . condition-satisfied),

 ;;; which we use to note distinct dynamic entries into functions. When
 ;;; we enter a traced function, we add a entry to this list holding
 ;;; the new end-cookie and whether the trace condition was satisfied.
 ;;; which we use to note distinct dynamic entries into functions. When
 ;;; we enter a traced function, we add a entry to this list holding
 ;;; the new end-cookie and whether the trace condition was satisfied.

@@ -91,8 +91,8 @@
 ;;;
 ;;; This list also helps us synchronize the TRACE facility dynamically
 ;;; for detecting non-local flow of control. Whenever execution hits a
 ;;;
 ;;; This list also helps us synchronize the TRACE facility dynamically
 ;;; for detecting non-local flow of control. Whenever execution hits a

-;;; :FUNCTION-END breakpoint used for TRACE'ing, we look for the
-;;; FUNCTION-END-COOKIE at the top of *TRACED-ENTRIES*. If it is not
+;;; :FUN-END breakpoint used for TRACE'ing, we look for the
+;;; FUN-END-COOKIE at the top of *TRACED-ENTRIES*. If it is not

 ;;; there, we discard any entries that come before our cookie.
 ;;;
 ;;; When we trace using encapsulation, we bind this variable and add
 ;;; there, we discard any entries that come before our cookie.
 ;;;
 ;;; When we trace using encapsulation, we bind this variable and add

@@ -125,17 +125,14 @@
                (values (fdefinition x) t))))
        (function x)
        (t (values (fdefinition x) t)))
                (values (fdefinition x) t))))
        (function x)
        (t (values (fdefinition x) t)))

-    (if (sb-eval:interpreted-function-p res)
-       (values res named-p (if (sb-eval:interpreted-function-closure res)
-                               :interpreted-closure :interpreted))
-       (case (sb-kernel:get-type res)
-         (#.sb-vm:closure-header-type
-          (values (sb-kernel:%closure-function res)
-                  named-p
-                  :compiled-closure))
-         (#.sb-vm:funcallable-instance-header-type
-          (values res named-p :funcallable-instance))
-         (t (values res named-p :compiled))))))
+    (case (sb-kernel:widetag-of res)
+      (#.sb-vm:closure-header-widetag
+       (values (sb-kernel:%closure-fun res)
+              named-p
+              :compiled-closure))
+      (#.sb-vm:funcallable-instance-header-widetag
+       (values res named-p :funcallable-instance))
+      (t (values res named-p :compiled)))))

 
 ;;; When a function name is redefined, and we were tracing that name,
 ;;; then untrace the old definition and trace the new one.
 
 ;;; When a function name is redefined, and we were tracing that name,
 ;;; then untrace the old definition and trace the new one.

@@ -146,7 +143,7 @@
       (when (and info (trace-info-named info))
        (untrace-1 fname)
        (trace-1 fname info new-value)))))
       (when (and info (trace-info-named info))
        (untrace-1 fname)
        (trace-1 fname info new-value)))))

-(push #'trace-redefined-update sb-int:*setf-fdefinition-hook*)
+(push #'trace-redefined-update *setf-fdefinition-hook*)

 
 ;;; Annotate some forms to evaluate with pre-converted functions. Each
 ;;; form is really a cons (exp . function). Loc is the code location
 
 ;;; Annotate some forms to evaluate with pre-converted functions. Each
 ;;; form is really a cons (exp . function). Loc is the code location

@@ -191,24 +188,23 @@
               *trace-indentation-step*)
            depth)))
 
               *trace-indentation-step*)
            depth)))
 

-;;; Return true if one of the Names appears on the stack below Frame.
+;;; Return true if any of the NAMES appears on the stack below FRAME.

 (defun trace-wherein-p (frame names)
   (do ((frame (sb-di:frame-down frame) (sb-di:frame-down frame)))
       ((not frame) nil)
 (defun trace-wherein-p (frame names)
   (do ((frame (sb-di:frame-down frame) (sb-di:frame-down frame)))
       ((not frame) nil)

-    (when (member (sb-di:debug-function-name (sb-di:frame-debug-function
-                                             frame))
+    (when (member (sb-di:debug-fun-name (sb-di:frame-debug-fun frame))

                  names
                  :test #'equal)
       (return t))))
 
                  names
                  :test #'equal)
       (return t))))
 

-;;; Handle print and print-after options.
+;;; Handle PRINT and PRINT-AFTER options.

 (defun trace-print (frame forms)
   (dolist (ele forms)
     (fresh-line)
     (print-trace-indentation)
     (format t "~S = ~S" (car ele) (funcall (cdr ele) frame))))
 
 (defun trace-print (frame forms)
   (dolist (ele forms)
     (fresh-line)
     (print-trace-indentation)
     (format t "~S = ~S" (car ele) (funcall (cdr ele) frame))))
 

-;;; Test a break option, and break if true.
+;;; Test a BREAK option, and break if true.

 (defun trace-maybe-break (info break where frame)
   (when (and break (funcall (cdr break) frame))
     (sb-di:flush-frames-above frame)
 (defun trace-maybe-break (info break where frame)
   (when (and break (funcall (cdr break) frame))
     (sb-di:flush-frames-above frame)

@@ -217,15 +213,15 @@
             where
             (trace-info-what info)))))
 
             where
             (trace-info-what info)))))
 

-;;; This function discards any invalid cookies on our simulated stack.
-;;; Encapsulated entries are always valid, since we bind
-;;; *TRACED-ENTRIES* in the encapsulation.
+;;; Discard any invalid cookies on our simulated stack. Encapsulated
+;;; entries are always valid, since we bind *TRACED-ENTRIES* in the
+;;; encapsulation.

 (defun discard-invalid-entries (frame)
   (loop
     (when (or (null *traced-entries*)
              (let ((cookie (caar *traced-entries*)))
                (or (not cookie)
 (defun discard-invalid-entries (frame)
   (loop
     (when (or (null *traced-entries*)
              (let ((cookie (caar *traced-entries*)))
                (or (not cookie)

-                   (sb-di:function-end-cookie-valid-p frame cookie))))
+                   (sb-di:fun-end-cookie-valid-p frame cookie))))

       (return))
     (pop *traced-entries*)))
 \f
       (return))
     (pop *traced-entries*)))
 \f

@@ -233,7 +229,7 @@
 
 ;;; Return a closure that can be used for a function start breakpoint
 ;;; hook function and a closure that can be used as the
 
 ;;; Return a closure that can be used for a function start breakpoint
 ;;; hook function and a closure that can be used as the

-;;; FUNCTION-END-COOKIE function. The first communicates the sense of
+;;; FUN-END-COOKIE function. The first communicates the sense of

 ;;; the Condition to the second via a closure variable.
 (defun trace-start-breakpoint-fun (info)
   (let (conditionp)
 ;;; the Condition to the second via a closure variable.
 (defun trace-start-breakpoint-fun (info)
   (let (conditionp)

@@ -306,8 +302,8 @@
                             frame)))))
 \f
 ;;; This function is called by the trace encapsulation. It calls the
                             frame)))))
 \f
 ;;; This function is called by the trace encapsulation. It calls the

-;;; breakpoint hook functions with NIL for the breakpoint and cookie, which
-;;; we have cleverly contrived to work for our hook functions.
+;;; breakpoint hook functions with NIL for the breakpoint and cookie,
+;;; which we have cleverly contrived to work for our hook functions.

 (defun trace-call (info)
   (multiple-value-bind (start cookie) (trace-start-breakpoint-fun info)
     (let ((frame (sb-di:frame-down (sb-di:top-frame))))
 (defun trace-call (info)
   (multiple-value-bind (start cookie) (trace-start-breakpoint-fun info)
     (let ((frame (sb-di:frame-down (sb-di:top-frame))))

@@ -334,18 +330,17 @@
                  (nth-value 2 (trace-fdefinition definition)))
          (trace-fdefinition function-or-name))
     (when (gethash fun *traced-functions*)
                  (nth-value 2 (trace-fdefinition definition)))
          (trace-fdefinition function-or-name))
     (when (gethash fun *traced-functions*)

-      ;; FIXME: should be STYLE-WARNING
-      (warn "Function ~S is already TRACE'd, retracing it." function-or-name)
+      (warn "~S is already TRACE'd, untracing it." function-or-name)

       (untrace-1 fun))
 
       (untrace-1 fun))
 

-    (let* ((debug-fun (sb-di:function-debug-function fun))
+    (let* ((debug-fun (sb-di:fun-debug-fun fun))

           (encapsulated
            (if (eq (trace-info-encapsulated info) :default)
                (ecase kind
                  (:compiled nil)
                  (:compiled-closure
                   (unless (functionp function-or-name)
           (encapsulated
            (if (eq (trace-info-encapsulated info) :default)
                (ecase kind
                  (:compiled nil)
                  (:compiled-closure
                   (unless (functionp function-or-name)

-                    (warn "Tracing shared code for ~S:~%  ~S"
+                    (warn "tracing shared code for ~S:~%  ~S"

                           function-or-name
                           fun))
                   nil)
                           function-or-name
                           fun))
                   nil)

@@ -354,7 +349,7 @@
                (trace-info-encapsulated info)))
           (loc (if encapsulated
                    :encapsulated
                (trace-info-encapsulated info)))
           (loc (if encapsulated
                    :encapsulated

-                   (sb-di:debug-function-start-location debug-fun)))
+                   (sb-di:debug-fun-start-location debug-fun)))

           (info (make-trace-info
                  :what function-or-name
                  :named named
           (info (make-trace-info
                  :what function-or-name
                  :named named

@@ -380,21 +375,21 @@
        (unless named
          (error "can't use encapsulation to trace anonymous function ~S"
                 fun))
        (unless named
          (error "can't use encapsulation to trace anonymous function ~S"
                 fun))

-       (sb-int:encapsulate function-or-name 'trace `(trace-call ',info)))
+       (encapsulate function-or-name 'trace `(trace-call ',info)))

        (t
        (multiple-value-bind (start-fun cookie-fun)
            (trace-start-breakpoint-fun info)
          (let ((start (sb-di:make-breakpoint start-fun debug-fun
        (t
        (multiple-value-bind (start-fun cookie-fun)
            (trace-start-breakpoint-fun info)
          (let ((start (sb-di:make-breakpoint start-fun debug-fun

-                                             :kind :function-start))
+                                             :kind :fun-start))

                (end (sb-di:make-breakpoint
                      (trace-end-breakpoint-fun info)
                (end (sb-di:make-breakpoint
                      (trace-end-breakpoint-fun info)

-                     debug-fun :kind :function-end
-                     :function-end-cookie cookie-fun)))
+                     debug-fun :kind :fun-end
+                     :fun-end-cookie cookie-fun)))

            (setf (trace-info-start-breakpoint info) start)
            (setf (trace-info-end-breakpoint info) end)
            ;; The next two forms must be in the order in which they
            ;; appear, since the start breakpoint must run before the
            (setf (trace-info-start-breakpoint info) start)
            (setf (trace-info-end-breakpoint info) end)
            ;; The next two forms must be in the order in which they
            ;; appear, since the start breakpoint must run before the

-           ;; function-end breakpoint's start helper (which calls the
+           ;; fun-end breakpoint's start helper (which calls the

            ;; cookie function.) One reason is that cookie function
            ;; requires that the CONDITIONP shared closure variable be
            ;; initialized.
            ;; cookie function.) One reason is that cookie function
            ;; requires that the CONDITIONP shared closure variable be
            ;; initialized.

@@ -577,7 +572,7 @@
      (t
       (cond
        ((trace-info-encapsulated info)
      (t
       (cond
        ((trace-info-encapsulated info)

-       (sb-int:unencapsulate (trace-info-what info) 'trace))
+       (unencapsulate (trace-info-what info) 'trace))

        (t
        (sb-di:delete-breakpoint (trace-info-start-breakpoint info))
        (sb-di:delete-breakpoint (trace-info-end-breakpoint info))))
        (t
        (sb-di:delete-breakpoint (trace-info-start-breakpoint info))
        (sb-di:delete-breakpoint (trace-info-end-breakpoint info))))