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

Contents of /src/code/ntrace.lisp

Parent Directory Parent Directory | Revision Log Revision Log


Revision 1.48 - (show annotations)
Tue Feb 22 22:56:15 2011 UTC (3 years, 1 month ago) by rtoy
Branch: MAIN
CVS Tags: GIT-CONVERSION, snapshot-2011-09, snapshot-2011-06, snapshot-2011-07, snapshot-2011-04, snapshot-2011-03, HEAD
Changes since 1.47: +3 -2 lines
Make the test for flet/labels functions more explicit.  We were
catching setf functions previously.
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 "$Header: /tiger/var/lib/cvsroots/cmucl/src/code/ntrace.lisp,v 1.48 2011/02/22 22:56:15 rtoy Exp $")
9 ;;;
10 ;;; **********************************************************************
11 ;;;
12 ;;; This is a tracing facility based on breakpoints.
13 ;;;
14 ;;; Written by Rob MacLachlan and Bill Chiles.
15 ;;;
16 ;;; **********************************************************************
17 ;;;
18 (in-package "LISP")
19 (intl:textdomain "cmucl")
20
21 (export '(trace untrace))
22
23 (in-package "DEBUG")
24
25 (export '(*trace-values* *max-trace-indentation* *trace-encapsulate-default*
26 *trace-encapsulate-package-names*))
27
28 (use-package :fwrappers)
29
30 (defvar *trace-values* nil
31 "This is bound to the returned values when evaluating :BREAK-AFTER and
32 :PRINT-AFTER forms.")
33
34 (defvar *max-trace-indentation* 40
35 "If the trace indentation exceeds this value, then indentation restarts at
36 0.")
37
38 (defvar *trace-encapsulate-default* :default
39 "The default value for the :ENCAPSULATE option to trace.")
40
41 (defvar *trace-encapsulate-package-names*
42 '("LISP"
43 "COMMON-LISP"
44 "CONDITIONS"
45 "DEBUG"
46 "EXTENSIONS"
47 "FORMAT"
48 "KERNEL"
49 "LOOP"
50 "PRETTY-PRINT"
51 "SYSTEM"
52 "COMPILER"
53 "TRACE")
54 "List of package names. Encapsulate functions from these packages
55 by default. This should at least include the packages of functions
56 used by TRACE, directly or indirectly.")
57
58
59 ;;;; 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 ;;;
64 (defvar *traced-functions* (make-hash-table :test #'equal))
65
66 ;;; 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 ;; Like wherein, but only if the caller is in the list.
98 (wherein-only nil :type list)
99 ;;
100 ;; 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
122 ;;; 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
143 ;;; 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 ;;; TRACE-FDEFINITION -- Internal
153 ;;;
154 ;;; 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 ;;;
161 (defun trace-fdefinition (x)
162 (multiple-value-bind (res named-p local)
163 (typecase x
164 (symbol
165 (cond ((special-operator-p x)
166 (error (intl:gettext "Can't trace special form ~S.") x))
167 ((macro-function x))
168 (t
169 (values (fdefinition x) t))))
170 (function x)
171 ((cons (member flet labels))
172 ;; An extended function name for flet/labels functions.
173 (values (fdefinition (car (last x))) t x))
174 (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 (t (values res named-p :compiled local))))))
184
185
186 ;;; TRACE-REDEFINED-UPDATE -- Internal
187 ;;;
188 ;;; When a function name is redefined, and we were tracing that name, then
189 ;;; untrace the old definition and trace the new one.
190 ;;;
191 (defun trace-redefined-update (fname new-value)
192 (when (fboundp fname)
193 (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 ;;;
214 (push #'trace-redefined-update ext:*setf-fdefinition-hook*)
215
216
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 (format t "~@V,0T~D: "
262 (+ (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 (let ((frame-name (di:debug-function-name (di:frame-debug-function frame))))
274 (when (member frame-name names :test #'equal)
275 (return t)))))
276
277 ;;; 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 ;;; 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 (break (intl:gettext "Breaking ~A traced call to ~S:") where
306 (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 (wherein (trace-info-wherein info))
341 (wherein-only (trace-info-wherein-only info)))
342 (setq conditionp
343 (and (not *in-trace*)
344 (or (not condition)
345 (funcall (cdr condition) frame))
346 (or (not wherein)
347 (trace-wherein-p frame wherein))
348 (or (not wherein-only)
349 (trace-wherein-only-p frame wherein-only)))))
350
351 (when conditionp
352 (let ((*print-length* (or *debug-print-length* *print-length*))
353 (*print-level* (or *debug-print-level* *print-level*))
354 (kernel:*current-level* 0)
355 (*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 (print-frame-call frame :verbosity 1))
363 (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 ;;;
380 (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 (kernel:*current-level* 0)
395 (*standard-output* *trace-output*)
396 (*in-trace* t))
397 (fresh-line)
398 (pprint-logical-block (*standard-output* nil)
399 (print-trace-indentation)
400 (pprint-indent :current 2)
401 (format t (intl:gettext "~S returned") (trace-info-what info))
402 (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 (trace-maybe-break info (trace-info-break-after info)
409 "after" frame)))))
410
411
412 ;;; TRACE-FWRAPPER -- Internal
413 ;;;
414 ;;; 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 ;;;
418 (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 (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 (let ((vals (multiple-value-list (call-next-function))))
433 (funcall (trace-end-breakpoint-fun info) frame nil vals nil)
434 (values-list vals))))))))
435
436
437 ;;; TRACE-1 -- Internal.
438 ;;;
439 ;;; 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 ;;;
443 ;;; 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 (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 (trace-fdefinition function-or-name))
460 (when (gethash (or local fun) *traced-functions*)
461 (warn (intl:gettext "Function ~S already TRACE'd, retracing it.") function-or-name)
462 (untrace-1 fun))
463
464 (let* ((debug-fun (di:function-debug-function fun :local-name local))
465 (encapsulated
466 (if (eq (trace-info-encapsulated info) :default)
467 (let ((encapsulate-p
468 (or (not (di::can-set-function-end-breakpoint-p debug-fun))
469 (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 (warn (intl:gettext "Tracing shared code for ~S:~% ~S")
476 function-or-name fun))
477 encapsulate-p)
478 ((:interpreted :interpreted-closure
479 :funcallable-instance)
480 t)))
481 (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 :wherein-only (trace-info-wherein-only info)
491 :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
500 (flet ((verify-wherein (wherein-info type)
501 (dolist (wherein wherein-info)
502 (multiple-value-bind (validp block-name)
503 (ext:valid-function-name-p wherein)
504 (declare (ignore validp))
505 (unless (or (stringp block-name)
506 (fboundp block-name))
507 (warn (intl:gettext "~S name is not a defined global function: ~S")
508 type wherein))))))
509 (verify-wherein (trace-info-wherein info) :wherein)
510 (verify-wherein (trace-info-wherein-only info) :wherein-only))
511
512
513 (cond
514 (encapsulated
515 (unless named
516 (error (intl:gettext "Can't use encapsulation to trace anonymous function ~S.")
517 fun))
518 (when (and (listp function-or-name)
519 (member function-or-name '(flet labels)))
520 (error (intl:gettext "Can't use encapsulation to trace local flet/labels function ~S.")
521 function-or-name))
522 (fwrap function-or-name #'trace-fwrapper :type 'trace
523 :user-data info))
524 (t
525 (multiple-value-bind
526 (start-fun cookie-fun)
527 (trace-start-breakpoint-fun info)
528 (let ((start (di:make-breakpoint start-fun debug-fun
529 :kind :function-start))
530 (end (di:make-breakpoint
531 (trace-end-breakpoint-fun info)
532 debug-fun :kind :function-end
533 :function-end-cookie cookie-fun)))
534 (setf (trace-info-start-breakpoint info) start)
535 (setf (trace-info-end-breakpoint info) end)
536 ;;
537 ;; The next two forms must be in the order in which they appear,
538 ;; since the start breakpoint must run before the function-end
539 ;; breakpoint's start helper (which calls the cookie function.)
540 ;; One reason is that cookie function requires that the CONDITIONP
541 ;; shared closure variable be initialized.
542 (di:activate-breakpoint start)
543 (di:activate-breakpoint end)))))
544
545 (setf (gethash (or local fun) *traced-functions*) info)))
546
547 function-or-name)
548
549 ;;;
550 ;;; Return true if FUNCTION-OR-NAME's package indicates that TRACE
551 ;;; should use encapsulation instead of function-end breakpoints.
552 ;;;
553 (defun encapsulate-by-package-p (function-or-name)
554 (multiple-value-bind (valid block)
555 (valid-function-name-p function-or-name)
556 (when (and valid (symbolp block))
557 (let* ((pkg (symbol-package block))
558 (pkg-name (and pkg (package-name pkg))))
559 (member pkg-name *trace-encapsulate-package-names* :test #'equal)))))
560
561
562 ;;;; The TRACE macro:
563
564 ;;; PARSE-TRACE-OPTIONS -- Internal
565 ;;;
566 ;;; Parse leading trace options off of Specs, modifying Info accordingly.
567 ;;; The remaining portion of the list is returned when we encounter a plausible
568 ;;; function name.
569 ;;;
570 (defun parse-trace-options (specs info)
571 (let ((current specs))
572 (flet ((collect-names (value)
573 (collect ((new-names))
574 (dolist (name (if (listp (car value)) (car value) value))
575 (cond ((and (consp name) (eq (car name) 'method)
576 (ext:valid-function-name-p name))
577 ;; This needs to be coordinated with how the
578 ;; debugger prints method names. So this is
579 ;; what this code does. Any method qualifiers
580 ;; appear as a list in the debugger. No
581 ;; qualifiers show up as NIL. We also take the
582 ;; method and add a pcl::fast-method in case the
583 ;; method wasn't compiled. (Do we need to do this?)
584 (let ((method (cond ((atom (third name))
585 `(,(second name) (,(third name)) ,@(cdddr name)))
586 (t
587 `(,(second name) nil ,@(cddr name))))))
588 (new-names `(pcl::fast-method ,@method))
589 (new-names `(method ,@method))))
590 (t
591 (new-names name))))
592 (new-names))))
593 (loop
594 (when (endp current) (return))
595 (let ((option (first current))
596 (value (cons (second current) nil)))
597 (case option
598 (:condition (setf (trace-info-condition info) value))
599 (:condition-after
600 (setf (trace-info-condition info) (cons nil nil))
601 (setf (trace-info-condition-after info) value))
602 (:condition-all
603 (setf (trace-info-condition info) value)
604 (setf (trace-info-condition-after info) value))
605 (:wherein
606 (setf (trace-info-wherein info) (collect-names value)))
607 (:wherein-only
608 (setf (trace-info-wherein-only info) (collect-names value)))
609 (:encapsulate
610 (setf (trace-info-encapsulated info) (car value)))
611 (:break (setf (trace-info-break info) value))
612 (:break-after (setf (trace-info-break-after info) value))
613 (:break-all
614 (setf (trace-info-break info) value)
615 (setf (trace-info-break-after info) value))
616 (:print
617 (setf (trace-info-print info)
618 (append (trace-info-print info) (list value))))
619 (:print-after
620 (setf (trace-info-print-after info)
621 (append (trace-info-print-after info) (list value))))
622 (:print-all
623 (setf (trace-info-print info)
624 (append (trace-info-print info) (list value)))
625 (setf (trace-info-print-after info)
626 (append (trace-info-print-after info) (list value))))
627 (t (return)))
628 (pop current)
629 (unless current
630 (error (intl:gettext "Missing argument to ~S TRACE option.") option))
631 (pop current)))
632 current)))
633
634
635 ;;; EXPAND-TRACE -- Internal
636 ;;;
637 ;;; Compute the expansion of TRACE in the non-trivial case (arguments
638 ;;; specified.) If there are no :FUNCTION specs, then don't use a LET. This
639 ;;; allows TRACE to be used without the full interpreter.
640 ;;;
641 (defun expand-trace (specs)
642 (collect ((binds)
643 (forms))
644 (let* ((global-options (make-trace-info))
645 (current (parse-trace-options specs global-options)))
646 (loop
647 (when (endp current) (return))
648 (let ((name (pop current))
649 (options (copy-trace-info global-options)))
650 (cond
651 ((eq name :function)
652 (let ((temp (gensym)))
653 (binds `(,temp ,(pop current)))
654 (forms `(trace-1 ,temp ',options))))
655 ;;
656 ;; Generic function -> trace all method functions.
657 ((eq name :methods)
658 (let ((tem (gensym)))
659 (binds `(,tem ,(pop current)))
660 (forms `(dolist (name (all-method-function-names ,tem))
661 (when (fboundp name)
662 (trace-1 name ',options))))))
663 ((and (keywordp name)
664 (not (or (fboundp name) (macro-function name))))
665 (error (intl:gettext "Unknown TRACE option: ~S") name))
666 ;;
667 ;; Method name -> trace method functions.
668 ((and (consp name) (eq (car name) 'method))
669 (when (fboundp name)
670 (forms `(trace-1 ',name ',options)))
671 (let ((name `(pcl::fast-method ,@(cdr name))))
672 (when (fboundp name)
673 (forms `(trace-1 ',name ',options)))))
674 (t
675 (forms `(trace-1 ',name ',options))))
676 (setq current (parse-trace-options current options)))))
677
678 (if (binds)
679 `(let ,(binds) (list ,@(forms)))
680 `(list ,@(forms)))))
681
682
683 ;;; %LIST-TRACED-FUNCTIONS -- Internal
684 ;;;
685 (defun %list-traced-functions ()
686 (loop for x being each hash-value in *traced-functions*
687 collect (trace-info-what x)))
688
689
690 ;;; TRACE -- Public.
691 ;;;
692 (defmacro trace (&rest specs)
693 "TRACE {Option Global-Value}* {Name {Option Value}*}*
694 TRACE is a debugging tool that prints information when specified functions
695 are called. In its simplest form:
696 (trace Name-1 Name-2 ...)
697
698 CLOS methods can be traced by specifying a name of the form
699 (METHOD {Qualifier}* ({Specializer}*)).
700
701 Labels and Flet functions can be traced by specifying a name of the form
702 (LABELS <lfun> <fun>) or (FLET <lfun> <fun>) where <lfun> is the Labels/Flet
703 function in <fun>.
704
705 TRACE causes a printout on *TRACE-OUTPUT* each time that one of the named
706 functions is entered or returns (the Names are not evaluated.) The output
707 is indented according to the number of pending traced calls, and this trace
708 depth is printed at the beginning of each line of output.
709
710 Options allow modification of the default behavior. Each option is a pair
711 of an option keyword and a value form. Options may be interspersed with
712 function names. Options only affect tracing of the function whose name they
713 appear immediately after. Global options are specified before the first
714 name, and affect all functions traced by a given use of TRACE.
715
716 The following options are defined:
717
718 :CONDITION Form
719 :CONDITION-AFTER Form
720 :CONDITION-ALL Form
721 If :CONDITION is specified, then TRACE does nothing unless Form
722 evaluates to true at the time of the call. :CONDITION-AFTER is
723 similar, but suppresses the initial printout, and is tested when the
724 function returns. :CONDITION-ALL tries both before and after.
725
726 :WHEREIN Names
727 If specified, Names is a function name or list of names. TRACE does
728 nothing unless a call to one of those functions encloses the call to
729 this function (i.e. it would appear in a backtrace.) Anonymous
730 functions have string names like \"DEFUN FOO\".
731 :WHEREIN-ONLY Names
732 Like :WHEREIN, but only if the immediate caller is one of Names,
733 instead of being any where in a backtrace.
734
735 :BREAK Form
736 :BREAK-AFTER Form
737 :BREAK-ALL Form
738 If specified, and Form evaluates to true, then the debugger is invoked
739 at the start of the function, at the end of the function, or both,
740 according to the respective option.
741
742 :PRINT Form
743 :PRINT-AFTER Form
744 :PRINT-ALL Form
745 In addition to the usual printout, the result of evaluating FORM is
746 printed at the start of the function, at the end of the function, or
747 both, according to the respective option. Multiple print options cause
748 multiple values to be printed.
749
750 :FUNCTION Function-Form
751 This is a not really an option, but rather another way of specifying
752 what function to trace. The Function-Form is evaluated immediately,
753 and the resulting function is traced.
754
755 :METHODS Function-Form
756 This is a not really an option, but rather a way of specifying
757 that all methods of a generic functions should be traced. The
758 Function-Form is evaluated immediately, and the methods of the resulting
759 generic function are traced.
760
761 :ENCAPSULATE {:DEFAULT | T | NIL}
762 If T, the tracing is done via encapsulation (redefining the function
763 name) rather than by modifying the function. :DEFAULT is the default,
764 and means to use encapsulation for interpreted functions and funcallable
765 instances, breakpoints otherwise. When encapsulation is used, forms are
766 *not* evaluated in the function's lexical environment, but DEBUG:ARG can
767 still be used.
768
769 :CONDITION, :BREAK and :PRINT forms are evaluated in the lexical environment
770 of the called function; DEBUG:VAR and DEBUG:ARG can be used. The -AFTER and
771 -ALL forms are evaluated in the null environment."
772 (if specs
773 (expand-trace specs)
774 '(%list-traced-functions)))
775
776
777 ;;;; Untracing:
778
779 ;;; UNTRACE-1 -- Internal
780 ;;;
781 ;;; Untrace one function.
782 ;;;
783 (defun untrace-1 (function-or-name)
784 (multiple-value-bind (fun named kind local)
785 (trace-fdefinition function-or-name)
786 (declare (ignore named kind))
787 (let* ((key (or local fun))
788 (info (gethash key *traced-functions*)))
789 (cond ((not info)
790 (warn (intl:gettext "Function is not TRACE'd -- ~S.") function-or-name))
791 (t
792 (cond ((trace-info-encapsulated info)
793 (funwrap (trace-info-what info) :type 'trace))
794 (t
795 (di:delete-breakpoint (trace-info-start-breakpoint info))
796 (di:delete-breakpoint (trace-info-end-breakpoint info))))
797 (setf (trace-info-untraced info) t)
798 (remhash key *traced-functions*))))))
799
800 ;;; UNTRACE-ALL -- Internal
801 ;;;
802 ;;; Untrace all traced functions.
803 ;;;
804 (defun untrace-all ()
805 (dolist (fun (%list-traced-functions))
806 (untrace-1 fun))
807 t)
808
809 (defmacro untrace (&rest specs)
810 "Removes tracing from the specified functions. With no args, untraces all
811 functions."
812 (if specs
813 (collect ((res))
814 (let ((current specs))
815 (loop
816 (unless current (return))
817 (let ((name (pop current)))
818 (cond ((eq name :function)
819 (res `(untrace-1 ,(pop current))))
820 ;;
821 ;; Method name -> untrace existing method functions.
822 ((and (consp name)
823 (eq (car name) 'method))
824 (when (fboundp name)
825 (res `(untrace-1 ',name)))
826 (let ((name `(pcl::fast-method ,@(cdr name))))
827 (when (fboundp name)
828 (res `(untrace-1 ',name)))))
829 ;;
830 ;; Generic function -> untrace all method functions.
831 ((eq name :methods)
832 (res
833 `(dolist (name (all-method-function-names ,(pop current)))
834 (when (fboundp name)
835 (untrace-1 name)))))
836 (t
837 (res `(untrace-1 ',name))))))
838 `(progn ,@(res) t)))
839 '(untrace-all)))

  ViewVC Help
Powered by ViewVC 1.1.5