- (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)))