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

Contents of /src/code/ntrace.lisp

Parent Directory Parent Directory | Revision Log Revision Log


Revision 1.5 - (show annotations)
Tue Mar 10 15:55:28 1992 UTC (22 years, 1 month ago) by wlott
Branch: MAIN
Changes since 1.4: +2 -6 lines
Don't bother warning about dynamic flow of control, because it is obvious
from the call depth numbers and the warning can happen at real confusing
times.
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.5 1992/03/10 15:55:28 wlott 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* *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 *max-trace-indentation* nil
47 "This is currently unused.")
48
49
50 ;;; TRACE -- Public.
51 ;;;
52 (defmacro trace (&rest specs)
53 "Establishes tracing for specified functions and pushes them on
54 *traced-function-list*. Each specification is one of the following:
55 function
56 the name of a function
57 a list form
58 If it is a list form, it has the following structure:
59 (function-or-name <trace-option> <value> <trace-option> <value> ...)
60 If you supply no specifications, TRACE returns the list of traced functions.
61 The following options are valid:
62 :condition
63 A form to EVAL to determine whether TRACE should display anything.
64 :break
65 A form to EVAL to determine whether to call BREAK before the call.
66 :break-after
67 Like :break, but takes effect after the call.
68 :break-all
69 Like :break, but takes effect before and after call.
70 :wherein
71 A function name or list of names in which TRACE will display a call.
72 :print
73 A list of forms for EVAL whose results TRACE will display in addition
74 to other information before the call.
75 :print-after
76 Like :print, but takes effect after the call.
77 :print-all
78 Like :print, but takes effect before and after the call.
79
80 While the provided expression evaluate, debug:*trace-frame* is bound to the
81 appropriate frame for accessing locals of the TRACE'd function. Therefore,
82 you can use DI:PREPROCESS-FOR-EVAL (and DI:DEBUG-FUNCTION-START-LOCATION if
83 necessary) and with its resulting function, provide an expression including
84 a FUNCALL of the function and debug:*trace-frame*."
85 (cond
86 ((not specs) '*traced-function-list*)
87 (t
88 (let ((name-list nil)
89 (trace-1-forms nil))
90 (dolist (spec specs `(progn
91 ;; Make sure every name has a definition.
92 ,@(mapcar #'(lambda (x) `#',x) name-list)
93 ,@trace-1-forms
94 ',(nreverse name-list)))
95 (multiple-value-bind
96 (name options)
97 (typecase spec
98 ((or symbol function)
99 (values spec nil))
100 (list
101 (let ((fun (car spec)))
102 (cond ((eq fun 'quote)
103 (error "Do NOT quote function names."))
104 ((or (symbolp fun) (functionp fun))
105 (values fun (cdr spec)))
106 ((not (and (consp fun) (= (length fun) 2)))
107 (error "Illegal function name: ~S." fun))
108 ((eq (car fun) 'setf)
109 (values fun (cdr spec)))
110 (t (error "Illegal function name: ~S." fun)))))
111 (t (error "Illegal trace spec: ~S." spec)))
112 (push name name-list)
113 (destructuring-bind (&key condition break break-after break-all
114 wherein print print-after print-all)
115 options
116 (when break-all
117 (setf break (setf break-after break-all)))
118 (when print-all
119 (setf print (setf print-after print-all)))
120 ;; Wherein must be a list of symbols or nil.
121 (setf wherein
122 (typecase wherein
123 (null nil)
124 (symbol (list wherein))
125 (list (dolist (fun wherein wherein)
126 (unless (or (symbolp fun)
127 (and (consp fun)
128 (= (length fun) 2)
129 (eq (car fun) 'setf)))
130 (error "Illegal function name, ~S, in :wherein."
131 fun))))
132 (t (error "Illegal :wherein option: ~S." wherein))))
133 ;; Print and print-after must be lists.
134 (unless (listp print)
135 (error "Illegal form list, ~S, for :print." print))
136 (unless (listp print-after)
137 (error "Illegal form list, ~S, for :print-after." print-after))
138 (push `(trace-1 ',name ',condition ',break ',break-after
139 ',wherein ',print ',print-after)
140 trace-1-forms))))))))
141
142 ;;; This is a list of function-end-cookies, which we use to note distinct
143 ;;; dynamic entries into functions.
144 ;;;
145 ;;; The length of this list tells us the indentation to use for printing TRACE
146 ;;; messages.
147 ;;;
148 ;;; This list also helps us synchronize the TRACE facility dynamically for
149 ;;; detecting non-local flow of control that affects TRACE'ing. Whenever
150 ;;; execution hits a :function-end breakpoint used for TRACE'ing, we look for
151 ;;; the function-end-cookie at the top of *traced-entries*. If it is not
152 ;;; there, we can adjust our indentation and the contents of the list
153 ;;; accordingly, printing a warning that some TRACE'd entries have been fouled.
154 ;;;
155 (defvar *traced-entries* nil)
156
157 ;;; This maps functions to the two breakpoints created in TRACE-1, so we can
158 ;;; get rid of them in UNTRACE-1.
159 ;;;
160 (defvar *trace-breakpoints* (make-hash-table :test #'eq))
161 ;;;
162 (defun clear-trace-breakpoint-record (fname new-value)
163 (declare (ignore new-value))
164 (when (fboundp fname)
165 (let* ((fun (fdefinition fname))
166 (bpts (gethash fun *trace-breakpoints*)))
167 (when bpts
168 ;; Free breakpoint bookkeeping data.
169 (di:delete-breakpoint (car bpts))
170 (di:delete-breakpoint (cdr bpts))
171 ;; Free TRACE bookkeeping data.
172 (setf (gethash fun *trace-breakpoints*) nil)))))
173 ;;;
174 (push #'clear-trace-breakpoint-record ext:*setf-fdefinition-hook*)
175
176 ;;; TRACE-1 -- Internal.
177 ;;;
178 ;;; This establishes :function-start and :function-end breakpoints with
179 ;;; appropriate hook functions to TRACE function-name as described by the user.
180 ;;;
181 (defun trace-1 (function-or-name condition break break-after where-in print
182 print-after)
183 (let ((fun (if (functionp function-or-name)
184 function-or-name
185 (fdefinition function-or-name))))
186 (cond
187 ((member fun *traced-function-list*)
188 (warn "Function ~S already TRACE'd, ignoring this request."
189 fun))
190 (t
191 (when where-in
192 (dolist (f where-in)
193 (unless (fboundp f)
194 (error "Undefined :where-in name -- ~S." f))))
195 (let* ((debug-fun (di:function-debug-function fun))
196 ;; The start and end hooks use conditionp for communication.
197 (conditionp nil)
198 (start (di:make-breakpoint
199 #'(lambda (frame bpt)
200 (let ((*trace-frame* frame))
201 (cond ((and (or (not condition) ;Save a call to EVAL
202 (eval condition))
203 (or (not where-in)
204 (trace-where-in-p frame where-in)))
205 (setf conditionp t)
206 (print-trace-start frame bpt print))
207 (t (setf conditionp nil)))
208 (when (and break (eval break))
209 (break "Breaking before TRACE'd call to ~S."
210 (di:debug-function-name
211 (di:frame-debug-function frame))))))
212 debug-fun :kind :function-start))
213 (end (di:make-breakpoint
214 #'(lambda (frame bpt values cookie)
215 (if (member fun *traced-function-list*)
216 (let ((*trace-frame* frame))
217 (when conditionp
218 (print-trace-end frame bpt values cookie
219 print-after))
220 (pop *traced-entries*)
221 (when (and break-after (eval break-after))
222 (break "Breaking after TRACE'd call to ~S."
223 (di:debug-function-name
224 (di:frame-debug-function frame)))))
225 (pop *traced-entries*)))
226 debug-fun :kind :function-end
227 :function-end-cookie
228 #'(lambda (frame x)
229 (when (and *traced-entries*
230 (not (di:function-end-cookie-valid-p
231 frame (car *traced-entries*))))
232 (loop
233 (pop *traced-entries*)
234 (when (or (not *traced-entries*)
235 (di:function-end-cookie-valid-p
236 frame (car *traced-entries*)))
237 (return))))
238 (push x *traced-entries*)))))
239 (setf (gethash fun *trace-breakpoints*) (cons start end))
240 ;; The next two forms must be in the order in which they appear. They
241 ;; rely on a documented property that later activated breakpoint hooks
242 ;; run first, and the end breakpoint establishes a starting helper bpt.
243 (di:activate-breakpoint start)
244 (di:activate-breakpoint end))
245 (push fun *traced-function-list*)))))
246
247 ;;; PRINT-TRACE-START -- Internal.
248 ;;;
249 ;;; This prints a representation of the call establishing frame.
250 ;;;
251 (defun print-trace-start (frame bpt &optional print)
252 (declare (ignore bpt))
253 (let ((*print-length* (or *trace-print-length* *print-length*))
254 (*print-level* (or *trace-print-level* *print-level*)))
255 (fresh-line)
256 (print-trace-indentation)
257 (print-frame-call-1 frame nil)
258 (dolist (ele print)
259 (fresh-line)
260 (print-trace-indentation)
261 (prin1 (eval ele)))
262 (terpri)))
263
264 ;;; PRINT-TRACE-END -- Internal.
265 ;;;
266 ;;; This prints a representation of the return values delivered to frame by the
267 ;;; function for which bpt is a :function-end breakpoint. First, this checks
268 ;;; to see that cookie is at the top of *traced-entries*; if it is not, then we
269 ;;; need to adjust this list to determine the correct indentation for output.
270 ;;;
271 (defun print-trace-end (frame bpt values cookie &optional print-after)
272 (declare (ignore frame bpt))
273 (unless (eq cookie (car *traced-entries*))
274 (setf *traced-entries* (member cookie *traced-entries*)))
275 (print-trace-indentation)
276 (write-string "returned ")
277 (dolist (v values)
278 (prin1 v)
279 (write-char #\space))
280 (dolist (ele print-after)
281 (terpri)
282 (print-trace-indentation)
283 (prin1 (eval ele)))
284 (terpri))
285
286 (defun print-trace-indentation ()
287 (let ((len (length (the list *traced-entries*))))
288 (dotimes (i len) (write-string " "))
289 (prin1 len)
290 (write-string ": ")))
291
292 ;;; TRACE-WHERE-IN-P -- Internal.
293 ;;;
294 ;;; The TRACE hooks use this for the :where-in arg.
295 ;;;
296 (defun trace-where-in-p (frame names)
297 (do ((frame (di:frame-down frame) (di:frame-down frame)))
298 ((not frame) nil)
299 (when (member (di:debug-function-name (di:frame-debug-function frame))
300 names :test #'equal)
301 (return t))))
302
303
304
305 ;;;; N-UNTRACE.
306
307 (defmacro untrace (&rest specs)
308 "Removes tracing from the specified functions. With no args, untraces all
309 functions."
310 (let ((specs (or specs *traced-function-list*))
311 (untrace-1-forms nil))
312 (dolist (spec specs `(progn ,@(nreverse untrace-1-forms) t))
313 (let ((fun (typecase spec
314 (symbol (fdefinition spec))
315 (function spec)
316 (list
317 (let ((fun (car spec)))
318 (cond ((eq fun 'quote)
319 (error "Do NOT quote function names."))
320 ((symbolp fun)
321 (fdefinition fun))
322 ((functionp fun)
323 fun)
324 ((not (and (consp fun) (= (length fun) 2)))
325 (error "Illegal function specifier: ~S." fun))
326 ((eq (car fun) 'setf)
327 (fdefinition fun))
328 (t (error "Illegal function specifier: ~S." fun)))))
329 (t (error "Illegal function specifier: ~S." spec)))))
330 (push `(untrace-1 ',fun) untrace-1-forms)))))
331
332 (defun untrace-1 (fun)
333 (cond ((member fun *traced-function-list*)
334 (let ((breakpoints (gethash fun *trace-breakpoints*)))
335 (di:delete-breakpoint (car breakpoints))
336 (di:delete-breakpoint (cdr breakpoints))
337 (setf (gethash fun *trace-breakpoints*) nil))
338 (setf *traced-function-list* (delete fun *traced-function-list*)))
339 (t (warn "Function is not TRACE'd -- ~S." fun))))

  ViewVC Help
Powered by ViewVC 1.1.5