X-Git-Url: http://repo.macrolet.net/gitweb/?a=blobdiff_plain;f=src%2Fcode%2Fntrace.lisp;h=ce60ee6ca4255c7723741544425863b5bfc8f4f1;hb=f2db6743b1fadeea9e72cb583d857851c87efcd4;hp=f4bbf63660ff9c83e58a069ad0a01bb406aa7639;hpb=dc3c6bfad38cbd96013cf76ce93a9273f01c46d2;p=sbcl.git

diff --git a/src/code/ntrace.lisp b/src/code/ntrace.lisp
index f4bbf63..ce60ee6 100644
--- a/src/code/ntrace.lisp
+++ b/src/code/ntrace.lisp
@@ -37,7 +37,7 @@
 
 ;;; 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-funs* (make-hash-table :test 'eq))
+(defvar *traced-funs* (make-hash-table :test 'eq :synchronized t))
 
 ;;; A TRACE-INFO object represents all the information we need to
 ;;; trace a given function.
@@ -127,14 +127,17 @@
                 (values (fdefinition x) t))))
         (function x)
         (t (values (fdefinition x) t)))
-    (case (sb-kernel:widetag-of res)
-      (#.sb-vm:closure-header-widetag
+    (typecase res
+      (closure
        (values (sb-kernel:%closure-fun res)
                named-p
                :compiled-closure))
-      (#.sb-vm:funcallable-instance-header-widetag
+      (funcallable-instance
        (values res named-p :funcallable-instance))
-      (t (values res named-p :compiled)))))
+      ;; FIXME: What about SB!EVAL:INTERPRETED-FUNCTION -- it gets picked off
+      ;; by the FIN above, is that right?
+      (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.
@@ -265,7 +268,8 @@
                ;; with DEFVAR.
                (locally
                  (declare (special basic-definition arg-list))
-                 (prin1 `(,(trace-info-what info) ,@arg-list)))
+                 (prin1 `(,(trace-info-what info)
+                          ,@(mapcar #'ensure-printable-object arg-list))))
                (print-frame-call frame *standard-output*))
            (terpri)
            (trace-print frame (trace-info-print info))
@@ -301,15 +305,16 @@
               (*standard-output* (make-string-output-stream))
               (*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)
+          (let ((*print-pretty* t))
+            (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 (ensure-printable-object v))))
+            (terpri))
           (trace-print frame (trace-info-print-after info))
           (write-sequence (get-output-stream-string *standard-output*)
                           *trace-output*)
@@ -419,21 +424,23 @@
       (setf (gethash fun *traced-funs*) info))
 
     (when (and (typep fun 'generic-function)
-               (trace-info-methods info))
-      (dolist (method-name (sb-pcl::list-all-maybe-method-names fun))
-        (when (fboundp method-name)
+               (trace-info-methods info)
+               ;; we are going to trace the method functions directly.
+               (not (trace-info-encapsulated info)))
+      (dolist (method (sb-mop:generic-function-methods fun))
+        (let ((mf (sb-mop:method-function method)))
           ;; NOTE: this direct style of tracing methods -- tracing the
           ;; pcl-internal method functions -- is only one possible
           ;; alternative.  It fails (a) when encapulation is
           ;; requested, because the function objects themselves are
           ;; stored in the method object; (b) when the method in
           ;; question is particularly simple, when the method
-          ;; functionality is in the dfun.  There is an alternative
-          ;; technique: to replace any currently active methods with
-          ;; methods which encapsulate the current one.  Steps towards
-          ;; this are currently commented out in src/pcl/env.lisp.  --
-          ;; CSR, 2005-01-03
-          (trace-1 method-name info)))))
+          ;; functionality is in the dfun.  See src/pcl/env.lisp for a
+          ;; stub implementation of encapsulating through a
+          ;; traced-method class.
+          (trace-1 mf info)
+          (when (typep mf 'sb-pcl::%method-function)
+            (trace-1 (sb-pcl::%method-function-fast-function mf) info))))))
 
   function-or-name)
 
@@ -509,11 +516,14 @@
            ((stringp name)
             (let ((package (find-undeleted-package-or-lose name)))
               (do-all-symbols (symbol (find-package name))
-                (when (and (eql package (symbol-package symbol))
-                           (fboundp symbol)
-                           (not (macro-function symbol))
-                           (not (special-operator-p symbol)))
-                  (forms `(trace-1 ',symbol ',options))))))
+                (when (eql package (symbol-package symbol))
+                  (when (and (fboundp symbol)
+                             (not (macro-function symbol))
+                             (not (special-operator-p symbol)))
+                    (forms `(trace-1 ',symbol ',options)))
+                  (let ((setf-name `(setf ,symbol)))
+                    (when (fboundp setf-name)
+                      (forms `(trace-1 ',setf-name ',options))))))))
            ;; special-case METHOD: it itself is not a general function
            ;; name symbol, but it (at least here) designates one of a
            ;; pair of such.
@@ -654,23 +664,30 @@ are evaluated in the null environment."
     (untrace-1 fun))
   t)
 
+(defun untrace-package (name)
+  (let ((package (find-package name)))
+    (when package
+      (dolist (fun (%list-traced-funs))
+        (cond ((and (symbolp fun) (eq package (symbol-package fun)))
+               (untrace-1 fun))
+              ((and (consp fun) (eq 'setf (car fun))
+                    (symbolp (second fun))
+                    (eq package (symbol-package (second fun))))
+               (untrace-1 fun)))))))
+
 (defmacro untrace (&rest specs)
   #+sb-doc
-  "Remove tracing from the specified functions. With no args, untrace all
-   functions."
-  ;; KLUDGE: Since we now allow (TRACE FOO BAR "SB-EXT") to trace not
-  ;; only #'FOO and #'BAR but also all the functions in #<PACKAGE "SB-EXT">,
-  ;; it would be probably be best for consistency to do something similar
-  ;; with UNTRACE. (But I leave it to someone who uses and cares about
-  ;; UNTRACE-with-args more often than I do.) -- WHN 2003-12-17
+  "Remove tracing from the specified functions. Untraces all
+functions when called with no arguments."
   (if specs
-      (collect ((res))
-        (let ((current specs))
-          (loop
-            (unless current (return))
-            (let ((name (pop current)))
-              (res (if (eq name :function)
-                       `(untrace-1 ,(pop current))
-                       `(untrace-1 ',name)))))
-          `(progn ,@(res) t)))
+      `(progn
+         ,@(loop while specs
+                 for name = (pop specs)
+                 collect (cond ((eq name :function)
+                                `(untrace-1 ,(pop specs)))
+                               ((stringp name)
+                                `(untrace-package ,name))
+                               (t
+                                `(untrace-1 ',name))))
+         t)
       '(untrace-all)))