-;;;; a tracing facility based on breakpoints
+;;;; a tracing facility
;;;; This software is part of the SBCL system. See the README file for
;;;; more information.
;;;; provided with absolutely no warranty. See the COPYING and CREDITS
;;;; files for more information.
-(in-package "SB-DEBUG")
+(in-package "SB-DEBUG") ; (SB-, not SB!, since we're built in warm load.)
;;; FIXME: Why, oh why, doesn't the SB-DEBUG package use the SB-DI
;;; package? That would let us get rid of a whole lot of stupid
"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
-;;; 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 :synchronized t))
;;; A TRACE-INFO object represents all the information we need to
;;; trace a given function.
(def!struct (trace-info
- (:make-load-form-fun sb-kernel:just-dump-it-normally)
- (:print-object (lambda (x stream)
- (print-unreadable-object (x stream :type t)
- (prin1 (trace-info-what x) stream)))))
+ (:make-load-form-fun sb-kernel:just-dump-it-normally)
+ (:print-object (lambda (x stream)
+ (print-unreadable-object (x stream :type t)
+ (prin1 (trace-info-what x) stream)))))
;; the original representation of the thing traced
(what nil :type (or function cons symbol))
;; Is WHAT a function name whose definition we should track?
(end-breakpoint nil :type (or sb-di:breakpoint null))
;; the list of function names for WHEREIN, or NIL if unspecified
(wherein nil :type list)
+ ;; should we trace methods given a generic function to trace?
+ (methods nil)
;; The following slots represent the forms that we are supposed to
;; evaluate on each iteration. Each form is represented by a cons
;; list of null environment forms
(print-after () :type list))
-;;; This is a list of conses (function-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. We must save the trace condition so
-;;; that the after breakpoint knows whether to print. The length of
-;;; this list tells us the indentation to use for printing TRACE
-;;; messages.
+;;; 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.
+;;; We must save the trace condition so that the after breakpoint
+;;; knows whether to print. The length of this list tells us the
+;;; indentation to use for printing TRACE messages.
;;;
;;; 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
;;; 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)))
- (if (sb-eval:interpreted-function-p res)
- (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))))))
+ (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.
(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 sb-int:*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.
+ (untrace-1 fname)
+ (trace-1 fname info new-value)))))
+(push #'trace-redefined-update *setf-fdefinition-hook*)
+
+;;; 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
- #'(lambda (frame)
- (let ((*current-frame* frame))
- (funcall fun frame)))))
- (let* ((bod (ecase loc
- ((nil) exp)
- (:encapsulated
- `(flet ((sb-debug:arg (n)
- (declare (special argument-list))
- (elt argument-list n)))
- (declare (ignorable #'sb-debug:arg))
- ,exp))))
- (fun (coerce `(lambda () ,bod) 'function)))
- (cons exp
- #'(lambda (frame)
- (declare (ignore frame))
- (let ((*current-frame* nil))
- (funcall fun)))))))))
+ (let ((fun (sb-di:preprocess-for-eval exp loc)))
+ (declare (type function fun))
+ (cons exp
+ (lambda (frame)
+ (let ((*current-frame* frame))
+ (funcall fun frame)))))
+ (let* ((bod (ecase loc
+ ((nil) exp)
+ (:encapsulated
+ `(locally (declare (disable-package-locks sb-debug:arg arg-list))
+ (flet ((sb-debug:arg (n)
+ (declare (special arg-list))
+ (elt arg-list n)))
+ (declare (ignorable #'sb-debug:arg)
+ (enable-package-locks sb-debug:arg arg-list))
+ ,exp)))))
+ (fun (coerce `(lambda () ,bod) 'function)))
+ (cons exp
+ (lambda (frame)
+ (declare (ignore frame))
+ (let ((*current-frame* nil))
+ (funcall fun)))))))))
+
(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.
(dolist (entry *traced-entries*)
(when (cdr entry) (incf depth)))
(format t
- "~@V,0T~D: "
- (+ (mod (* depth *trace-indentation-step*)
- (- *max-trace-indentation* *trace-indentation-step*))
- *trace-indentation-step*)
- depth)))
+ "~V,0@T~W: "
+ (+ (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)
- (when (member (sb-di:debug-function-name (sb-di:frame-debug-function
- frame))
- names
- :test #'equal)
+ (when (member (sb-di:debug-fun-name (sb-di:frame-debug-fun frame))
+ 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)
- (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 break if true.
+;;; Test a BREAK option, and if true, break.
(defun trace-maybe-break (info break where frame)
(when (and break (funcall (cdr break) frame))
(sb-di:flush-frames-above frame)
(let ((*stack-top-hint* frame))
(break "breaking ~A traced call to ~S:"
- 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)
- (sb-di:function-end-cookie-valid-p frame cookie))))
+ (let ((cookie (caar *traced-entries*)))
+ (or (not cookie)
+ (sb-di:fun-end-cookie-valid-p frame cookie))))
(return))
(pop *traced-entries*)))
\f
;;;; hook functions
;;; 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
-;;; the Condition to the second via a closure variable.
+;;; hook function and a closure that can be used as the FUN-END-COOKIE
+;;; function. The first communicates the sense of the
+;;; TRACE-INFO-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* (make-string-output-stream))
+ (*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)
+ ,@(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*)
+ (finish-output *trace-output*))
+ (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
-;;; *traced-entries*; if it is not, then we need to adjust this list
+;;; *TRACED-ENTRIES*; if it is not, then we need to adjust this list
;;; to determine the correct indentation for output. We then check to
;;; see whether the function is still traced and that the condition
;;; succeeded before printing anything.
+(declaim (ftype (function (trace-info) function) trace-end-breakpoint-fun))
(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* (make-string-output-stream))
+ (*in-trace* t))
+ (fresh-line)
+ (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*)
+ (finish-output *trace-output*))
+ (trace-maybe-break info
+ (trace-info-break-after info)
+ "after"
+ frame)))))
\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)
+ (declare (type function start cookie))
(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))
- (funcall cookie frame nil)
- (let ((vals
- (multiple-value-list
- (apply basic-definition argument-list))))
- (funcall (trace-end-breakpoint-fun info) frame nil vals nil)
- (values-list vals))))))
+ (declare (special basic-definition arg-list))
+ (funcall cookie frame nil)
+ (let ((vals
+ (multiple-value-list
+ (apply basic-definition arg-list))))
+ (funcall (trace-end-breakpoint-fun info) frame nil vals nil)
+ (values-list vals))))))
\f
;;; Trace one function according to the specified options. We copy the
;;; trace info (it was a quoted constant), fill in the functions, and
(defun trace-1 (function-or-name info &optional definition)
(multiple-value-bind (fun named kind)
(if definition
- (values definition t
- (nth-value 2 (trace-fdefinition definition)))
- (trace-fdefinition function-or-name))
- (when (gethash fun *traced-functions*)
- ;; FIXME: should be STYLE-WARNING
- (warn "Function ~S is already TRACE'd, retracing it." function-or-name)
- (untrace-1 fun))
-
- (let* ((debug-fun (sb-di:function-debug-function 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-function-start-location debug-fun)))
- (info (make-trace-info
- :what function-or-name
- :named named
- :encapsulated encapsulated
- :wherein (trace-info-wherein 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))
- (sb-int: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 :function-start))
- (end (sb-di:make-breakpoint
- (trace-end-breakpoint-fun info)
- debug-fun :kind :function-end
- :function-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
- ;; function-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-functions*) info)))
-
- function-or-name)
+ (values definition t
+ (nth-value 2 (trace-fdefinition definition)))
+ (trace-fdefinition 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
(loop
(when (endp current) (return))
(let ((option (first current))
- (value (cons (second current) nil)))
- (case option
- (:report (error "stub: The :REPORT option is not yet implemented."))
- (:condition (setf (trace-info-condition info) value))
- (:condition-after
- (setf (trace-info-condition info) (cons nil nil))
- (setf (trace-info-condition-after info) value))
- (:condition-all
- (setf (trace-info-condition info) value)
- (setf (trace-info-condition-after info) value))
- (:wherein
- (setf (trace-info-wherein info)
- (if (listp (car value)) (car value) value)))
- (:encapsulate
- (setf (trace-info-encapsulated info) (car value)))
- (:break (setf (trace-info-break info) value))
- (:break-after (setf (trace-info-break-after info) value))
- (:break-all
- (setf (trace-info-break info) value)
- (setf (trace-info-break-after info) value))
- (:print
- (setf (trace-info-print info)
- (append (trace-info-print info) (list value))))
- (:print-after
- (setf (trace-info-print-after info)
- (append (trace-info-print-after info) (list value))))
- (:print-all
- (setf (trace-info-print info)
- (append (trace-info-print info) (list value)))
- (setf (trace-info-print-after info)
- (append (trace-info-print-after info) (list value))))
- (t (return)))
- (pop current)
- (unless current
- (error "missing argument to ~S TRACE option" option))
- (pop current)))
+ (value (cons (second current) nil)))
+ (case option
+ (:report (error "stub: The :REPORT option is not yet implemented."))
+ (:condition (setf (trace-info-condition info) value))
+ (:condition-after
+ (setf (trace-info-condition info) (cons nil nil))
+ (setf (trace-info-condition-after info) value))
+ (:condition-all
+ (setf (trace-info-condition info) value)
+ (setf (trace-info-condition-after info) value))
+ (:wherein
+ (setf (trace-info-wherein info)
+ (if (listp (car value)) (car value) value)))
+ (:encapsulate
+ (setf (trace-info-encapsulated info) (car value)))
+ (:methods
+ (setf (trace-info-methods info) (car value)))
+ (:break (setf (trace-info-break info) value))
+ (:break-after (setf (trace-info-break-after info) value))
+ (:break-all
+ (setf (trace-info-break info) value)
+ (setf (trace-info-break-after info) value))
+ (:print
+ (setf (trace-info-print info)
+ (append (trace-info-print info) (list value))))
+ (:print-after
+ (setf (trace-info-print-after info)
+ (append (trace-info-print-after info) (list value))))
+ (:print-all
+ (setf (trace-info-print info)
+ (append (trace-info-print info) (list value)))
+ (setf (trace-info-print-after info)
+ (append (trace-info-print-after info) (list value))))
+ (t (return)))
+ (pop current)
+ (unless current
+ (error "missing argument to ~S TRACE option" option))
+ (pop current)))
current))
;;; Compute the expansion of TRACE in the non-trivial case (arguments
-;;; specified.) If there are no :FUNCTION specs, then don't use a LET.
-;;; This allows TRACE to be used without the full interpreter.
+;;; specified.)
(defun expand-trace (specs)
(collect ((binds)
- (forms))
+ (forms))
(let* ((global-options (make-trace-info))
- (current (parse-trace-options specs global-options)))
+ (current (parse-trace-options specs global-options)))
(loop
- (when (endp current) (return))
- (let ((name (pop current))
- (options (copy-trace-info global-options)))
- (cond
- ((eq name :function)
- (let ((temp (gensym)))
- (binds `(,temp ,(pop current)))
- (forms `(trace-1 ,temp ',options))))
- ((and (keywordp name)
- (not (or (fboundp name) (macro-function name))))
- (error "unknown TRACE option: ~S" name))
- (t
- (forms `(trace-1 ',name ',options))))
- (setq current (parse-trace-options current options)))))
-
- (if (binds)
- `(let ,(binds) (list ,@(forms)))
- `(list ,@(forms)))))
-
-(defun %list-traced-functions ()
- (loop for x being each hash-value in *traced-functions*
- collect (trace-info-what x)))
+ (when (endp current) (return))
+ (let ((name (pop current))
+ (options (copy-trace-info global-options)))
+ (cond
+ ((eq name :function)
+ (let ((temp (gensym)))
+ (binds `(,temp ,(pop current)))
+ (forms `(trace-1 ,temp ',options))))
+ ((and (keywordp name)
+ (not (or (fboundp name) (macro-function name))))
+ (error "unknown TRACE option: ~S" name))
+ ((stringp name)
+ (let ((package (find-undeleted-package-or-lose name)))
+ (do-all-symbols (symbol (find-package name))
+ (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.
+ ((and (consp name) (eq (car name) 'method))
+ (when (fboundp (list* 'sb-pcl::slow-method (cdr name)))
+ (forms `(trace-1 ',(list* 'sb-pcl::slow-method (cdr name))
+ ',options)))
+ (when (fboundp (list* 'sb-pcl::fast-method (cdr name)))
+ (forms `(trace-1 ',(list* 'sb-pcl::fast-method (cdr name))
+ ',options))))
+ (t
+ (forms `(trace-1 ',name ',options))))
+ (setq current (parse-trace-options current options)))))
+
+ `(let ,(binds)
+ (remove nil (list ,@(forms))))))
+
+(defun %list-traced-funs ()
+ (loop for x being each hash-value in *traced-funs*
+ collect (trace-info-what x)))
(defmacro trace (&rest specs)
#+sb-doc
"TRACE {Option Global-Value}* {Name {Option Value}*}*
- TRACE is a debugging tool that provides information when specified functions
- are called. In its simplest form:
- (trace Name-1 Name-2 ...)
- (The Names are not evaluated.)
-
- Options allow modification of the default behavior. Each option is a pair
- of an option keyword and a value form. Global options are specified before
- the first name, and affect all functions traced by a given use of TRACE.
- Options may also be interspersed with function names, in which case they
- act as local options, only affecting tracing of the immediately preceding
- function name. Local options override global options.
-
- By default, TRACE causes a printout on *TRACE-OUTPUT* each time that
- one of the named functions is entered or returns. (This is the
- basic, ANSI Common Lisp behavior of TRACE.) As an SBCL extension, the
- :REPORT SB-EXT:PROFILE option can be used to instead cause information
- to be silently recorded to be inspected later using the SB-EXT:PROFILE
- function.
-
- The following options are defined:
+
+TRACE is a debugging tool that provides information when specified
+functions are called. In its simplest form:
+
+ (TRACE NAME-1 NAME-2 ...)
+
+The NAMEs are not evaluated. Each may be a symbol, denoting an
+individual function, or a string, denoting all functions fbound to
+symbols whose home package is the package with the given name.
+
+Options allow modification of the default behavior. Each option is a
+pair of an option keyword and a value form. Global options are
+specified before the first name, and affect all functions traced by a
+given use of TRACE. Options may also be interspersed with function
+names, in which case they act as local options, only affecting tracing
+of the immediately preceding function name. Local options override
+global options.
+
+By default, TRACE causes a printout on *TRACE-OUTPUT* each time that
+one of the named functions is entered or returns. (This is the basic,
+ANSI Common Lisp behavior of TRACE.) As an SBCL extension, the
+:REPORT SB-EXT:PROFILE option can be used to instead cause information
+to be silently recorded to be inspected later using the SB-EXT:PROFILE
+function.
+
+The following options are defined:
:REPORT Report-Type
If Report-Type is TRACE (the default) then information is reported
evaluates to true at the time of the call. :CONDITION-AFTER is
similar, but suppresses the initial printout, and is tested when the
function returns. :CONDITION-ALL tries both before and after.
+ This option is not supported with :REPORT PROFILE.
:BREAK Form
:BREAK-AFTER Form
:BREAK-ALL Form
If specified, and Form evaluates to true, then the debugger is invoked
at the start of the function, at the end of the function, or both,
- according to the respective option.
+ according to the respective option.
:PRINT Form
:PRINT-AFTER Form
If specified, Names is a function name or list of names. TRACE does
nothing unless a call to one of those functions encloses the call to
this function (i.e. it would appear in a backtrace.) Anonymous
- functions have string names like \"DEFUN FOO\".
+ functions have string names like \"DEFUN FOO\". This option is not
+ supported with :REPORT PROFILE.
:ENCAPSULATE {:DEFAULT | T | NIL}
If T, the tracing is done via encapsulation (redefining the function
*not* evaluated in the function's lexical environment, but SB-DEBUG:ARG
can still be used.
+ :METHODS {T | NIL}
+ If T, any function argument naming a generic function will have its
+ methods traced in addition to the generic function itself.
+
:FUNCTION Function-Form
This is a not really an option, but rather another way of specifying
what function to trace. The Function-Form is evaluated immediately,
- and the resulting function is traced.
+ and the resulting function is instrumented, i.e. traced or profiled
+ as specified in REPORT.
- :CONDITION, :BREAK and :PRINT forms are evaluated in the lexical environment
- of the called function; SB-DEBUG:VAR and SB-DEBUG:ARG can be used. The
- -AFTER and -ALL forms are evaluated in the null environment."
+:CONDITION, :BREAK and :PRINT forms are evaluated in a context which
+mocks up the lexical environment of the called function, so that
+SB-DEBUG:VAR and SB-DEBUG:ARG can be used. The -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))
- (info (gethash fun *traced-functions*)))
+ (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)
- (sb-int: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-functions*)))))
+ ((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 ()
- (dolist (fun (%list-traced-functions))
+ (dolist (fun (%list-traced-funs))
(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."
+ "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)))