;;; 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.
;;; value is one of :COMPILED, :COMPILED-CLOSURE, :INTERPRETED,
;;; :INTERPRETED-CLOSURE and :FUNCALLABLE-INSTANCE.
(defun trace-fdefinition (x)
- (multiple-value-bind (res named-p)
- (typecase x
- (symbol
- (cond ((special-operator-p x)
- (error "can't trace special form ~S" x))
- ((macro-function x))
- (t
- (values (fdefinition x) t))))
- (function x)
- (t (values (fdefinition x) t)))
- (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)))))
+ (flet ((get-def ()
+ (if (valid-function-name-p x)
+ (if (fboundp x)
+ (fdefinition x)
+ (warn "~/sb-impl::print-symbol-with-prefix/ is ~
+ undefined, not tracing." x))
+ (warn "~S is not a valid function name, not tracing." x))))
+ (multiple-value-bind (res named-p)
+ (typecase x
+ (symbol
+ (cond ((special-operator-p x)
+ (warn "~S is a special operator, not tracing." x))
+ ((macro-function x))
+ (t
+ (values (get-def) t))))
+ (function
+ x)
+ (t
+ (values (get-def) t)))
+ (typecase res
+ (closure
+ (values (sb-kernel:%closure-fun res)
+ named-p
+ :compiled-closure))
+ (funcallable-instance
+ (values res named-p :funcallable-instance))
+ ;; 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.
(dolist (ele forms)
(fresh-line)
(print-trace-indentation)
- (format t "~@<~S ~_= ~S~:>" (car ele) (funcall (cdr ele) frame))
+ (format t "~@<~S ~_= ~:[; No values~;~:*~{~S~^, ~}~]~:>"
+ (car ele)
+ (multiple-value-list (funcall (cdr ele) frame)))
(terpri)))
;;; Test a BREAK option, and if true, break.
(*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*)
(values definition t
(nth-value 2 (trace-fdefinition definition)))
(trace-fdefinition function-or-name))
- (when (gethash fun *traced-funs*)
- (warn "~S is already TRACE'd, untracing it first." function-or-name)
- (untrace-1 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)
- (warn "tracing shared code for ~S:~% ~S"
- function-or-name
- fun))
- nil)
- ((:interpreted :interpreted-closure :funcallable-instance)
- t))
- (trace-info-encapsulated info)))
- (loc (if encapsulated
- :encapsulated
- (sb-di:debug-fun-start-location debug-fun)))
- (info (make-trace-info
- :what function-or-name
- :named named
- :encapsulated encapsulated
- :wherein (trace-info-wherein info)
- :methods (trace-info-methods info)
- :condition (coerce-form (trace-info-condition info) loc)
- :break (coerce-form (trace-info-break info) loc)
- :print (coerce-form-list (trace-info-print info) loc)
- :break-after (coerce-form (trace-info-break-after info) nil)
- :condition-after
- (coerce-form (trace-info-condition-after info) nil)
- :print-after
- (coerce-form-list (trace-info-print-after info) nil))))
-
- (dolist (wherein (trace-info-wherein info))
- (unless (or (stringp wherein)
- (fboundp wherein))
- (warn ":WHEREIN name ~S is not a defined global function."
- wherein)))
-
- (cond
- (encapsulated
- (unless named
- (error "can't use encapsulation to trace anonymous function ~S"
- fun))
- (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
- :kind :fun-start))
- (end (sb-di:make-breakpoint
- (trace-end-breakpoint-fun info)
- 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
- ;; 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)))))
-
- (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)
- ;; 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)))))
-
- function-or-name)
+ (when fun
+ (when (gethash fun *traced-funs*)
+ (warn "~S is already TRACE'd, untracing it first." function-or-name)
+ (untrace-1 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)
+ (warn "tracing shared code for ~S:~% ~S"
+ function-or-name
+ fun))
+ nil)
+ ((:interpreted :interpreted-closure :funcallable-instance)
+ t))
+ (trace-info-encapsulated info)))
+ (loc (if encapsulated
+ :encapsulated
+ (sb-di:debug-fun-start-location debug-fun)))
+ (info (make-trace-info
+ :what function-or-name
+ :named named
+ :encapsulated encapsulated
+ :wherein (trace-info-wherein info)
+ :methods (trace-info-methods info)
+ :condition (coerce-form (trace-info-condition info) loc)
+ :break (coerce-form (trace-info-break info) loc)
+ :print (coerce-form-list (trace-info-print info) loc)
+ :break-after (coerce-form (trace-info-break-after info) nil)
+ :condition-after
+ (coerce-form (trace-info-condition-after info) nil)
+ :print-after
+ (coerce-form-list (trace-info-print-after info) nil))))
+
+ (dolist (wherein (trace-info-wherein info))
+ (unless (or (stringp wherein)
+ (fboundp wherein))
+ (warn ":WHEREIN name ~S is not a defined global function."
+ wherein)))
+
+ (cond
+ (encapsulated
+ (unless named
+ (error "can't use encapsulation to trace anonymous function ~S"
+ fun))
+ (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
+ :kind :fun-start))
+ (end (sb-di:make-breakpoint
+ (trace-end-breakpoint-fun info)
+ 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
+ ;; 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)))))
+
+ (setf (gethash fun *traced-funs*) info))
+
+ (when (and (typep fun 'generic-function)
+ (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. 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
;;;; the TRACE macro
((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.
(setq current (parse-trace-options current options)))))
`(let ,(binds)
- (list ,@(forms)))))
+ (remove nil (list ,@(forms))))))
(defun %list-traced-funs ()
(loop for x being each hash-value in *traced-funs*
;;; Untrace one function.
(defun untrace-1 (function-or-name)
(let* ((fun (trace-fdefinition function-or-name))
- (info (gethash fun *traced-funs*)))
+ (info (when fun (gethash fun *traced-funs*))))
(cond
- ((not info)
- (warn "Function is not TRACEd: ~S" function-or-name))
- (t
- (cond
- ((trace-info-encapsulated info)
- (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))))
- (setf (trace-info-untraced info) t)
- (remhash fun *traced-funs*)))))
+ ((and fun (not info))
+ (warn "Function is not TRACEd: ~S" function-or-name))
+ ((not fun)
+ ;; Someone has FMAKUNBOUND it.
+ (let ((table *traced-funs*))
+ (with-locked-system-table (table)
+ (maphash (lambda (fun info)
+ (when (equal function-or-name (trace-info-what info))
+ (remhash fun table)))
+ table))))
+ (t
+ (cond
+ ((trace-info-encapsulated info)
+ (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))))
+ (setf (trace-info-untraced info) t)
+ (remhash fun *traced-funs*)))))
;;; Untrace all traced functions.
(defun untrace-all ()
(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)))
projects / sbcl.git / blobdiff