From 59b47038145d2b5cced09f2dcb1df76460415361 Mon Sep 17 00:00:00 2001 From: ram <ram> Date: Wed, 27 May 1992 01:09:51 +0000 Subject: [PATCH] Substantially rewritten. TRACE has a new syntax. It now subsumes the old encapsulation-based trace via the :ENCAPSULATE option. Interpreted functions and generic functions are traced via encapsulation by default, which works. Conditional stuff works much better. --- code/ntrace.lisp | 879 ++++++++++++++++++++++++++++++++--------------- 1 file changed, 600 insertions(+), 279 deletions(-) diff --git a/code/ntrace.lisp b/code/ntrace.lisp index f86f43449..ccc56c5de 100644 --- a/code/ntrace.lisp +++ b/code/ntrace.lisp @@ -7,311 +7,226 @@ ;;; Scott Fahlman or slisp-group@cs.cmu.edu. ;;; (ext:file-comment - "$Header: /Volumes/share2/src/cmucl/cvs2git/cvsroot/src/code/ntrace.lisp,v 1.7 1992/05/15 18:31:05 ram Exp $") + "$Header: /Volumes/share2/src/cmucl/cvs2git/cvsroot/src/code/ntrace.lisp,v 1.8 1992/05/27 01:09:51 ram Exp $") ;;; ;;; ********************************************************************** ;;; -;;; This is a tracing facility. +;;; This is a tracing facility based on breakpoints. ;;; -;;; THIS IS CURRENTLY UNDER DEVELOPMENT AND TESTING. -;;; -;;; Written by Bill Chiles. +;;; Written by Rob MacLachlan and Bill Chiles. ;;; ;;; ********************************************************************** ;;; - (in-package "LISP") (export '(trace untrace)) - (in-package "DEBUG") -(export '(*trace-print-level* *trace-print-length* *traced-function-list* - *trace-frame* *trace-values* *max-trace-indentation*)) - -(defvar *traced-function-list* nil - "A list of functions which are traced.") - -(defvar *trace-print-length* nil - "Tracing output occurs with *print-length* bound to this value.") - -(defvar *trace-print-level* nil - "Tracing output occurs with *print-level* bound to this value.") - -(defvar *trace-frame* nil - "TRACE causes expressions for its switches to evaluate within a context - where this is bound to the appropriate control stack frame.") +(export '(*trace-values* *max-trace-indentation* *trace-encapsulate-default*)) (defvar *trace-values* nil "This is bound to the returned values when evaluating :BREAK-AFTER and :PRINT-AFTER forms.") -(defvar *max-trace-indentation* nil - "This is currently unused.") +(defvar *max-trace-indentation* 40 + "If the trace indentation exceeds this value, then indentation restarts at + 0.") - -;;; TRACE -- Public. -;;; -(defmacro trace (&rest specs) - "Establishes tracing for specified functions and pushes them on - *traced-function-list*. Each specification is one of the following: - function - the name of a function - a list form - If it is a list form, it has the following structure: - (function-or-name <trace-option> <value> <trace-option> <value> ...) - If you supply no specifications, TRACE returns the list of traced functions. - The following options are valid: - :condition - A form to EVAL to determine whether TRACE should display anything. - :break - A form to EVAL to determine whether to call BREAK before the call. - :break-after - Like :break, but takes effect after the call. - :break-all - Like :break, but takes effect before and after call. - :wherein - A function name or list of names in which TRACE will display a call. - :print - A list of forms for EVAL whose results TRACE will display in addition - to other information before the call. - :print-after - Like :print, but takes effect after the call. - :print-all - Like :print, but takes effect before and after the call. - - While the provided expression evaluate, debug:*trace-frame* is bound to the - appropriate frame for accessing locals of the TRACE'd function. Therefore, - you can use DI:PREPROCESS-FOR-EVAL (and DI:DEBUG-FUNCTION-START-LOCATION if - necessary) and with its resulting function, provide an expression including - a FUNCALL of the function and debug:*trace-frame*." - (cond - ((not specs) '*traced-function-list*) - (t - (let ((name-list nil) - (trace-1-forms nil)) - (dolist (spec specs `(progn - ,@trace-1-forms - ',(reverse name-list))) - (multiple-value-bind - (name options) - (typecase spec - ((or symbol function) - (values spec nil)) - (list - (let ((fun (car spec))) - (cond ((eq fun 'quote) - (error "Do NOT quote function names.")) - ((or (symbolp fun) (functionp fun)) - (values fun (cdr spec))) - ((not (and (consp fun) (= (length fun) 2))) - (error "Illegal function name: ~S." fun)) - ((eq (car fun) 'setf) - (values fun (cdr spec))) - (t (error "Illegal function name: ~S." fun))))) - (t (error "Illegal trace spec: ~S." spec))) - (push name name-list) - (destructuring-bind (&key condition break break-after break-all - wherein print print-after print-all) - options - (when break-all - (setf break (setf break-after break-all))) - (when print-all - (setf print (setf print-after print-all))) - ;; Wherein must be a list of symbols or nil. - (setf wherein - (typecase wherein - (null nil) - (symbol (list wherein)) - (list (dolist (fun wherein wherein) - (unless (or (symbolp fun) - (and (consp fun) - (= (length fun) 2) - (eq (car fun) 'setf))) - (error "Illegal function name, ~S, in :wherein." - fun)))) - (t (error "Illegal :wherein option: ~S." wherein)))) - ;; Print and print-after must be lists. - (unless (listp print) - (error "Illegal form list, ~S, for :print." print)) - (unless (listp print-after) - (error "Illegal form list, ~S, for :print-after." print-after)) - (push `(trace-1 ',name ',condition ',break ',break-after - ',wherein ',print ',print-after) - trace-1-forms)))))))) +(defvar *trace-encapsulate-default* :default + "The default value for the :ENCAPSULATE option to trace.") + +;;;; Internal state: -;;; TRACE-FDEFINITION -- Internal -;;; -;;; Given a function or macro name, return the definition. Error if a -;;; special form. If already a function, just return it. +;;; A hash-table that maps each traced function to the TRACE-INFO. The entry +;;; for a closure is the shared function-entry object. ;;; -(defun trace-fdefinition (x) - (typecase x - (symbol - (cond ((special-form-p x) - (error "Can't trace special form ~S." x)) - ((macro-function x)) - (t - (fdefinition x)))) - (function x) - (t (fdefinition x)))) +(defvar *traced-functions* (make-hash-table :test #'eq)) - -;;; This is a list of function-end-cookies, which we use to note distinct -;;; dynamic entries into functions. +;;; The TRACE-INFO structure represents all the information we need to trace a +;;; given function. ;;; +(defstruct (trace-info + (:print-function + (lambda (s stream d) + (declare (ignore d)) + (print-unreadable-object (s stream) + (format stream "Trace-Info ~S" (trace-info-what s))))) + (:make-load-form-fun :just-dump-it-normally)) + ;; + ;; The original representation of the thing traced. + (what nil :type (or function cons symbol)) + ;; + ;; True if What is a function name whose definition we should track. + (named nil) + ;; + ;; True if tracing is to be done by encapsulation rather than breakpoints. + ;; T implies Named. + (encapsulated *trace-encapsulate-default*) + ;; + ;; True if this trace has been untraced. + (untraced nil) + ;; + ;; Breakpoints we set up to trigger tracing. + (start-breakpoint nil :type (or di:breakpoint null)) + (end-breakpoint nil :type (or di:breakpoint null)) + ;; + ;; The list of function names for wherein. NIL means 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.) + ;; + ;; Current environment forms: + (condition nil) + (break nil) + ;; + ;; List of current environment forms: + (print () :type list) + ;; + ;; Null environment forms. + (condition-after nil) + (break-after 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 statisfied. 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 that affects TRACE'ing. 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 -;;; there, we can adjust our indentation and the contents of the list -;;; accordingly, printing a warning that some TRACE'd entries have been fouled. +;;; 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 there, we +;;; discard any entries that come before our cookie. ;;; -(defvar *traced-entries* nil) +;;; When we trace using encapsulation, we bind this variable and add +;;; (nil . condition-satisfied), so a NIL "cookie" marks an encapsulated +;;; tracing. +;;; +(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. +;;; +(defvar *in-trace* nil) + + +;;;; Utilities: + +;;; TRACE-FDEFINITION -- Internal +;;; +;;; 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 + (symbol + (cond ((special-form-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 (eval:interpreted-function-p res) + (values res named-p (if (eval:interpreted-function-closure res) + :interpreted-closure :interpreted)) + (case (kernel:get-type res) + (#.vm:closure-header-type + (values (kernel:%closure-function res) named-p :compiled-closure)) + (#.vm:funcallable-instance-header-type + (values res named-p :funcallable-instance)) + (t (values res named-p :compiled)))))) + -;;; This maps functions to the two breakpoints created in TRACE-1, so we can -;;; get rid of them in UNTRACE-1. +;;; TRACE-REDEFINED-UPDATE -- Internal ;;; -(defvar *trace-breakpoints* (make-hash-table :test #'eq)) +;;; When a function name is redefined, and we were tracing that name, then +;;; untrace the old definition and trace the new one. ;;; -(defun clear-trace-breakpoint-record (fname new-value) - (declare (ignore new-value)) +(defun trace-redefined-update (fname new-value) (when (fboundp fname) (let* ((fun (trace-fdefinition fname)) - (bpts (gethash fun *trace-breakpoints*))) - (when bpts - ;; Free breakpoint bookkeeping data. - (di:delete-breakpoint (car bpts)) - (di:delete-breakpoint (cdr bpts)) - ;; Free TRACE bookkeeping data. - (setf (gethash fun *trace-breakpoints*) nil))))) + (info (gethash fun *traced-functions*))) + (when (and info (trace-info-named info)) + (untrace-1 fname) + (trace-1 fname info new-value))))) ;;; -(push #'clear-trace-breakpoint-record ext:*setf-fdefinition-hook*) +(push #'trace-redefined-update ext:*setf-fdefinition-hook*) -;;; TRACE-1 -- Internal. + +;;; COERCE-FORM, COERCE-FORM-LIST -- Internal ;;; -;;; This establishes :function-start and :function-end breakpoints with -;;; appropriate hook functions to TRACE function-name as described by the user. +;;; 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. ;;; -(defun trace-1 (function-or-name condition break break-after wherein print - print-after) - (let ((fun (trace-fdefinition function-or-name))) - (when (member fun *traced-function-list*) - (warn "Function ~S already TRACE'd, retracing it." function-or-name) - (untrace-1 fun)) - - (when wherein - (dolist (f wherein) - (unless (fboundp f) - (error "Undefined :wherein name -- ~S." f)))) - (let* ((debug-fun (di:function-debug-function fun)) - ;; The start and end hooks use conditionp for communication. - (conditionp nil) - (start (di:make-breakpoint - #'(lambda (frame bpt) - (let ((*trace-frame* frame)) - (cond ((and (or (not condition) ;Save a call to EVAL - (eval condition)) - (or (not wherein) - (trace-wherein-p frame wherein))) - (setf conditionp t) - (print-trace-start frame bpt print)) - (t (setf conditionp nil))) - (when (and break (eval break)) - (di:flush-frames-above frame) - (let ((*stack-top-hint* frame)) - (break "Breaking before TRACE'd call to ~S." - function-or-name))))) - debug-fun :kind :function-start)) - (end (di:make-breakpoint - #'(lambda (frame bpt *trace-values* cookie) - (if (member fun *traced-function-list*) - (let ((*trace-frame* frame)) - (when conditionp - (print-trace-end frame bpt *trace-values* cookie - print-after)) - (pop *traced-entries*) - (when (and break-after (eval break-after)) - (di:flush-frames-above frame) - (let ((*stack-top-hint* frame)) - (break "Breaking after TRACE'd call to ~S." - function-or-name)))) - (pop *traced-entries*))) - debug-fun :kind :function-end - :function-end-cookie - #'(lambda (frame x) - (when (and *traced-entries* - (not (di:function-end-cookie-valid-p - frame (car *traced-entries*)))) - (loop - (pop *traced-entries*) - (when (or (not *traced-entries*) - (di:function-end-cookie-valid-p - frame (car *traced-entries*))) - (return)))) - (push x *traced-entries*))))) - (assert (not (gethash fun *trace-breakpoints*))) - (setf (gethash fun *trace-breakpoints*) (cons start end)) - ;; The next two forms must be in the order in which they appear. They - ;; rely on a documented property that later activated breakpoint hooks - ;; run first, and the end breakpoint establishes a starting helper bpt. - (di:activate-breakpoint start) - (di:activate-breakpoint end)) - (push fun *traced-function-list*))) - -;;; PRINT-TRACE-START -- Internal. -;;; -;;; This prints a representation of the call establishing frame. -;;; -(defun print-trace-start (frame bpt &optional print) - (declare (ignore bpt)) - (let ((*print-length* (or *trace-print-length* *print-length*)) - (*print-level* (or *trace-print-level* *print-level*))) - (fresh-line) - (print-trace-indentation) - (print-frame-call-1 frame nil) - (dolist (ele print) - (fresh-line) - (print-trace-indentation) - (prin1 (eval ele))) - (terpri))) - -;;; PRINT-TRACE-END -- Internal. -;;; -;;; This prints a representation of the return values delivered to frame by the -;;; function for which bpt is a :function-end breakpoint. 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 to determine the correct indentation for output. -;;; -(defun print-trace-end (frame bpt values cookie &optional print-after) - (declare (ignore frame bpt)) - (unless (eq cookie (car *traced-entries*)) - (setf *traced-entries* (member cookie *traced-entries*))) - (print-trace-indentation) - (write-string "returned ") - (dolist (v values) - (prin1 v) - (write-char #\space)) - (dolist (ele print-after) - (terpri) - (print-trace-indentation) - (prin1 (eval ele))) - (terpri)) +(defun coerce-form (form loc) + (when form + (let ((exp (car form))) + (if (di:code-location-p loc) + (let ((fun (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 ((debug:arg (n) + (declare (special argument-list)) + (elt argument-list n))) + (declare (ignorable #'debug:arg)) + ,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)) + +;;; PRINT-TRACE-INDENTATION -- Internal +;;; +;;; Print indentation according to the number of trace entries. Entries +;;; whose condition was false don't count. +;;; (defun print-trace-indentation () - (let ((len (length (the list *traced-entries*)))) - (dotimes (i len) (write-string " ")) - (prin1 len) - (write-string ": "))) + (let ((depth 0)) + (dolist (entry *traced-entries*) + (when (cdr entry) (incf depth))) + (format t "~&~VT~D: " + (+ (mod (* depth 2) (- *max-trace-indentation* 2)) 2) + depth))) + ;;; TRACE-WHEREIN-P -- Internal. ;;; -;;; The TRACE hooks use this for the :wherein arg. +;;; Return true if one of the Names appears on the stack below Frame. ;;; (defun trace-wherein-p (frame names) (do ((frame (di:frame-down frame) (di:frame-down frame))) @@ -320,26 +235,432 @@ names :test #'equal) (return t)))) +;;; TRACE-PRINT -- Internal +;;; +;;; 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)))) + +;;; TRACE-MAYBE-BREAK -- Internal +;;; +;;; Test a break option, and break if true. +;;; +(defun trace-maybe-break (info break where frame) + (when (and break (funcall (cdr break) frame)) + (di:flush-frames-above frame) + (let ((*stack-top-hint* frame)) + (break "Breaking ~A traced call to ~S:" where + (trace-info-what info))))) + +;;; DISCARD-INVALID-ENTRIES -- Internal +;;; +;;; This function discards 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) + (di:function-end-cookie-valid-p frame cookie)))) + (return)) + (pop *traced-entries*))) -;;;; N-UNTRACE. +;;;; Hook functions: + +;;; TRACE-START-BREAKPOINT-FUN -- Internal. +;;; +;;; 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. +;;; +(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 ((*print-length* (or *debug-print-length* *print-length*)) + (*print-level* (or *debug-print-level* *print-level*)) + (*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-1 frame nil)) + (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*))))) + + +;;; TRACE-END-BREAKPOINT-FUN -- Internal +;;; +;;; 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 to determine the correct indentation +;;; for output. We then check to see if 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 ((*print-length* (or *debug-print-length* *print-length*)) + (*print-level* (or *debug-print-level* *print-level*)) + (*standard-output* *trace-output*) + (*in-trace* t)) + (print-trace-indentation) + (format t "~S returned " (trace-info-what info)) + (dolist (v *trace-values*) + (prin1 v) + (write-char #\space)) + (trace-print frame (trace-info-print-after info)) + (terpri)) + (trace-maybe-break info (trace-info-break-after info) + "after" frame))))) + + +;;; TRACE-CALL -- Internal +;;; +;;; 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. +;;; +(defun trace-call (info) + (multiple-value-bind + (start cookie) + (trace-start-breakpoint-fun info) + (let ((frame (di:frame-down (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)))))) + + +;;; TRACE-1 -- Internal. +;;; +;;; 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. +;;; +;;; If non-null, Definition is the new definition of a function that we are +;;; automatically retracing; this +;;; +(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*) + (warn "Function ~S already TRACE'd, retracing it." function-or-name) + (untrace-1 fun)) + + (let* ((debug-fun (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 + (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 is not a defined global function: ~S" + wherein))) + + (cond + (encapsulated + (unless named + (error "Can't use encapsulation to trace anonymous function ~S." + fun)) + (ext:encapsulate function-or-name 'trace `(trace-call ',info))) + (t + (multiple-value-bind + (start-fun cookie-fun) + (trace-start-breakpoint-fun info) + (let ((start (di:make-breakpoint start-fun debug-fun + :kind :function-start)) + (end (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. + (di:activate-breakpoint start) + (di:activate-breakpoint end))))) + + (setf (gethash fun *traced-functions*) info))) + + function-or-name) + + +;;;; The TRACE macro: + +;;; PARSE-TRACE-OPTIONS -- Internal +;;; +;;; 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 + (when (endp current) (return)) + (let ((option (first current)) + (value (cons (second current) nil))) + (case option + (: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))) + current)) + + +;;; EXPAND-TRACE -- Internal +;;; +;;; 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. +;;; +(defun expand-trace (specs) + (collect ((binds) + (forms)) + (let* ((global-options (make-trace-info)) + (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))))) + + +;;; %LIST-TRACED-FUNCTIONS -- Internal +;;; +(defun %list-traced-functions () + (loop for x being each hash-value in *traced-functions* + collect (trace-info-what x))) + + +;;; TRACE -- Public. +;;; +(defmacro trace (&rest specs) + "TRACE {Option Global-Value}* {Name {Option Value}*}* + TRACE is a debugging tool that prints information when specified functions + are called. In its simplest form: + (trace Name-1 Name-2 ...) + + TRACE causes a printout on *TRACE-OUTPUT* each time that one of the named + functions is entered or returns (the Names are not evaluated.) The output + is indented according to the number of pending traced calls, and this trace + depth is printed at the beginning of each line of output. + + Options allow modification of the default behavior. Each option is a pair + of an option keyword and a value form. Options may be interspersed with + function names. Options only affect tracing of the function whose name they + appear immediately after. Global options are specified before the first + name, and affect all functions traced by a given use of TRACE. + + The following options are defined: + + :CONDITION Form + :CONDITION-AFTER Form + :CONDITION-ALL Form + If :CONDITION is specified, then TRACE does nothing unless Form + 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. + + :WHEREIN Names + 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\". + + :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. + + :PRINT Form + :PRINT-AFTER Form + :PRINT-ALL Form + In addition to the usual prinout, he 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. + + :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. + + :ENCAPSULATE {:DEFAULT | T | NIL} + If T, the tracing is done via encapsulation (redefining the function + name) rather than by modifying the function. :DEFAULT is the default, + and means to use encapsulation for interpreted functions and funcallable + instances, breakpoints otherwise. When encapsulation is used, forms are + *not* evaluated in the function's lexical environment, but DEBUG:ARG can + still be used. + + :CONDITION, :BREAK and :PRINT forms are evaluated in the lexical environment + of the called function; DEBUG:VAR and DEBUG:ARG can be used. The -AFTER and + -ALL forms are evaluated in the null environment." + (if specs + (expand-trace specs) + '(%list-traced-functions))) + + +;;;; Untracing: + +;;; UNTRACE-1 -- Internal +;;; +;;; Untrace one function. +;;; +(defun untrace-1 (function-or-name) + (let* ((fun (trace-fdefinition function-or-name)) + (info (gethash fun *traced-functions*))) + (cond + ((not info) (warn "Function is not TRACE'd -- ~S." function-or-name)) + ((trace-info-encapsulated info) + (ext:unencapsulate (trace-info-what info) 'trace)) + (t + (di:delete-breakpoint (trace-info-start-breakpoint info)) + (di:delete-breakpoint (trace-info-end-breakpoint info)))) + (setf (trace-info-untraced info) t) + (remhash fun *traced-functions*))) + +;;; UNTRACE-ALL -- Internal +;;; +;;; Untrace all traced functions. +;;; +(defun untrace-all () + (dolist (fun (%list-traced-functions)) + (untrace-1 fun)) + t) (defmacro untrace (&rest specs) "Removes tracing from the specified functions. With no args, untraces all functions." - (let ((specs (or specs *traced-function-list*))) - `(progn - ,@(mapcar #'(lambda (spec) - `(untrace-1 ',(if (consp spec) (car spec) spec))) - specs) - t))) - -(defun untrace-1 (function-or-name) - (let ((fun (trace-fdefinition function-or-name))) - (cond ((member fun *traced-function-list*) - (let ((breakpoints (gethash fun *trace-breakpoints*))) - (di:delete-breakpoint (car breakpoints)) - (di:delete-breakpoint (cdr breakpoints)) - (setf (gethash fun *trace-breakpoints*) nil)) - (setf *traced-function-list* (delete fun *traced-function-list*))) - (t (warn "Function is not TRACE'd -- ~S." fun))))) + (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))) + '(untrace-all))) -- GitLab