;;;; 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))
+;;; 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))
-;;; A TRACE-INFO object represents all the information we need to trace a
-;;; given function.
+;;; 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)
;; the list of function names for WHEREIN, or NIL if unspecified
(wherein nil :type list)
- ;; The following slots represent the forms that we are supposed to evaluate
- ;; on each iteration. Each form is represented by a cons (Form . Function),
- ;; where the Function is the cached result of coercing Form to a function.
- ;; Forms which use the current environment are converted with
- ;; PREPROCESS-FOR-EVAL, which gives us a one-arg function.
- ;; Null environment forms also have one-arg functions, but the argument is
- ;; ignored. NIL means unspecified (the default.)
+ ;; The following slots represent the forms that we are supposed to
+ ;; evaluate on each iteration. Each form is represented by a cons
+ ;; (Form . Function), where the Function is the cached result of
+ ;; coercing Form to a function. Forms which use the current
+ ;; environment are converted with PREPROCESS-FOR-EVAL, which gives
+ ;; us a one-arg function. Null environment forms also have one-arg
+ ;; functions, but the argument is ignored. NIL means unspecified
+ ;; (the default.)
;; current environment forms
(condition nil)
;; 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
(defvar *traced-entries* ())
(declaim (list *traced-entries*))
-;;; This variable is used to discourage infinite recursions when some trace
-;;; action invokes a function that is itself traced. In this case, we quietly
-;;; ignore the inner tracing.
+;;; This variable is used to discourage infinite recursions when some
+;;; trace action invokes a function that is itself traced. In this
+;;; case, we quietly ignore the inner tracing.
(defvar *in-trace* nil)
\f
;;;; utilities
-;;; Given a function name, a function or a macro name, return the raw
-;;; definition and some information. "Raw" means that if the result is a
-;;; closure, we strip off the closure and return the bare code. The second
-;;; value is T if the argument was a function name. The third value is one of
-;;; :COMPILED, :COMPILED-CLOSURE, :INTERPRETED, :INTERPRETED-CLOSURE and
-;;; :FUNCALLABLE-INSTANCE.
+;;; Given a function name, a function or a macro name, return the raw
+;;; definition and some information. "Raw" means that if the result is
+;;; a closure, we strip off the closure and return the bare code. The
+;;; second value is T if the argument was a function name. The third
+;;; 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
(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))))))
-
-;;; When a function name is redefined, and we were tracing that name, then
-;;; untrace the old definition and trace the new one.
+ (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)))))
+
+;;; 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*)
+(push #'trace-redefined-update *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.
+;;; 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)))))
+ (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 (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)))))))))
+ (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: "
+ "~@V,0T~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))
+ (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 ~_= ~S~:>" (car ele) (funcall (cdr ele) frame))))
-;;; Test a break option, and break if true.
+;;; Test a BREAK option, and break if true.
(defun trace-maybe-break (info break where frame)
(when (and break (funcall (cdr break) frame))
(sb-di:flush-frames-above frame)
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))))
+ (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.
+;;; 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.
(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* *trace-output*)
+ (*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)))
+ (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.
(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* *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)))))
\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)
(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))
+ (declare (special basic-definition arg-list))
(funcall cookie frame nil)
(let ((vals
(multiple-value-list
- (apply basic-definition argument-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 then
-;;; install the breakpoints or encapsulation.
+;;; trace info (it was a quoted constant), fill in the functions, and
+;;; then install the breakpoints or encapsulation.
;;;
-;;; If non-null, Definition is the new definition of a function that we are
-;;; automatically retracing.
+;;; If non-null, DEFINITION is the new definition of a function that
+;;; we are automatically retracing.
(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)
+ (when (gethash fun *traced-funs*)
+ (warn "~S is already TRACE'd, untracing it." function-or-name)
(untrace-1 fun))
- (let* ((debug-fun (sb-di:function-debug-function 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"
+ (warn "tracing shared code for ~S:~% ~S"
function-or-name
fun))
nil)
(trace-info-encapsulated info)))
(loc (if encapsulated
:encapsulated
- (sb-di:debug-function-start-location debug-fun)))
+ (sb-di:debug-fun-start-location debug-fun)))
(info (make-trace-info
:what function-or-name
:named named
(unless named
(error "can't use encapsulation to trace anonymous function ~S"
fun))
- (sb-int:encapsulate function-or-name 'trace `(trace-call ',info)))
+ (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))
+ :kind :fun-start))
(end (sb-di:make-breakpoint
(trace-end-breakpoint-fun info)
- debug-fun :kind :function-end
- :function-end-cookie cookie-fun)))
+ 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 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.
+ ;; 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-functions*) info)))
+ (setf (gethash fun *traced-funs*) info)))
function-or-name)
\f
;;;; the TRACE macro
-;;; Parse leading trace options off of SPECS, modifying INFO accordingly. The
-;;; remaining portion of the list is returned when we encounter a plausible
-;;; function name.
+;;; Parse leading trace options off of SPECS, modifying INFO
+;;; accordingly. The remaining portion of the list is returned when we
+;;; encounter a plausible function name.
(defun parse-trace-options (specs info)
(let ((current specs))
(loop
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.) If there are no :FUNCTION specs, then don't use a LET.
+;;; This allows TRACE to be used without the full interpreter.
(defun expand-trace (specs)
(collect ((binds)
(forms))
`(let ,(binds) (list ,@(forms)))
`(list ,@(forms)))))
-(defun %list-traced-functions ()
- (loop for x being each hash-value in *traced-functions*
+(defun %list-traced-funs ()
+ (loop for x being each hash-value in *traced-funs*
collect (trace-info-what x)))
(defmacro trace (&rest specs)
-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 (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))
+ (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*)))))
+ (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)
projects / sbcl.git / blobdiff