;;; 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.
(*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 (ensure-printable-object 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*)
(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)
\f
((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.
(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)))