0.7.8.36:

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

diff --git a/src/code/ntrace.lisp b/src/code/ntrace.lisp
index c1e5eeb..d666736 100644 (file)
--- a/src/code/ntrace.lisp
+++ b/src/code/ntrace.lisp
@@ -29,15 +29,15 @@
   "If the trace indentation exceeds this value, then indentation restarts at
    0.")
 
   "If the trace indentation exceeds this value, then indentation restarts at
    0.")
 

-(defvar *trace-encapsulate-default* :default
+(defvar *trace-encapsulate-default* t

   #+sb-doc
   "the default value for the :ENCAPSULATE option to TRACE")
 \f
 ;;;; internal state
 
 ;;; a hash table that maps each traced function to the TRACE-INFO. The
   #+sb-doc
   "the default value for the :ENCAPSULATE option to TRACE")
 \f
 ;;;; internal state
 
 ;;; a hash table that maps each traced function to the TRACE-INFO. The

-;;; entry for a closure is the shared function-entry object.
-(defvar *traced-functions* (make-hash-table :test 'eq))
+;;; entry for a closure is the shared function entry object.
+(defvar *traced-funs* (make-hash-table :test 'eq))

 
 ;;; A TRACE-INFO object represents all the information we need to
 ;;; trace a given function.
 
 ;;; A TRACE-INFO object represents all the information we need to
 ;;; trace a given function.

@@ -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,59 +125,56 @@
                (values (fdefinition x) t))))
        (function x)
        (t (values (fdefinition x) t)))
                (values (fdefinition x) t))))
        (function x)
        (t (values (fdefinition x) t)))

