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

Contents of /src/code/ntrace.lisp

Parent Directory Parent Directory | Revision Log Revision Log


Revision 1.5 - (hide 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 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     ;;; 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 wlott 1.5 "$Header: /tiger/var/lib/cvsroots/cmucl/src/code/ntrace.lisp,v 1.5 1992/03/10 15:55:28 wlott Exp $")
11 chiles 1.1 ;;;
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 chiles 1.2 (in-package "LISP")
24    
25     (export '(trace untrace))
26    
27    
28 chiles 1.1 (in-package "DEBUG")
29    
30 chiles 1.2 (export '(*trace-print-level* *trace-print-length* *traced-function-list*
31     *trace-frame* *max-trace-indentation*))
32 chiles 1.1
33 chiles 1.2 (defvar *traced-function-list* nil
34 chiles 1.4 "A list of functions which are traced.")
35 chiles 1.1
36 chiles 1.2 (defvar *trace-print-length* nil
37     "Tracing output occurs with *print-length* bound to this value.")
38 chiles 1.1
39 chiles 1.2 (defvar *trace-print-level* nil
40     "Tracing output occurs with *print-level* bound to this value.")
41 chiles 1.1
42 chiles 1.2 (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 chiles 1.1
46 chiles 1.2 (defvar *max-trace-indentation* nil
47     "This is currently unused.")
48    
49 chiles 1.1
50 chiles 1.2 ;;; TRACE -- Public.
51 chiles 1.1 ;;;
52 chiles 1.2 (defmacro trace (&rest specs)
53 chiles 1.4 "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 chiles 1.1 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 chiles 1.2 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 chiles 1.1 (cond
86 chiles 1.2 ((not specs) '*traced-function-list*)
87 chiles 1.1 (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 chiles 1.4 ((or symbol function)
99 chiles 1.1 (values spec nil))
100     (list
101 chiles 1.2 (let ((fun (car spec)))
102     (cond ((eq fun 'quote)
103     (error "Do NOT quote function names."))
104 chiles 1.4 ((or (symbolp fun) (functionp fun))
105 chiles 1.2 (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 chiles 1.1 (t (error "Illegal trace spec: ~S." spec)))
112     (push name name-list)
113 ram 1.3 (destructuring-bind (&key condition break break-after break-all
114     wherein print print-after print-all)
115     options
116 chiles 1.1 (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 chiles 1.2 (unless (or (symbolp fun)
127     (and (consp fun)
128     (= (length fun) 2)
129     (eq (car fun) 'setf)))
130 chiles 1.1 (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 chiles 1.2 (push `(trace-1 ',name ',condition ',break ',break-after
139 chiles 1.1 ',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 chiles 1.4 ;;; This maps functions to the two breakpoints created in TRACE-1, so we can
158     ;;; get rid of them in UNTRACE-1.
159 chiles 1.1 ;;;
160     (defvar *trace-breakpoints* (make-hash-table :test #'eq))
161 chiles 1.2 ;;;
162     (defun clear-trace-breakpoint-record (fname new-value)
163     (declare (ignore new-value))
164 chiles 1.4 (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 chiles 1.2 ;;;
174     (push #'clear-trace-breakpoint-record ext:*setf-fdefinition-hook*)
175 chiles 1.1
176 chiles 1.2 ;;; TRACE-1 -- Internal.
177 chiles 1.1 ;;;
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 chiles 1.4 (defun trace-1 (function-or-name condition break break-after where-in print
182 chiles 1.1 print-after)
183 chiles 1.4 (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 chiles 1.1
247     ;;; PRINT-TRACE-START -- Internal.
248     ;;;
249     ;;; This prints a representation of the call establishing frame.
250     ;;;
251 chiles 1.2 (defun print-trace-start (frame bpt &optional print)
252 chiles 1.1 (declare (ignore bpt))
253 chiles 1.2 (let ((*print-length* (or *trace-print-length* *print-length*))
254     (*print-level* (or *trace-print-level* *print-level*)))
255 chiles 1.1 (fresh-line)
256     (print-trace-indentation)
257     (print-frame-call-1 frame nil)
258 chiles 1.2 (dolist (ele print)
259     (fresh-line)
260     (print-trace-indentation)
261     (prin1 (eval ele)))
262 chiles 1.1 (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 chiles 1.2 (defun print-trace-end (frame bpt values cookie &optional print-after)
272 chiles 1.1 (declare (ignore frame bpt))
273     (unless (eq cookie (car *traced-entries*))
274 wlott 1.5 (setf *traced-entries* (member cookie *traced-entries*)))
275 chiles 1.1 (print-trace-indentation)
276     (write-string "returned ")
277     (dolist (v values)
278     (prin1 v)
279     (write-char #\space))
280 chiles 1.2 (dolist (ele print-after)
281     (terpri)
282     (print-trace-indentation)
283     (prin1 (eval ele)))
284 chiles 1.1 (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 chiles 1.2 ;;; 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 chiles 1.1
303 chiles 1.2
304 chiles 1.1
305     ;;;; N-UNTRACE.
306    
307 chiles 1.4 (defmacro untrace (&rest specs)
308     "Removes tracing from the specified functions. With no args, untraces all
309 chiles 1.1 functions."
310 chiles 1.4 (let ((specs (or specs *traced-function-list*))
311 chiles 1.1 (untrace-1-forms nil))
312 chiles 1.4 (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 chiles 1.1
332 chiles 1.4 (defun untrace-1 (fun)
333     (cond ((member fun *traced-function-list*)
334     (let ((breakpoints (gethash fun *trace-breakpoints*)))
335 chiles 1.1 (di:delete-breakpoint (car breakpoints))
336     (di:delete-breakpoint (cdr breakpoints))
337 chiles 1.4 (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