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

Contents of /src/code/ntrace.lisp

Parent Directory Parent Directory | Revision Log Revision Log


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

  ViewVC Help
Powered by ViewVC 1.1.5