-    (if (or #+sb-interpreter (sb-eval:interpreted-function-p res)
-           nil)
-       (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.
 (defun trace-redefined-update (fname new-value)
   (when (fboundp fname)
     (let* ((fun (trace-fdefinition fname))
 
 ;;; When a function name is redefined, and we were tracing that name,
 ;;; then untrace the old definition and trace the new one.
 (defun trace-redefined-update (fname new-value)
   (when (fboundp fname)
     (let* ((fun (trace-fdefinition fname))

-          (info (gethash fun *traced-functions*)))
+          (info (gethash fun *traced-funs*)))

       (when (and info (trace-info-named info))
        (untrace-1 fname)
        (trace-1 fname info new-value)))))
 (push #'trace-redefined-update *setf-fdefinition-hook*)
 
       (when (and info (trace-info-named info))
        (untrace-1 fname)
        (trace-1 fname info new-value)))))
 (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
-;;; to use for the lexical environment. If Loc is NIL, evaluate in the
-;;; null environment. If Form is NIL, just return NIL.
+;;; Annotate a FORM to evaluate with pre-converted functions. FORM is
+;;; really a cons (EXP . FUNCTION). LOC is the code location to use
+;;; for the lexical environment. If LOC is NIL, evaluate in the null
+;;; environment. If FORM is NIL, just return NIL.

 (defun coerce-form (form loc)
   (when form
     (let ((exp (car form)))
       (if (sb-di:code-location-p loc)
          (let ((fun (sb-di:preprocess-for-eval exp loc)))
            (cons exp
 (defun coerce-form (form loc)
   (when form
     (let ((exp (car form)))
       (if (sb-di:code-location-p loc)
          (let ((fun (sb-di:preprocess-for-eval exp loc)))
            (cons exp

-                 #'(lambda (frame)
-                     (let ((*current-frame* frame))
-                       (funcall fun frame)))))
+                 (lambda (frame)
+                   (let ((*current-frame* frame))
+                     (funcall fun frame)))))

          (let* ((bod (ecase loc
                        ((nil) exp)
                        (:encapsulated
                         `(flet ((sb-debug:arg (n)
          (let* ((bod (ecase loc
                        ((nil) exp)
                        (:encapsulated
                         `(flet ((sb-debug:arg (n)

-                                  (declare (special argument-list))
-                                  (elt argument-list n)))
+                                  (declare (special arg-list))
+                                  (elt arg-list n)))

                            (declare (ignorable #'sb-debug:arg))
                            ,exp))))
                 (fun (coerce `(lambda () ,bod) 'function)))
            (cons exp
                            (declare (ignorable #'sb-debug:arg))
                            ,exp))))
                 (fun (coerce `(lambda () ,bod) 'function)))
            (cons exp

-                 #'(lambda (frame)
-                     (declare (ignore frame))
-                     (let ((*current-frame* nil))
-                       (funcall fun)))))))))
+                 (lambda (frame)
+                   (declare (ignore frame))
+                   (let ((*current-frame* nil))
+                     (funcall fun)))))))))
+

 (defun coerce-form-list (forms loc)
 (defun coerce-form-list (forms loc)

-  (mapcar #'(lambda (x) (coerce-form x loc)) forms))
+  (mapcar (lambda (x) (coerce-form x loc)) forms))

 
 ;;; Print indentation according to the number of trace entries.
 ;;; Entries whose condition was false don't count.
 
 ;;; Print indentation according to the number of trace entries.
 ;;; Entries whose condition was false don't count.

@@ -186,30 +183,29 @@
     (dolist (entry *traced-entries*)
       (when (cdr entry) (incf depth)))
     (format t
     (dolist (entry *traced-entries*)
       (when (cdr entry) (incf depth)))
     (format t

-           "~@V,0T~D: "
+           "~V,0@T~W: "

            (+ (mod (* depth *trace-indentation-step*)
                    (- *max-trace-indentation* *trace-indentation-step*))
               *trace-indentation-step*)
            depth)))
 
            (+ (mod (* depth *trace-indentation-step*)
                    (- *max-trace-indentation* *trace-indentation-step*))
               *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)
 (defun trace-print (frame forms)
   (dolist (ele forms)
     (fresh-line)
     (print-trace-indentation)

-    (format t "~S = ~S" (car ele) (funcall (cdr ele) frame))))
+    (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)

@@ -218,15 +214,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

@@ -234,40 +230,44 @@
 
 ;;; 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)
     (values
 ;;; the Condition to the second via a closure variable.
 (defun trace-start-breakpoint-fun (info)
   (let (conditionp)
     (values

-     #'(lambda (frame bpt)
-        (declare (ignore bpt))
-        (discard-invalid-entries frame)
-        (let ((condition (trace-info-condition info))
-              (wherein (trace-info-wherein info)))
-          (setq conditionp
-                (and (not *in-trace*)
-                     (or (not condition)
-                         (funcall (cdr condition) frame))
-                     (or (not wherein)
-                         (trace-wherein-p frame wherein)))))
-
-        (when conditionp
-          (let ((sb-kernel:*current-level* 0)
-                (*standard-output* *trace-output*)
-                (*in-trace* t))
-            (fresh-line)
-            (print-trace-indentation)
-            (if (trace-info-encapsulated info)
-                (locally (declare (special basic-definition argument-list))
-                  (prin1 `(,(trace-info-what info) ,@argument-list)))
-                (print-frame-call frame))
-            (terpri)
-            (trace-print frame (trace-info-print info)))
-          (trace-maybe-break info (trace-info-break info) "before" frame)))
-
-     #'(lambda (frame cookie)
-        (declare (ignore frame))
-        (push (cons cookie conditionp) *traced-entries*)))))
+
+     (lambda (frame bpt)
+       (declare (ignore bpt))
+       (discard-invalid-entries frame)
+       (let ((condition (trace-info-condition info))
+            (wherein (trace-info-wherein info)))
+        (setq conditionp
+              (and (not *in-trace*)
+                   (or (not condition)
+                       (funcall (cdr condition) frame))
+                   (or (not wherein)
+                       (trace-wherein-p frame wherein)))))
+       (when conditionp
+        (let ((sb-kernel:*current-level-in-print* 0)
+              (*standard-output* *trace-output*)
+              (*in-trace* t))
+          (fresh-line)
+          (print-trace-indentation)
+          (if (trace-info-encapsulated info)
+              ;; FIXME: These special variables should be given
+              ;; *FOO*-style names, and probably declared globally
+              ;; with DEFVAR.
+              (locally
+                (declare (special basic-definition arg-list))
+                (prin1 `(,(trace-info-what info) ,@arg-list)))
+              (print-frame-call frame))
+          (terpri)
+          (trace-print frame (trace-info-print info)))
+        (trace-maybe-break info (trace-info-break info) "before" frame)))
+
+     (lambda (frame cookie)
+       (declare (ignore frame))
+       (push (cons cookie conditionp) *traced-entries*)))))

 
 ;;; This prints a representation of the return values delivered.
 ;;; First, this checks to see that cookie is at the top of
 
 ;;; This prints a representation of the return values delivered.
 ;;; First, this checks to see that cookie is at the top of

@@ -276,49 +276,49 @@
 ;;; see whether the function is still traced and that the condition
 ;;; succeeded before printing anything.
 (defun trace-end-breakpoint-fun (info)
 ;;; see whether the function is still traced and that the condition
 ;;; succeeded before printing anything.
 (defun trace-end-breakpoint-fun (info)

-  #'(lambda (frame bpt *trace-values* cookie)
-      (declare (ignore bpt))
-      (unless (eq cookie (caar *traced-entries*))
-       (setf *traced-entries*
-             (member cookie *traced-entries* :key #'car)))
-
-      (let ((entry (pop *traced-entries*)))
-       (when (and (not (trace-info-untraced info))
-                  (or (cdr entry)
-                      (let ((cond (trace-info-condition-after info)))
-                        (and cond (funcall (cdr cond) frame)))))
-         (let ((sb-kernel:*current-level* 0)
-               (*standard-output* *trace-output*)
-               (*in-trace* t))
-           (fresh-line)
-           (pprint-logical-block (*standard-output* nil)
-             (print-trace-indentation)
-             (pprint-indent :current 2)
-             (format t "~S returned" (trace-info-what info))
-             (dolist (v *trace-values*)
-               (write-char #\space)
-               (pprint-newline :linear)
-               (prin1 v)))
-           (terpri)
-           (trace-print frame (trace-info-print-after info)))
-         (trace-maybe-break info
-                            (trace-info-break-after info)
-                            "after"
-                            frame)))))
+  (lambda (frame bpt *trace-values* cookie)
+    (declare (ignore bpt))
+    (unless (eq cookie (caar *traced-entries*))
+      (setf *traced-entries*
+           (member cookie *traced-entries* :key #'car)))
+
+    (let ((entry (pop *traced-entries*)))
+      (when (and (not (trace-info-untraced info))
+                (or (cdr entry)
+                    (let ((cond (trace-info-condition-after info)))
+                      (and cond (funcall (cdr cond) frame)))))
+       (let ((sb-kernel:*current-level-in-print* 0)
+             (*standard-output* *trace-output*)
+             (*in-trace* t))
+         (fresh-line)
+         (pprint-logical-block (*standard-output* nil)
+           (print-trace-indentation)
+           (pprint-indent :current 2)
+           (format t "~S returned" (trace-info-what info))
+           (dolist (v *trace-values*)
+             (write-char #\space)
+             (pprint-newline :linear)
+             (prin1 v)))
+         (terpri)
+         (trace-print frame (trace-info-print-after info)))
+       (trace-maybe-break info
+                          (trace-info-break-after info)
+                          "after"
+                          frame)))))

 \f
 ;;; This function is called by the trace encapsulation. It calls the
 \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))))
       (funcall start frame nil)
       (let ((*traced-entries* *traced-entries*))
 (defun trace-call (info)
   (multiple-value-bind (start cookie) (trace-start-breakpoint-fun info)
     (let ((frame (sb-di:frame-down (sb-di:top-frame))))
       (funcall start frame nil)
       (let ((*traced-entries* *traced-entries*))

-       (declare (special basic-definition argument-list))
+       (declare (special basic-definition arg-list))

        (funcall cookie frame nil)
        (let ((vals
               (multiple-value-list
        (funcall cookie frame nil)
        (let ((vals
               (multiple-value-list

-               (apply basic-definition argument-list))))
+               (apply basic-definition arg-list))))

          (funcall (trace-end-breakpoint-fun info) frame nil vals nil)
          (values-list vals))))))
 \f
          (funcall (trace-end-breakpoint-fun info) frame nil vals nil)
          (values-list vals))))))
 \f

@@ -334,18 +334,18 @@
          (values definition t
                  (nth-value 2 (trace-fdefinition definition)))
          (trace-fdefinition function-or-name))
          (values definition t
                  (nth-value 2 (trace-fdefinition definition)))
          (trace-fdefinition function-or-name))

-    (when (gethash fun *traced-functions*)
+    (when (gethash fun *traced-funs*)

       (warn "~S is already TRACE'd, untracing it." function-or-name)
       (untrace-1 fun))
 
       (warn "~S is already TRACE'd, untracing it." function-or-name)
       (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 +354,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

@@ -385,23 +385,23 @@
        (multiple-value-bind (start-fun cookie-fun)
            (trace-start-breakpoint-fun info)
          (let ((start (sb-di:make-breakpoint start-fun debug-fun
        (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.
            (sb-di:activate-breakpoint start)
            (sb-di:activate-breakpoint end)))))
 
            ;; cookie function.) One reason is that cookie function
            ;; requires that the CONDITIONP shared closure variable be
            ;; initialized.
            (sb-di:activate-breakpoint start)
            (sb-di:activate-breakpoint end)))))
 

