;;; 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.
(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
;;; 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.
(defun trace-redefined-update (fname new-value)
(when (fboundp fname)
(let* ((fun (trace-fdefinition fname))
- (info (gethash fun *traced-funs*)))
+ (info (gethash fun *traced-funs*)))
(when (and info (trace-info-named info))
- (untrace-1 fname)
- (trace-1 fname info new-value)))))
+ (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
(when form
(let ((exp (car form)))
(if (sb-di:code-location-p loc)
- (let ((fun (sb-di:preprocess-for-eval exp loc)))
+ (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
- `(flet ((sb-debug:arg (n)
- (declare (special arg-list))
- (elt arg-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)))))))))
+ (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))
(dolist (entry *traced-entries*)
(when (cdr entry) (incf depth)))
(format t
- "~V,0@T~W: "
- (+ (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 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-fun-name (sb-di:frame-debug-fun frame))
- names
- :test #'equal)
+ names
+ :test #'equal)
(return t))))
;;; Handle PRINT and PRINT-AFTER options.
(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)))))
;;; Discard any invalid cookies on our simulated stack. Encapsulated
;;; entries are always valid, since we bind *TRACED-ENTRIES* in the
(defun discard-invalid-entries (frame)
(loop
(when (or (null *traced-entries*)
- (let ((cookie (caar *traced-entries*)))
- (or (not cookie)
- (sb-di:fun-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
-;;; FUN-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
(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)))))
+ (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) ,@arg-list)))
- (print-frame-call frame))
- (terpri)
- (trace-print frame (trace-info-print info))
- (write-sequence (get-output-stream-string *standard-output*)
- *trace-output*))
- (trace-maybe-break info (trace-info-break info) "before" frame)))
+ (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))
(declare (ignore bpt))
(unless (eq cookie (caar *traced-entries*))
(setf *traced-entries*
- (member cookie *traced-entries* :key #'car)))
+ (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)
- (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))
- (write-sequence (get-output-stream-string *standard-output*)
- *trace-output*))
- (trace-maybe-break info
- (trace-info-break-after info)
- "after"
- frame)))))
+ (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,
(let ((frame (sb-di:frame-down (sb-di:top-frame))))
(funcall start frame nil)
(let ((*traced-entries* *traced-entries*))
- (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))))))
+ (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-funs*)
- (warn "~S is already TRACE'd, untracing it." 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)
- :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)))
-
- 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)))))
+ (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)))
+ 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 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.
+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.
- 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.
+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.
- The following options are defined:
+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
: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
In addition to the usual printout, the result of evaluating Form is
printed at the start of the function, at the end of the function, or
both, according to the respective option. Multiple print options cause
- multiple values to be printed.
+ multiple values to be printed.
:WHEREIN Names
If specified, Names is a function name or list of names. TRACE does
*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 instrumented, i.e. traced or profiled
as specified in REPORT.
- :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."
+: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-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."
+ "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