/[cmucl]/src/code/ntrace.lisp
ViewVC logotype

Contents of /src/code/ntrace.lisp

Parent Directory Parent Directory | Revision Log Revision Log


Revision 1.47 - (hide annotations)
Tue Feb 1 15:35:00 2011 UTC (3 years, 2 months ago) by rtoy
Branch: MAIN
CVS Tags: snapshot-2011-02
Changes since 1.46: +3 -3 lines
Fix typo.  The check for whether we were trying to use encapsulation
to trace a local function was checking for the wrong thing.
1 chiles 1.1 ;;; -*- Package: debug -*-
2     ;;;
3     ;;; **********************************************************************
4     ;;; This code was written as part of the CMU Common Lisp project at
5     ;;; Carnegie Mellon University, and has been placed in the public domain.
6     ;;;
7     (ext:file-comment
8 rtoy 1.47 "$Header: /tiger/var/lib/cvsroots/cmucl/src/code/ntrace.lisp,v 1.47 2011/02/01 15:35:00 rtoy Exp $")
9 chiles 1.1 ;;;
10     ;;; **********************************************************************
11     ;;;
12 ram 1.8 ;;; This is a tracing facility based on breakpoints.
13 chiles 1.1 ;;;
14 ram 1.8 ;;; Written by Rob MacLachlan and Bill Chiles.
15 chiles 1.1 ;;;
16     ;;; **********************************************************************
17     ;;;
18 chiles 1.2 (in-package "LISP")
19 rtoy 1.44 (intl:textdomain "cmucl")
20 chiles 1.2
21     (export '(trace untrace))
22    
23 chiles 1.1 (in-package "DEBUG")
24    
25 gerd 1.23 (export '(*trace-values* *max-trace-indentation* *trace-encapsulate-default*
26     *trace-encapsulate-package-names*))
27 chiles 1.1
28 gerd 1.25 (use-package :fwrappers)
29    
30 ram 1.7 (defvar *trace-values* nil
31 rtoy 1.45 "This is bound to the returned values when evaluating :BREAK-AFTER and
32 ram 1.7 :PRINT-AFTER forms.")
33    
34 ram 1.8 (defvar *max-trace-indentation* 40
35 rtoy 1.45 "If the trace indentation exceeds this value, then indentation restarts at
36 ram 1.8 0.")
37 chiles 1.2
38 rtoy 1.42 (defvar *trace-encapsulate-default* :default
39 rtoy 1.45 "The default value for the :ENCAPSULATE option to trace.")
40 ram 1.8
41 gerd 1.23 (defvar *trace-encapsulate-package-names*
42 gerd 1.27 '("LISP"
43     "COMMON-LISP"
44 gerd 1.23 "CONDITIONS"
45     "DEBUG"
46     "EXTENSIONS"
47     "FORMAT"
48     "KERNEL"
49     "LOOP"
50     "PRETTY-PRINT"
51     "SYSTEM"
52 gerd 1.26 "COMPILER"
53 gerd 1.23 "TRACE")
54 rtoy 1.45 "List of package names. Encapsulate functions from these packages
55 gerd 1.23 by default. This should at least include the packages of functions
56     used by TRACE, directly or indirectly.")
57    
58 chiles 1.1
59 ram 1.8 ;;;; Internal state:
60    
61     ;;; A hash-table that maps each traced function to the TRACE-INFO. The entry
62     ;;; for a closure is the shared function-entry object.
63 chiles 1.1 ;;;
64 rtoy 1.39 (defvar *traced-functions* (make-hash-table :test #'equal))
65 chiles 1.2
66 ram 1.8 ;;; The TRACE-INFO structure represents all the information we need to trace a
67     ;;; given function.
68     ;;;
69     (defstruct (trace-info
70     (:print-function
71     (lambda (s stream d)
72     (declare (ignore d))
73     (print-unreadable-object (s stream)
74     (format stream "Trace-Info ~S" (trace-info-what s)))))
75     (:make-load-form-fun :just-dump-it-normally))
76     ;;
77     ;; The original representation of the thing traced.
78     (what nil :type (or function cons symbol))
79     ;;
80     ;; True if What is a function name whose definition we should track.
81     (named nil)
82     ;;
83     ;; True if tracing is to be done by encapsulation rather than breakpoints.
84     ;; T implies Named.
85     (encapsulated *trace-encapsulate-default*)
86     ;;
87     ;; True if this trace has been untraced.
88     (untraced nil)
89     ;;
90     ;; Breakpoints we set up to trigger tracing.
91     (start-breakpoint nil :type (or di:breakpoint null))
92     (end-breakpoint nil :type (or di:breakpoint null))
93     ;;
94     ;; The list of function names for wherein. NIL means unspecified.
95     (wherein nil :type list)
96     ;;
97 rtoy 1.36 ;; Like wherein, but only if the caller is in the list.
98     (wherein-only nil :type list)
99     ;;
100 ram 1.8 ;; The following slots represent the forms that we are supposed to evaluate
101     ;; on each iteration. Each form is represented by a cons (Form . Function),
102     ;; where the Function is the cached result of coercing Form to a function.
103     ;; Forms which use the current environment are converted with
104     ;; PREPROCESS-FOR-EVAL, which gives us a one-arg function.
105     ;; Null environment forms also have one-arg functions, but the argument is
106     ;; ignored. NIL means unspecified (the default.)
107     ;;
108     ;; Current environment forms:
109     (condition nil)
110     (break nil)
111     ;;
112     ;; List of current environment forms:
113     (print () :type list)
114     ;;
115     ;; Null environment forms.
116     (condition-after nil)
117     (break-after nil)
118     ;;
119     ;; List of null environment forms
120     (print-after () :type list))
121 chiles 1.1
122 ram 1.8 ;;; This is a list of conses (function-end-cookie . condition-satisfied),
123     ;;; which we use to note distinct dynamic entries into functions. When we
124     ;;; enter a traced function, we add a entry to this list holding the new
125     ;;; end-cookie and whether the trace condition was statisfied. We must save
126     ;;; the trace condition so that the after breakpoint knows whether to print.
127     ;;; The length of this list tells us the indentation to use for printing TRACE
128     ;;; messages.
129     ;;;
130     ;;; This list also helps us synchronize the TRACE facility dynamically for
131     ;;; detecting non-local flow of control. Whenever execution hits a
132     ;;; :function-end breakpoint used for TRACE'ing, we look for the
133     ;;; function-end-cookie at the top of *traced-entries*. If it is not there, we
134     ;;; discard any entries that come before our cookie.
135     ;;;
136     ;;; When we trace using encapsulation, we bind this variable and add
137     ;;; (nil . condition-satisfied), so a NIL "cookie" marks an encapsulated
138     ;;; tracing.
139     ;;;
140     (defvar *traced-entries* ())
141     (declaim (list *traced-entries*))
142 ram 1.7
143 ram 1.8 ;;; This variable is used to discourage infinite recursions when some trace
144     ;;; action invokes a function that is itself traced. In this case, we quietly
145     ;;; ignore the inner tracing.
146     ;;;
147     (defvar *in-trace* nil)
148    
149    
150     ;;;; Utilities:
151    
152 ram 1.7 ;;; TRACE-FDEFINITION -- Internal
153     ;;;
154 ram 1.8 ;;; Given a function name, a function or a macro name, return the raw
155     ;;; definition and some information. "Raw" means that if the result is a
156     ;;; closure, we strip off the closure and return the bare code. The second
157     ;;; value is T if the argument was a function name. The third value is one of
158     ;;; :COMPILED, :COMPILED-CLOSURE, :INTERPRETED, :INTERPRETED-CLOSURE and
159     ;;; :FUNCALLABLE-INSTANCE.
160 ram 1.7 ;;;
161     (defun trace-fdefinition (x)
162 rtoy 1.40 (multiple-value-bind (res named-p local)
163 ram 1.8 (typecase x
164     (symbol
165 ram 1.11 (cond ((special-operator-p x)
166 rtoy 1.46 (error (intl:gettext "Can't trace special form ~S.") x))
167 ram 1.8 ((macro-function x))
168     (t
169     (values (fdefinition x) t))))
170     (function x)
171 rtoy 1.35 ((cons (member flet labels))
172     ;; An extended function name for flet/labels functions.
173 rtoy 1.40 (values (fdefinition (car (last x))) t x))
174 ram 1.8 (t (values (fdefinition x) t)))
175     (if (eval:interpreted-function-p res)
176     (values res named-p (if (eval:interpreted-function-closure res)
177     :interpreted-closure :interpreted))
178     (case (kernel:get-type res)
179     (#.vm:closure-header-type
180     (values (kernel:%closure-function res) named-p :compiled-closure))
181     (#.vm:funcallable-instance-header-type
182     (values res named-p :funcallable-instance))
183 rtoy 1.40 (t (values res named-p :compiled local))))))
184 ram 1.7
185    
186 ram 1.8 ;;; TRACE-REDEFINED-UPDATE -- Internal
187 chiles 1.1 ;;;
188 ram 1.8 ;;; When a function name is redefined, and we were tracing that name, then
189     ;;; untrace the old definition and trace the new one.
190 chiles 1.1 ;;;
191 ram 1.8 (defun trace-redefined-update (fname new-value)
192     (when (fboundp fname)
193 rtoy 1.40 (multiple-value-bind (fun named kind local)
194     (trace-fdefinition fname)
195     (let* ((fkey (or local fun))
196     (info (gethash fkey *traced-functions*)))
197     (flet ((handle-local-funs ()
198     ;; FIXME: This is gross. We need to grovel over the
199     ;; *traced-functions* to see if any flet/labels functions
200     ;; have been traced in the function we're redefining.
201     (maphash #'(lambda (key info)
202     (when (and (listp key)
203     (eq fname (car (last key))))
204     (when info
205     (untrace-1 key)
206     (trace-1 key info new-value))))
207     *traced-functions*)))
208     (when (and info (trace-info-named info))
209     (untrace-1 fname)
210     (trace-1 fname info new-value))
211     (handle-local-funs))))))
212    
213 chiles 1.1 ;;;
214 ram 1.8 (push #'trace-redefined-update ext:*setf-fdefinition-hook*)
215 chiles 1.1
216 ram 1.8
217     ;;; COERCE-FORM, COERCE-FORM-LIST -- Internal
218     ;;;
219     ;;; Annotate some forms to evaluate with pre-converted functions. Each form
220     ;;; is really a cons (exp . function). Loc is the code location to use for
221     ;;; the lexical environment. If Loc is NIL, evaluate in the null environment.
222     ;;; If Form is NIL, just return NIL.
223     ;;;
224     (defun coerce-form (form loc)
225     (when form
226     (let ((exp (car form)))
227     (if (di:code-location-p loc)
228     (let ((fun (di:preprocess-for-eval exp loc)))
229     (cons exp
230     #'(lambda (frame)
231     (let ((*current-frame* frame))
232     (funcall fun frame)))))
233     (let* ((bod (ecase loc
234     ((nil) exp)
235     (:encapsulated
236     `(flet ((debug:arg (n)
237     (declare (special argument-list))
238     (elt argument-list n)))
239     (declare (ignorable #'debug:arg))
240     ,exp))))
241     (fun (coerce `(lambda () ,bod) 'function)))
242     (cons exp
243     #'(lambda (frame)
244     (declare (ignore frame))
245     (let ((*current-frame* nil))
246     (funcall fun)))))))))
247     ;;;
248     (defun coerce-form-list (forms loc)
249     (mapcar #'(lambda (x) (coerce-form x loc)) forms))
250    
251    
252     ;;; PRINT-TRACE-INDENTATION -- Internal
253     ;;;
254     ;;; Print indentation according to the number of trace entries. Entries
255     ;;; whose condition was false don't count.
256     ;;;
257     (defun print-trace-indentation ()
258     (let ((depth 0))
259     (dolist (entry *traced-entries*)
260     (when (cdr entry) (incf depth)))
261 wlott 1.10 (format t "~@V,0T~D: "
262 ram 1.8 (+ (mod (* depth 2) (- *max-trace-indentation* 2)) 2)
263     depth)))
264    
265    
266     ;;; TRACE-WHEREIN-P -- Internal.
267     ;;;
268     ;;; Return true if one of the Names appears on the stack below Frame.
269     ;;;
270     (defun trace-wherein-p (frame names)
271     (do ((frame (di:frame-down frame) (di:frame-down frame)))
272     ((not frame) nil)
273 rtoy 1.30 (let ((frame-name (di:debug-function-name (di:frame-debug-function frame))))
274     (when (member frame-name names :test #'equal)
275     (return t)))))
276 ram 1.8
277 rtoy 1.36 ;;; TRACE-WHEREIN-ONLY-P -- Internal
278     ;;;
279     ;;; Like, TRACE-WHEREIN-ONLY-P, except true only if the last stack
280     ;;; frame Frame has the given name.
281     (defun trace-wherein-only-p (frame name)
282     (let ((caller-frame (di::frame-down frame)))
283     (when caller-frame
284     (let ((frame-name (di:debug-function-name (di:frame-debug-function caller-frame))))
285     (member frame-name name :test #'equal)))))
286    
287 ram 1.8 ;;; TRACE-PRINT -- Internal
288     ;;;
289     ;;; Handle print and print-after options.
290     ;;;
291     (defun trace-print (frame forms)
292     (dolist (ele forms)
293     (fresh-line)
294     (print-trace-indentation)
295     (format t "~S = ~S" (car ele) (funcall (cdr ele) frame))))
296    
297     ;;; TRACE-MAYBE-BREAK -- Internal
298     ;;;
299     ;;; Test a break option, and break if true.
300     ;;;
301     (defun trace-maybe-break (info break where frame)
302     (when (and break (funcall (cdr break) frame))
303     (di:flush-frames-above frame)
304     (let ((*stack-top-hint* frame))
305 rtoy 1.46 (break (intl:gettext "Breaking ~A traced call to ~S:") where
306 ram 1.8 (trace-info-what info)))))
307    
308     ;;; DISCARD-INVALID-ENTRIES -- Internal
309     ;;;
310     ;;; This function discards any invalid cookies on our simulated stack.
311     ;;; Encapsulated entries are always valid, since we bind *traced-entries* in
312     ;;; the encapsulation.
313     ;;;
314     (defun discard-invalid-entries (frame)
315     (loop
316     (when (or (null *traced-entries*)
317     (let ((cookie (caar *traced-entries*)))
318     (or (not cookie)
319     (di:function-end-cookie-valid-p frame cookie))))
320     (return))
321     (pop *traced-entries*)))
322    
323    
324     ;;;; Hook functions:
325    
326     ;;; TRACE-START-BREAKPOINT-FUN -- Internal.
327     ;;;
328     ;;; Return a closure that can be used for a function start breakpoint hook
329     ;;; function and a closure that can be used as the FUNCTION-END-COOKIE
330     ;;; function. The first communicates the sense of the Condition to the second
331     ;;; via a closure variable.
332     ;;;
333     (defun trace-start-breakpoint-fun (info)
334     (let (conditionp)
335     (values
336     #'(lambda (frame bpt)
337     (declare (ignore bpt))
338     (discard-invalid-entries frame)
339     (let ((condition (trace-info-condition info))
340 rtoy 1.36 (wherein (trace-info-wherein info))
341     (wherein-only (trace-info-wherein-only info)))
342 ram 1.8 (setq conditionp
343     (and (not *in-trace*)
344     (or (not condition)
345     (funcall (cdr condition) frame))
346     (or (not wherein)
347 rtoy 1.36 (trace-wherein-p frame wherein))
348     (or (not wherein-only)
349     (trace-wherein-only-p frame wherein-only)))))
350 ram 1.8
351     (when conditionp
352     (let ((*print-length* (or *debug-print-length* *print-length*))
353     (*print-level* (or *debug-print-level* *print-level*))
354 wlott 1.10 (kernel:*current-level* 0)
355 ram 1.8 (*standard-output* *trace-output*)
356     (*in-trace* t))
357     (fresh-line)
358     (print-trace-indentation)
359     (if (trace-info-encapsulated info)
360     (locally (declare (special basic-definition argument-list))
361     (prin1 `(,(trace-info-what info) ,@argument-list)))
362 cracauer 1.19 (print-frame-call frame :verbosity 1))
363 ram 1.8 (terpri)
364     (trace-print frame (trace-info-print info)))
365     (trace-maybe-break info (trace-info-break info) "before" frame)))
366    
367     #'(lambda (frame cookie)
368     (declare (ignore frame))
369     (push (cons cookie conditionp) *traced-entries*)))))
370    
371    
372     ;;; TRACE-END-BREAKPOINT-FUN -- Internal
373     ;;;
374     ;;; This prints a representation of the return values delivered. First,
375     ;;; this checks to see that cookie is at the top of *traced-entries*; if it is
376     ;;; not, then we need to adjust this list to determine the correct indentation
377     ;;; for output. We then check to see if the function is still traced and that
378     ;;; the condition succeeded before printing anything.
379 chiles 1.1 ;;;
380 ram 1.8 (defun trace-end-breakpoint-fun (info)
381     #'(lambda (frame bpt *trace-values* cookie)
382     (declare (ignore bpt))
383     (unless (eq cookie (caar *traced-entries*))
384     (setf *traced-entries*
385     (member cookie *traced-entries* :key #'car)))
386    
387     (let ((entry (pop *traced-entries*)))
388     (when (and (not (trace-info-untraced info))
389     (or (cdr entry)
390     (let ((cond (trace-info-condition-after info)))
391     (and cond (funcall (cdr cond) frame)))))
392     (let ((*print-length* (or *debug-print-length* *print-length*))
393     (*print-level* (or *debug-print-level* *print-level*))
394 wlott 1.10 (kernel:*current-level* 0)
395 ram 1.8 (*standard-output* *trace-output*)
396     (*in-trace* t))
397 wlott 1.10 (fresh-line)
398     (pprint-logical-block (*standard-output* nil)
399     (print-trace-indentation)
400     (pprint-indent :current 2)
401 rtoy 1.46 (format t (intl:gettext "~S returned") (trace-info-what info))
402 wlott 1.10 (dolist (v *trace-values*)
403     (write-char #\space)
404     (pprint-newline :linear)
405     (prin1 v)))
406     (terpri)
407     (trace-print frame (trace-info-print-after info)))
408 ram 1.8 (trace-maybe-break info (trace-info-break-after info)
409     "after" frame)))))
410    
411    
412 gerd 1.25 ;;; TRACE-FWRAPPER -- Internal
413 chiles 1.2 ;;;
414 ram 1.8 ;;; This function is called by the trace encapsulation. It calls the
415     ;;; breakpoint hook functions with NIL for the breakpoint and cookie, which
416     ;;; we have cleverly contrived to work for our hook functions.
417 chiles 1.2 ;;;
418 gerd 1.25 (define-fwrapper trace-fwrapper (&rest args)
419     (let* ((info (fwrapper-user-data fwrapper))
420     (name (trace-info-what info))
421     (fdefn (lisp::fdefinition-object name nil))
422     (basic-definition (fwrapper-next fwrapper))
423     (argument-list args))
424     (declare (special basic-definition argument-list))
425     (letf (((lisp::fdefn-function fdefn) basic-definition))
426 gerd 1.23 (multiple-value-bind (start cookie)
427     (trace-start-breakpoint-fun info)
428     (let ((frame (di:frame-down (di:top-frame))))
429     (funcall start frame nil)
430     (let ((*traced-entries* *traced-entries*))
431     (funcall cookie frame nil)
432 gerd 1.25 (let ((vals (multiple-value-list (call-next-function))))
433 gerd 1.23 (funcall (trace-end-breakpoint-fun info) frame nil vals nil)
434     (values-list vals))))))))
435 chiles 1.1
436 ram 1.8
437 chiles 1.2 ;;; TRACE-1 -- Internal.
438 chiles 1.1 ;;;
439 ram 1.8 ;;; Trace one function according to the specified options. We copy the
440     ;;; trace info (it was a quoted constant), fill in the functions, and then
441     ;;; install the breakpoints or encapsulation.
442 chiles 1.1 ;;;
443 ram 1.8 ;;; If non-null, Definition is the new definition of a function that we are
444     ;;; automatically retracing; this
445     ;;;
446     (defun trace-1 (function-or-name info &optional definition)
447 rtoy 1.40 (multiple-value-bind (fun named kind local)
448     (if definition
449     ;; Tracing a new definition. If function-or-name looks like a
450     ;; local function, we trace the new definition with the local
451     ;; function. Otherwise, we do what we used to do.
452     (if (and (valid-function-name-p function-or-name)
453     (typep function-or-name '(cons (member flet labels))))
454     (multiple-value-bind (fun named kind)
455     (trace-fdefinition definition)
456     (values fun t kind function-or-name))
457     (values definition t
458     (nth-value 2 (trace-fdefinition definition))))
459 ram 1.8 (trace-fdefinition function-or-name))
460 rtoy 1.40 (when (gethash (or local fun) *traced-functions*)
461 rtoy 1.46 (warn (intl:gettext "Function ~S already TRACE'd, retracing it.") function-or-name)
462 ram 1.7 (untrace-1 fun))
463    
464 rtoy 1.40 (let* ((debug-fun (di:function-debug-function fun :local-name local))
465 gerd 1.22 (encapsulated
466 ram 1.8 (if (eq (trace-info-encapsulated info) :default)
467 gerd 1.23 (let ((encapsulate-p
468 gerd 1.28 (or (not (di::can-set-function-end-breakpoint-p debug-fun))
469 gerd 1.23 (encapsulate-by-package-p function-or-name))))
470     (ecase kind
471     (:compiled
472     encapsulate-p)
473     (:compiled-closure
474     (unless (functionp function-or-name)
475 rtoy 1.46 (warn (intl:gettext "Tracing shared code for ~S:~% ~S")
476 gerd 1.23 function-or-name fun))
477     encapsulate-p)
478     ((:interpreted :interpreted-closure
479     :funcallable-instance)
480     t)))
481 ram 1.8 (trace-info-encapsulated info)))
482     (loc (if encapsulated
483     :encapsulated
484     (di:debug-function-start-location debug-fun)))
485     (info (make-trace-info
486     :what function-or-name
487     :named named
488     :encapsulated encapsulated
489     :wherein (trace-info-wherein info)
490 rtoy 1.36 :wherein-only (trace-info-wherein-only info)
491 ram 1.8 :condition (coerce-form (trace-info-condition info) loc)
492     :break (coerce-form (trace-info-break info) loc)
493     :print (coerce-form-list (trace-info-print info) loc)
494     :break-after (coerce-form (trace-info-break-after info) nil)
495     :condition-after
496     (coerce-form (trace-info-condition-after info) nil)
497     :print-after
498     (coerce-form-list (trace-info-print-after info) nil))))
499 chiles 1.1
500 rtoy 1.38 (flet ((verify-wherein (wherein-info type)
501     (dolist (wherein wherein-info)
502 rtoy 1.36 (multiple-value-bind (validp block-name)
503     (ext:valid-function-name-p wherein)
504 rtoy 1.38 (declare (ignore validp))
505 rtoy 1.36 (unless (or (stringp block-name)
506     (fboundp block-name))
507 rtoy 1.46 (warn (intl:gettext "~S name is not a defined global function: ~S")
508 rtoy 1.36 type wherein))))))
509     (verify-wherein (trace-info-wherein info) :wherein)
510     (verify-wherein (trace-info-wherein-only info) :wherein-only))
511    
512 ram 1.8
513     (cond
514     (encapsulated
515     (unless named
516 rtoy 1.46 (error (intl:gettext "Can't use encapsulation to trace anonymous function ~S.")
517 ram 1.8 fun))
518 rtoy 1.47 (when (listp function-or-name)
519 rtoy 1.46 (error (intl:gettext "Can't use encapsulation to trace local flet/labels function ~S.")
520 rtoy 1.47 function-or-name))
521 gerd 1.25 (fwrap function-or-name #'trace-fwrapper :type 'trace
522     :user-data info))
523 ram 1.8 (t
524     (multiple-value-bind
525     (start-fun cookie-fun)
526     (trace-start-breakpoint-fun info)
527     (let ((start (di:make-breakpoint start-fun debug-fun
528     :kind :function-start))
529     (end (di:make-breakpoint
530     (trace-end-breakpoint-fun info)
531     debug-fun :kind :function-end
532     :function-end-cookie cookie-fun)))
533     (setf (trace-info-start-breakpoint info) start)
534     (setf (trace-info-end-breakpoint info) end)
535     ;;
536     ;; The next two forms must be in the order in which they appear,
537     ;; since the start breakpoint must run before the function-end
538     ;; breakpoint's start helper (which calls the cookie function.)
539     ;; One reason is that cookie function requires that the CONDITIONP
540     ;; shared closure variable be initialized.
541     (di:activate-breakpoint start)
542     (di:activate-breakpoint end)))))
543    
544 rtoy 1.40 (setf (gethash (or local fun) *traced-functions*) info)))
545 ram 1.8
546     function-or-name)
547 gerd 1.23
548     ;;;
549     ;;; Return true if FUNCTION-OR-NAME's package indicates that TRACE
550     ;;; should use encapsulation instead of function-end breakpoints.
551     ;;;
552     (defun encapsulate-by-package-p (function-or-name)
553     (multiple-value-bind (valid block)
554     (valid-function-name-p function-or-name)
555     (when (and valid (symbolp block))
556     (let* ((pkg (symbol-package block))
557     (pkg-name (and pkg (package-name pkg))))
558     (member pkg-name *trace-encapsulate-package-names* :test #'equal)))))
559 ram 1.8
560    
561     ;;;; The TRACE macro:
562    
563     ;;; PARSE-TRACE-OPTIONS -- Internal
564 chiles 1.1 ;;;
565 ram 1.8 ;;; Parse leading trace options off of Specs, modifying Info accordingly.
566     ;;; The remaining portion of the list is returned when we encounter a plausible
567     ;;; function name.
568 chiles 1.1 ;;;
569 ram 1.8 (defun parse-trace-options (specs info)
570     (let ((current specs))
571 rtoy 1.36 (flet ((collect-names (value)
572     (collect ((new-names))
573     (dolist (name (if (listp (car value)) (car value) value))
574     (cond ((and (consp name) (eq (car name) 'method)
575     (ext:valid-function-name-p name))
576     ;; This needs to be coordinated with how the
577     ;; debugger prints method names. So this is
578     ;; what this code does. Any method qualifiers
579     ;; appear as a list in the debugger. No
580     ;; qualifiers show up as NIL. We also take the
581     ;; method and add a pcl::fast-method in case the
582     ;; method wasn't compiled. (Do we need to do this?)
583     (let ((method (cond ((atom (third name))
584     `(,(second name) (,(third name)) ,@(cdddr name)))
585     (t
586     `(,(second name) nil ,@(cddr name))))))
587     (new-names `(pcl::fast-method ,@method))
588     (new-names `(method ,@method))))
589     (t
590     (new-names name))))
591     (new-names))))
592     (loop
593     (when (endp current) (return))
594     (let ((option (first current))
595     (value (cons (second current) nil)))
596     (case option
597     (:condition (setf (trace-info-condition info) value))
598     (:condition-after
599     (setf (trace-info-condition info) (cons nil nil))
600     (setf (trace-info-condition-after info) value))
601     (:condition-all
602     (setf (trace-info-condition info) value)
603     (setf (trace-info-condition-after info) value))
604     (:wherein
605     (setf (trace-info-wherein info) (collect-names value)))
606     (:wherein-only
607     (setf (trace-info-wherein-only info) (collect-names value)))
608     (:encapsulate
609     (setf (trace-info-encapsulated info) (car value)))
610     (:break (setf (trace-info-break info) value))
611     (:break-after (setf (trace-info-break-after info) value))
612     (:break-all
613     (setf (trace-info-break info) value)
614     (setf (trace-info-break-after info) value))
615     (:print
616     (setf (trace-info-print info)
617     (append (trace-info-print info) (list value))))
618     (:print-after
619     (setf (trace-info-print-after info)
620     (append (trace-info-print-after info) (list value))))
621     (:print-all
622     (setf (trace-info-print info)
623     (append (trace-info-print info) (list value)))
624     (setf (trace-info-print-after info)
625     (append (trace-info-print-after info) (list value))))
626     (t (return)))
627     (pop current)
628     (unless current
629 rtoy 1.46 (error (intl:gettext "Missing argument to ~S TRACE option.") option))
630 rtoy 1.36 (pop current)))
631     current)))
632 chiles 1.1
633 ram 1.8
634     ;;; EXPAND-TRACE -- Internal
635 chiles 1.1 ;;;
636 ram 1.8 ;;; Compute the expansion of TRACE in the non-trivial case (arguments
637     ;;; specified.) If there are no :FUNCTION specs, then don't use a LET. This
638     ;;; allows TRACE to be used without the full interpreter.
639 chiles 1.1 ;;;
640 ram 1.8 (defun expand-trace (specs)
641     (collect ((binds)
642     (forms))
643     (let* ((global-options (make-trace-info))
644     (current (parse-trace-options specs global-options)))
645     (loop
646     (when (endp current) (return))
647     (let ((name (pop current))
648     (options (copy-trace-info global-options)))
649     (cond
650     ((eq name :function)
651     (let ((temp (gensym)))
652     (binds `(,temp ,(pop current)))
653     (forms `(trace-1 ,temp ',options))))
654 gerd 1.20 ;;
655     ;; Generic function -> trace all method functions.
656     ((eq name :methods)
657     (let ((tem (gensym)))
658     (binds `(,tem ,(pop current)))
659     (forms `(dolist (name (all-method-function-names ,tem))
660     (when (fboundp name)
661     (trace-1 name ',options))))))
662 ram 1.8 ((and (keywordp name)
663     (not (or (fboundp name) (macro-function name))))
664 rtoy 1.46 (error (intl:gettext "Unknown TRACE option: ~S") name))
665 gerd 1.20 ;;
666     ;; Method name -> trace method functions.
667     ((and (consp name) (eq (car name) 'method))
668     (when (fboundp name)
669     (forms `(trace-1 ',name ',options)))
670     (let ((name `(pcl::fast-method ,@(cdr name))))
671     (when (fboundp name)
672     (forms `(trace-1 ',name ',options)))))
673 ram 1.8 (t
674     (forms `(trace-1 ',name ',options))))
675     (setq current (parse-trace-options current options)))))
676 chiles 1.1
677 ram 1.8 (if (binds)
678     `(let ,(binds) (list ,@(forms)))
679     `(list ,@(forms)))))
680 chiles 1.1
681 ram 1.8
682     ;;; %LIST-TRACED-FUNCTIONS -- Internal
683 chiles 1.2 ;;;
684 ram 1.8 (defun %list-traced-functions ()
685     (loop for x being each hash-value in *traced-functions*
686     collect (trace-info-what x)))
687    
688    
689     ;;; TRACE -- Public.
690 chiles 1.2 ;;;
691 ram 1.8 (defmacro trace (&rest specs)
692 rtoy 1.45 "TRACE {Option Global-Value}* {Name {Option Value}*}*
693 ram 1.8 TRACE is a debugging tool that prints information when specified functions
694     are called. In its simplest form:
695     (trace Name-1 Name-2 ...)
696 chiles 1.1
697 gerd 1.20 CLOS methods can be traced by specifying a name of the form
698     (METHOD {Qualifier}* ({Specializer}*)).
699    
700 rtoy 1.37 Labels and Flet functions can be traced by specifying a name of the form
701     (LABELS <lfun> <fun>) or (FLET <lfun> <fun>) where <lfun> is the Labels/Flet
702     function in <fun>.
703    
704 ram 1.8 TRACE causes a printout on *TRACE-OUTPUT* each time that one of the named
705     functions is entered or returns (the Names are not evaluated.) The output
706     is indented according to the number of pending traced calls, and this trace
707     depth is printed at the beginning of each line of output.
708 chiles 1.2
709 ram 1.8 Options allow modification of the default behavior. Each option is a pair
710     of an option keyword and a value form. Options may be interspersed with
711     function names. Options only affect tracing of the function whose name they
712     appear immediately after. Global options are specified before the first
713     name, and affect all functions traced by a given use of TRACE.
714    
715     The following options are defined:
716    
717     :CONDITION Form
718     :CONDITION-AFTER Form
719     :CONDITION-ALL Form
720     If :CONDITION is specified, then TRACE does nothing unless Form
721     evaluates to true at the time of the call. :CONDITION-AFTER is
722     similar, but suppresses the initial printout, and is tested when the
723     function returns. :CONDITION-ALL tries both before and after.
724 rtoy 1.29
725 ram 1.8 :WHEREIN Names
726     If specified, Names is a function name or list of names. TRACE does
727     nothing unless a call to one of those functions encloses the call to
728     this function (i.e. it would appear in a backtrace.) Anonymous
729     functions have string names like \"DEFUN FOO\".
730 rtoy 1.36 :WHEREIN-ONLY Names
731     Like :WHEREIN, but only if the immediate caller is one of Names,
732     instead of being any where in a backtrace.
733 ram 1.8
734     :BREAK Form
735     :BREAK-AFTER Form
736     :BREAK-ALL Form
737     If specified, and Form evaluates to true, then the debugger is invoked
738     at the start of the function, at the end of the function, or both,
739     according to the respective option.
740    
741     :PRINT Form
742     :PRINT-AFTER Form
743     :PRINT-ALL Form
744 toy 1.18 In addition to the usual printout, the result of evaluating FORM is
745 ram 1.8 printed at the start of the function, at the end of the function, or
746     both, according to the respective option. Multiple print options cause
747     multiple values to be printed.
748    
749     :FUNCTION Function-Form
750     This is a not really an option, but rather another way of specifying
751     what function to trace. The Function-Form is evaluated immediately,
752     and the resulting function is traced.
753    
754 gerd 1.20 :METHODS Function-Form
755     This is a not really an option, but rather a way of specifying
756 emarsden 1.21 that all methods of a generic functions should be traced. The
757 gerd 1.20 Function-Form is evaluated immediately, and the methods of the resulting
758     generic function are traced.
759    
760 ram 1.8 :ENCAPSULATE {:DEFAULT | T | NIL}
761     If T, the tracing is done via encapsulation (redefining the function
762     name) rather than by modifying the function. :DEFAULT is the default,
763     and means to use encapsulation for interpreted functions and funcallable
764     instances, breakpoints otherwise. When encapsulation is used, forms are
765     *not* evaluated in the function's lexical environment, but DEBUG:ARG can
766     still be used.
767    
768     :CONDITION, :BREAK and :PRINT forms are evaluated in the lexical environment
769     of the called function; DEBUG:VAR and DEBUG:ARG can be used. The -AFTER and
770     -ALL forms are evaluated in the null environment."
771     (if specs
772     (expand-trace specs)
773     '(%list-traced-functions)))
774    
775 chiles 1.1
776 ram 1.8 ;;;; Untracing:
777 chiles 1.1
778 ram 1.8 ;;; UNTRACE-1 -- Internal
779     ;;;
780     ;;; Untrace one function.
781     ;;;
782     (defun untrace-1 (function-or-name)
783 rtoy 1.40 (multiple-value-bind (fun named kind local)
784     (trace-fdefinition function-or-name)
785     (declare (ignore named kind))
786     (let* ((key (or local fun))
787     (info (gethash key *traced-functions*)))
788     (cond ((not info)
789 rtoy 1.46 (warn (intl:gettext "Function is not TRACE'd -- ~S.") function-or-name))
790 rtoy 1.40 (t
791     (cond ((trace-info-encapsulated info)
792     (funwrap (trace-info-what info) :type 'trace))
793     (t
794     (di:delete-breakpoint (trace-info-start-breakpoint info))
795     (di:delete-breakpoint (trace-info-end-breakpoint info))))
796     (setf (trace-info-untraced info) t)
797     (remhash key *traced-functions*))))))
798 ram 1.8
799     ;;; UNTRACE-ALL -- Internal
800     ;;;
801     ;;; Untrace all traced functions.
802     ;;;
803     (defun untrace-all ()
804     (dolist (fun (%list-traced-functions))
805     (untrace-1 fun))
806     t)
807    
808 chiles 1.4 (defmacro untrace (&rest specs)
809 rtoy 1.45 "Removes tracing from the specified functions. With no args, untraces all
810 chiles 1.1 functions."
811 ram 1.8 (if specs
812     (collect ((res))
813     (let ((current specs))
814     (loop
815     (unless current (return))
816     (let ((name (pop current)))
817 gerd 1.20 (cond ((eq name :function)
818     (res `(untrace-1 ,(pop current))))
819     ;;
820     ;; Method name -> untrace existing method functions.
821     ((and (consp name)
822     (eq (car name) 'method))
823     (when (fboundp name)
824     (res `(untrace-1 ',name)))
825     (let ((name `(pcl::fast-method ,@(cdr name))))
826     (when (fboundp name)
827     (res `(untrace-1 ',name)))))
828     ;;
829     ;; Generic function -> untrace all method functions.
830     ((eq name :methods)
831     (res
832     `(dolist (name (all-method-function-names ,(pop current)))
833     (when (fboundp name)
834     (untrace-1 name)))))
835     (t
836     (res `(untrace-1 ',name))))))
837 ram 1.8 `(progn ,@(res) t)))
838     '(untrace-all)))

  ViewVC Help
Powered by ViewVC 1.1.5