X-Git-Url: http://repo.macrolet.net/gitweb/?a=blobdiff_plain;f=src%2Fcode%2Fntrace.lisp;h=b6453870886e2bdbe0a4eae68373ed1a9e46b940;hb=e9c546b14771ebe96447c3920a75e9e580f9075f;hp=ded1ab7dc0424c37744b7be83edde2c9ac69f7c8;hpb=4898ef32c639b1c7f4ee13a5ba566ce6debd03e6;p=sbcl.git diff --git a/src/code/ntrace.lisp b/src/code/ntrace.lisp index ded1ab7..b645387 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. @@ -265,12 +265,14 @@ ;; 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)) (write-sequence (get-output-stream-string *standard-output*) - *trace-output*)) + *trace-output*) + (finish-output *trace-output*)) (trace-maybe-break info (trace-info-break info) "before" frame))) (lambda (frame cookie) @@ -300,18 +302,20 @@ (*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*)) + *trace-output*) + (finish-output *trace-output*)) (trace-maybe-break info (trace-info-break-after info) "after" @@ -417,21 +421,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) @@ -507,11 +513,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. @@ -652,23 +661,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 #, - ;; 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)))