-      (setf (gethash fun *traced-functions*) info)))
+      (setf (gethash fun *traced-funs*) info)))

 
   function-or-name)
 \f
 
   function-or-name)
 \f

@@ -481,8 +481,8 @@
        `(let ,(binds) (list ,@(forms)))
        `(list ,@(forms)))))
 
        `(let ,(binds) (list ,@(forms)))
        `(list ,@(forms)))))
 

-(defun %list-traced-functions ()
-  (loop for x being each hash-value in *traced-functions*
+(defun %list-traced-funs ()
+  (loop for x being each hash-value in *traced-funs*

        collect (trace-info-what x)))
 
 (defmacro trace (&rest specs)
        collect (trace-info-what x)))
 
 (defmacro trace (&rest specs)

@@ -563,14 +563,14 @@
    -AFTER and -ALL forms are evaluated in the null environment."
   (if specs
       (expand-trace specs)
    -AFTER and -ALL forms are evaluated in the null environment."
   (if specs
       (expand-trace specs)

-      '(%list-traced-functions)))
+      '(%list-traced-funs)))

 \f
 ;;;; untracing
 
 ;;; Untrace one function.
 (defun untrace-1 (function-or-name)
   (let* ((fun (trace-fdefinition function-or-name))
 \f
 ;;;; untracing
 
 ;;; Untrace one function.
 (defun untrace-1 (function-or-name)
   (let* ((fun (trace-fdefinition function-or-name))

-        (info (gethash fun *traced-functions*)))
+        (info (gethash fun *traced-funs*)))

     (cond
      ((not info)
       (warn "Function is not TRACEd: ~S" function-or-name))
     (cond
      ((not info)
       (warn "Function is not TRACEd: ~S" function-or-name))

@@ -582,11 +582,11 @@
        (sb-di:delete-breakpoint (trace-info-start-breakpoint info))
        (sb-di:delete-breakpoint (trace-info-end-breakpoint info))))
       (setf (trace-info-untraced info) t)
        (sb-di:delete-breakpoint (trace-info-start-breakpoint info))
        (sb-di:delete-breakpoint (trace-info-end-breakpoint info))))
       (setf (trace-info-untraced info) t)

-      (remhash fun *traced-functions*)))))
+      (remhash fun *traced-funs*)))))

 
 ;;; Untrace all traced functions.
 (defun untrace-all ()
 
 ;;; Untrace all traced functions.
 (defun untrace-all ()

-  (dolist (fun (%list-traced-functions))
+  (dolist (fun (%list-traced-funs))

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