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

Contents of /src/code/ntrace.lisp

Parent Directory Parent Directory | Revision Log Revision Log


Revision 1.6 - (hide annotations)
Tue Mar 10 18:37:08 1992 UTC (22 years, 1 month ago) by wlott
Branch: MAIN
Changes since 1.5: +9 -7 lines
Bind debug:*stack-top-hint* before calling break.
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.6 "$Header: /tiger/var/lib/cvsroots/cmucl/src/code/ntrace.lisp,v 1.6 1992/03/10 18:37:08 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 wlott 1.6 (di:flush-frames-above frame)
210     (let ((*stack-top-hint* frame))
211     (break "Breaking before TRACE'd call to ~S."
212     function-or-name)))))
213 chiles 1.4 debug-fun :kind :function-start))
214     (end (di:make-breakpoint
215     #'(lambda (frame bpt values cookie)
216     (if (member fun *traced-function-list*)
217     (let ((*trace-frame* frame))
218     (when conditionp
219     (print-trace-end frame bpt values cookie
220     print-after))
221     (pop *traced-entries*)
222     (when (and break-after (eval break-after))
223 wlott 1.6 (di:flush-frames-above frame)
224     (let ((*stack-top-hint* frame))
225     (break "Breaking after TRACE'd call to ~S."
226     function-or-name))))
227 chiles 1.4 (pop *traced-entries*)))
228     debug-fun :kind :function-end
229     :function-end-cookie
230     #'(lambda (frame x)
231     (when (and *traced-entries*
232     (not (di:function-end-cookie-valid-p
233     frame (car *traced-entries*))))
234     (loop
235     (pop *traced-entries*)
236     (when (or (not *traced-entries*)
237     (di:function-end-cookie-valid-p
238     frame (car *traced-entries*)))
239     (return))))
240     (push x *traced-entries*)))))
241     (setf (gethash fun *trace-breakpoints*) (cons start end))
242     ;; The next two forms must be in the order in which they appear. They
243     ;; rely on a documented property that later activated breakpoint hooks
244     ;; run first, and the end breakpoint establishes a starting helper bpt.
245     (di:activate-breakpoint start)
246     (di:activate-breakpoint end))
247     (push fun *traced-function-list*)))))
248 chiles 1.1
249     ;;; PRINT-TRACE-START -- Internal.
250     ;;;
251     ;;; This prints a representation of the call establishing frame.
252     ;;;
253 chiles 1.2 (defun print-trace-start (frame bpt &optional print)
254 chiles 1.1 (declare (ignore bpt))
255 chiles 1.2 (let ((*print-length* (or *trace-print-length* *print-length*))
256     (*print-level* (or *trace-print-level* *print-level*)))
257 chiles 1.1 (fresh-line)
258     (print-trace-indentation)
259     (print-frame-call-1 frame nil)
260 chiles 1.2 (dolist (ele print)
261     (fresh-line)
262     (print-trace-indentation)
263     (prin1 (eval ele)))
264 chiles 1.1 (terpri)))
265    
266     ;;; PRINT-TRACE-END -- Internal.
267     ;;;
268     ;;; This prints a representation of the return values delivered to frame by the
269     ;;; function for which bpt is a :function-end breakpoint. First, this checks
270     ;;; to see that cookie is at the top of *traced-entries*; if it is not, then we
271     ;;; need to adjust this list to determine the correct indentation for output.
272     ;;;
273 chiles 1.2 (defun print-trace-end (frame bpt values cookie &optional print-after)
274 chiles 1.1 (declare (ignore frame bpt))
275     (unless (eq cookie (car *traced-entries*))
276 wlott 1.5 (setf *traced-entries* (member cookie *traced-entries*)))
277 chiles 1.1 (print-trace-indentation)
278     (write-string "returned ")
279     (dolist (v values)
280     (prin1 v)
281     (write-char #\space))
282 chiles 1.2 (dolist (ele print-after)
283     (terpri)
284     (print-trace-indentation)
285     (prin1 (eval ele)))
286 chiles 1.1 (terpri))
287    
288     (defun print-trace-indentation ()
289     (let ((len (length (the list *traced-entries*))))
290     (dotimes (i len) (write-string " "))
291     (prin1 len)
292     (write-string ": ")))
293    
294 chiles 1.2 ;;; TRACE-WHERE-IN-P -- Internal.
295     ;;;
296     ;;; The TRACE hooks use this for the :where-in arg.
297     ;;;
298     (defun trace-where-in-p (frame names)
299     (do ((frame (di:frame-down frame) (di:frame-down frame)))
300     ((not frame) nil)
301     (when (member (di:debug-function-name (di:frame-debug-function frame))
302     names :test #'equal)
303     (return t))))
304 chiles 1.1
305 chiles 1.2
306 chiles 1.1
307     ;;;; N-UNTRACE.
308    
309 chiles 1.4 (defmacro untrace (&rest specs)
310     "Removes tracing from the specified functions. With no args, untraces all
311 chiles 1.1 functions."
312 chiles 1.4 (let ((specs (or specs *traced-function-list*))
313 chiles 1.1 (untrace-1-forms nil))
314 chiles 1.4 (dolist (spec specs `(progn ,@(nreverse untrace-1-forms) t))
315     (let ((fun (typecase spec
316     (symbol (fdefinition spec))
317     (function spec)
318     (list
319     (let ((fun (car spec)))
320     (cond ((eq fun 'quote)
321     (error "Do NOT quote function names."))
322     ((symbolp fun)
323     (fdefinition fun))
324     ((functionp fun)
325     fun)
326     ((not (and (consp fun) (= (length fun) 2)))
327     (error "Illegal function specifier: ~S." fun))
328     ((eq (car fun) 'setf)
329     (fdefinition fun))
330     (t (error "Illegal function specifier: ~S." fun)))))
331     (t (error "Illegal function specifier: ~S." spec)))))
332     (push `(untrace-1 ',fun) untrace-1-forms)))))
333 chiles 1.1
334 chiles 1.4 (defun untrace-1 (fun)
335     (cond ((member fun *traced-function-list*)
336     (let ((breakpoints (gethash fun *trace-breakpoints*)))
337 chiles 1.1 (di:delete-breakpoint (car breakpoints))
338     (di:delete-breakpoint (cdr breakpoints))
339 chiles 1.4 (setf (gethash fun *trace-breakpoints*) nil))
340     (setf *traced-function-list* (delete fun *traced-function-list*)))
341     (t (warn "Function is not TRACE'd -- ~S." fun))))

  ViewVC Help
Powered by ViewVC 1.1.5