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

Contents of /src/code/ntrace.lisp

Parent Directory Parent Directory | Revision Log Revision Log


Revision 1.7 - (show annotations)
Fri May 15 18:31:05 1992 UTC (21 years, 11 months ago) by ram
Branch: MAIN
Changes since 1.6: +105 -101 lines
Fixed to actually allow tracing anonymous function objects.  Changed to allow
tracing of macros.  When tracing an already traced function, untrace and
retrace it, instead of ignoring the second request.  Moved the undefined error
for UNTRACE to the UNTRACE-1 subfunction, instead of signalling it at
macroexpand time.  In TRACE-1, added an assertion that there isn't already an
entry in the trace breakpoint table, since sometimes we seem to be forgetting
about breakpoints.
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 ;;; If you want to use this code or any part of CMU Common Lisp, please contact
7 ;;; Scott Fahlman or slisp-group@cs.cmu.edu.
8 ;;;
9 (ext:file-comment
10 "$Header: /tiger/var/lib/cvsroots/cmucl/src/code/ntrace.lisp,v 1.7 1992/05/15 18:31:05 ram Exp $")
11 ;;;
12 ;;; **********************************************************************
13 ;;;
14 ;;; This is a tracing facility.
15 ;;;
16 ;;; THIS IS CURRENTLY UNDER DEVELOPMENT AND TESTING.
17 ;;;
18 ;;; Written by Bill Chiles.
19 ;;;
20 ;;; **********************************************************************
21 ;;;
22
23 (in-package "LISP")
24
25 (export '(trace untrace))
26
27
28 (in-package "DEBUG")
29
30 (export '(*trace-print-level* *trace-print-length* *traced-function-list*
31 *trace-frame* *trace-values* *max-trace-indentation*))
32
33 (defvar *traced-function-list* nil
34 "A list of functions which are traced.")
35
36 (defvar *trace-print-length* nil
37 "Tracing output occurs with *print-length* bound to this value.")
38
39 (defvar *trace-print-level* nil
40 "Tracing output occurs with *print-level* bound to this value.")
41
42 (defvar *trace-frame* nil
43 "TRACE causes expressions for its switches to evaluate within a context
44 where this is bound to the appropriate control stack frame.")
45
46 (defvar *trace-values* nil
47 "This is bound to the returned values when evaluating :BREAK-AFTER and
48 :PRINT-AFTER forms.")
49
50 (defvar *max-trace-indentation* nil
51 "This is currently unused.")
52
53
54 ;;; TRACE -- Public.
55 ;;;
56 (defmacro trace (&rest specs)
57 "Establishes tracing for specified functions and pushes them on
58 *traced-function-list*. Each specification is one of the following:
59 function
60 the name of a function
61 a list form
62 If it is a list form, it has the following structure:
63 (function-or-name <trace-option> <value> <trace-option> <value> ...)
64 If you supply no specifications, TRACE returns the list of traced functions.
65 The following options are valid:
66 :condition
67 A form to EVAL to determine whether TRACE should display anything.
68 :break
69 A form to EVAL to determine whether to call BREAK before the call.
70 :break-after
71 Like :break, but takes effect after the call.
72 :break-all
73 Like :break, but takes effect before and after call.
74 :wherein
75 A function name or list of names in which TRACE will display a call.
76 :print
77 A list of forms for EVAL whose results TRACE will display in addition
78 to other information before the call.
79 :print-after
80 Like :print, but takes effect after the call.
81 :print-all
82 Like :print, but takes effect before and after the call.
83
84 While the provided expression evaluate, debug:*trace-frame* is bound to the
85 appropriate frame for accessing locals of the TRACE'd function. Therefore,
86 you can use DI:PREPROCESS-FOR-EVAL (and DI:DEBUG-FUNCTION-START-LOCATION if
87 necessary) and with its resulting function, provide an expression including
88 a FUNCALL of the function and debug:*trace-frame*."
89 (cond
90 ((not specs) '*traced-function-list*)
91 (t
92 (let ((name-list nil)
93 (trace-1-forms nil))
94 (dolist (spec specs `(progn
95 ,@trace-1-forms
96 ',(reverse name-list)))
97 (multiple-value-bind
98 (name options)
99 (typecase spec
100 ((or symbol function)
101 (values spec nil))
102 (list
103 (let ((fun (car spec)))
104 (cond ((eq fun 'quote)
105 (error "Do NOT quote function names."))
106 ((or (symbolp fun) (functionp fun))
107 (values fun (cdr spec)))
108 ((not (and (consp fun) (= (length fun) 2)))
109 (error "Illegal function name: ~S." fun))
110 ((eq (car fun) 'setf)
111 (values fun (cdr spec)))
112 (t (error "Illegal function name: ~S." fun)))))
113 (t (error "Illegal trace spec: ~S." spec)))
114 (push name name-list)
115 (destructuring-bind (&key condition break break-after break-all
116 wherein print print-after print-all)
117 options
118 (when break-all
119 (setf break (setf break-after break-all)))
120 (when print-all
121 (setf print (setf print-after print-all)))
122 ;; Wherein must be a list of symbols or nil.
123 (setf wherein
124 (typecase wherein
125 (null nil)
126 (symbol (list wherein))
127 (list (dolist (fun wherein wherein)
128 (unless (or (symbolp fun)
129 (and (consp fun)
130 (= (length fun) 2)
131 (eq (car fun) 'setf)))
132 (error "Illegal function name, ~S, in :wherein."
133 fun))))
134 (t (error "Illegal :wherein option: ~S." wherein))))
135 ;; Print and print-after must be lists.
136 (unless (listp print)
137 (error "Illegal form list, ~S, for :print." print))
138 (unless (listp print-after)
139 (error "Illegal form list, ~S, for :print-after." print-after))
140 (push `(trace-1 ',name ',condition ',break ',break-after
141 ',wherein ',print ',print-after)
142 trace-1-forms))))))))
143
144
145 ;;; TRACE-FDEFINITION -- Internal
146 ;;;
147 ;;; Given a function or macro name, return the definition. Error if a
148 ;;; special form. If already a function, just return it.
149 ;;;
150 (defun trace-fdefinition (x)
151 (typecase x
152 (symbol
153 (cond ((special-form-p x)
154 (error "Can't trace special form ~S." x))
155 ((macro-function x))
156 (t
157 (fdefinition x))))
158 (function x)
159 (t (fdefinition x))))
160
161
162 ;;; This is a list of function-end-cookies, which we use to note distinct
163 ;;; dynamic entries into functions.
164 ;;;
165 ;;; The length of this list tells us the indentation to use for printing TRACE
166 ;;; messages.
167 ;;;
168 ;;; This list also helps us synchronize the TRACE facility dynamically for
169 ;;; detecting non-local flow of control that affects TRACE'ing. Whenever
170 ;;; execution hits a :function-end breakpoint used for TRACE'ing, we look for
171 ;;; the function-end-cookie at the top of *traced-entries*. If it is not
172 ;;; there, we can adjust our indentation and the contents of the list
173 ;;; accordingly, printing a warning that some TRACE'd entries have been fouled.
174 ;;;
175 (defvar *traced-entries* nil)
176
177 ;;; This maps functions to the two breakpoints created in TRACE-1, so we can
178 ;;; get rid of them in UNTRACE-1.
179 ;;;
180 (defvar *trace-breakpoints* (make-hash-table :test #'eq))
181 ;;;
182 (defun clear-trace-breakpoint-record (fname new-value)
183 (declare (ignore new-value))
184 (when (fboundp fname)
185 (let* ((fun (trace-fdefinition fname))
186 (bpts (gethash fun *trace-breakpoints*)))
187 (when bpts
188 ;; Free breakpoint bookkeeping data.
189 (di:delete-breakpoint (car bpts))
190 (di:delete-breakpoint (cdr bpts))
191 ;; Free TRACE bookkeeping data.
192 (setf (gethash fun *trace-breakpoints*) nil)))))
193 ;;;
194 (push #'clear-trace-breakpoint-record ext:*setf-fdefinition-hook*)
195
196 ;;; TRACE-1 -- Internal.
197 ;;;
198 ;;; This establishes :function-start and :function-end breakpoints with
199 ;;; appropriate hook functions to TRACE function-name as described by the user.
200 ;;;
201 (defun trace-1 (function-or-name condition break break-after wherein print
202 print-after)
203 (let ((fun (trace-fdefinition function-or-name)))
204 (when (member fun *traced-function-list*)
205 (warn "Function ~S already TRACE'd, retracing it." function-or-name)
206 (untrace-1 fun))
207
208 (when wherein
209 (dolist (f wherein)
210 (unless (fboundp f)
211 (error "Undefined :wherein name -- ~S." f))))
212 (let* ((debug-fun (di:function-debug-function fun))
213 ;; The start and end hooks use conditionp for communication.
214 (conditionp nil)
215 (start (di:make-breakpoint
216 #'(lambda (frame bpt)
217 (let ((*trace-frame* frame))
218 (cond ((and (or (not condition) ;Save a call to EVAL
219 (eval condition))
220 (or (not wherein)
221 (trace-wherein-p frame wherein)))
222 (setf conditionp t)
223 (print-trace-start frame bpt print))
224 (t (setf conditionp nil)))
225 (when (and break (eval break))
226 (di:flush-frames-above frame)
227 (let ((*stack-top-hint* frame))
228 (break "Breaking before TRACE'd call to ~S."
229 function-or-name)))))
230 debug-fun :kind :function-start))
231 (end (di:make-breakpoint
232 #'(lambda (frame bpt *trace-values* cookie)
233 (if (member fun *traced-function-list*)
234 (let ((*trace-frame* frame))
235 (when conditionp
236 (print-trace-end frame bpt *trace-values* cookie
237 print-after))
238 (pop *traced-entries*)
239 (when (and break-after (eval break-after))
240 (di:flush-frames-above frame)
241 (let ((*stack-top-hint* frame))
242 (break "Breaking after TRACE'd call to ~S."
243 function-or-name))))
244 (pop *traced-entries*)))
245 debug-fun :kind :function-end
246 :function-end-cookie
247 #'(lambda (frame x)
248 (when (and *traced-entries*
249 (not (di:function-end-cookie-valid-p
250 frame (car *traced-entries*))))
251 (loop
252 (pop *traced-entries*)
253 (when (or (not *traced-entries*)
254 (di:function-end-cookie-valid-p
255 frame (car *traced-entries*)))
256 (return))))
257 (push x *traced-entries*)))))
258 (assert (not (gethash fun *trace-breakpoints*)))
259 (setf (gethash fun *trace-breakpoints*) (cons start end))
260 ;; The next two forms must be in the order in which they appear. They
261 ;; rely on a documented property that later activated breakpoint hooks
262 ;; run first, and the end breakpoint establishes a starting helper bpt.
263 (di:activate-breakpoint start)
264 (di:activate-breakpoint end))
265 (push fun *traced-function-list*)))
266
267 ;;; PRINT-TRACE-START -- Internal.
268 ;;;
269 ;;; This prints a representation of the call establishing frame.
270 ;;;
271 (defun print-trace-start (frame bpt &optional print)
272 (declare (ignore bpt))
273 (let ((*print-length* (or *trace-print-length* *print-length*))
274 (*print-level* (or *trace-print-level* *print-level*)))
275 (fresh-line)
276 (print-trace-indentation)
277 (print-frame-call-1 frame nil)
278 (dolist (ele print)
279 (fresh-line)
280 (print-trace-indentation)
281 (prin1 (eval ele)))
282 (terpri)))
283
284 ;;; PRINT-TRACE-END -- Internal.
285 ;;;
286 ;;; This prints a representation of the return values delivered to frame by the
287 ;;; function for which bpt is a :function-end breakpoint. First, this checks
288 ;;; to see that cookie is at the top of *traced-entries*; if it is not, then we
289 ;;; need to adjust this list to determine the correct indentation for output.
290 ;;;
291 (defun print-trace-end (frame bpt values cookie &optional print-after)
292 (declare (ignore frame bpt))
293 (unless (eq cookie (car *traced-entries*))
294 (setf *traced-entries* (member cookie *traced-entries*)))
295 (print-trace-indentation)
296 (write-string "returned ")
297 (dolist (v values)
298 (prin1 v)
299 (write-char #\space))
300 (dolist (ele print-after)
301 (terpri)
302 (print-trace-indentation)
303 (prin1 (eval ele)))
304 (terpri))
305
306 (defun print-trace-indentation ()
307 (let ((len (length (the list *traced-entries*))))
308 (dotimes (i len) (write-string " "))
309 (prin1 len)
310 (write-string ": ")))
311
312 ;;; TRACE-WHEREIN-P -- Internal.
313 ;;;
314 ;;; The TRACE hooks use this for the :wherein arg.
315 ;;;
316 (defun trace-wherein-p (frame names)
317 (do ((frame (di:frame-down frame) (di:frame-down frame)))
318 ((not frame) nil)
319 (when (member (di:debug-function-name (di:frame-debug-function frame))
320 names :test #'equal)
321 (return t))))
322
323
324
325 ;;;; N-UNTRACE.
326
327 (defmacro untrace (&rest specs)
328 "Removes tracing from the specified functions. With no args, untraces all
329 functions."
330 (let ((specs (or specs *traced-function-list*)))
331 `(progn
332 ,@(mapcar #'(lambda (spec)
333 `(untrace-1 ',(if (consp spec) (car spec) spec)))
334 specs)
335 t)))
336
337 (defun untrace-1 (function-or-name)
338 (let ((fun (trace-fdefinition function-or-name)))
339 (cond ((member fun *traced-function-list*)
340 (let ((breakpoints (gethash fun *trace-breakpoints*)))
341 (di:delete-breakpoint (car breakpoints))
342 (di:delete-breakpoint (cdr breakpoints))
343 (setf (gethash fun *trace-breakpoints*) nil))
344 (setf *traced-function-list* (delete fun *traced-function-list*)))
345 (t (warn "Function is not TRACE'd -- ~S." fun)))))

  ViewVC Help
Powered by ViewVC 1.1.5