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

Contents of /src/code/ntrace.lisp

Parent Directory Parent Directory | Revision Log Revision Log


Revision 1.40 - (hide annotations)
Thu Oct 18 22:26:08 2007 UTC (6 years, 6 months ago) by rtoy
Branch: MAIN
CVS Tags: snapshot-2007-12, snapshot-2007-11
Changes since 1.39: +54 -28 lines
Slight reimplemention of how tracing of local functions is done.   We
don't do the hackish list-of-name to find local debug function
anymore.  This change allows us to retrace local functions when the
function is redefined.

code/debug-int.lisp:
o Add :LOCAL-NAME keyword parameter to tell us to look for the local
  function within the given FUN.  The bizarre hack using a list as the
  FUN to do this is now gone.

code/ntrace.lisp:
o Change TRACE-FDEFINITION to return a fourth value if the function is
  a local function.  The fourth value is the name of the local
  function.

o TRACE-1 recognizes the extra value from TRACE-FDEFINITION to
  determine if this is a local function that needs to be traced.
  Also, if DEFINITION is given, we process that carefully so we can
  trace the new definition with a local function.

o UNTRACE-1 likewise updated to recognize and handle local functions.

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

  ViewVC Help
Powered by ViewVC 1.1.5