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

Contents of /src/code/ntrace.lisp

Parent Directory Parent Directory | Revision Log Revision Log


Revision 1.1 - (show annotations)
Sun Oct 13 14:29:30 1991 UTC (22 years, 6 months ago) by chiles
Branch: MAIN
Initial revision
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.1 1991/10/13 14:29:30 chiles 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 "DEBUG")
24
25 ;;; BECAUSE SOMEONE SLOPPILY MADE THE "DEBUG" PACKAGE USE "EXT", I HAVE TO BEND
26 ;;; OVER BACKWARDS NOW TO PREVENT STEPPING ON STUFF EXPORTED BY THE OLD TRACE
27 ;;; CODE FROM "EXT". THAT'S WHY THERE ARE ALL THE FUNNY NAMES. NO, I DON'T
28 ;;; FEEL LIKE CLEANING UP THE "DEBUG" PACKAGE ONCE AGAIN.
29 ;;;
30
31 (export '(*n-trace-print-level* *n-trace-print-length* *n-traced-function-list*
32 n-trace n-untrace))
33
34 (defvar *n-traced-function-list* ()
35 "A list of function names which are traced.")
36
37 (defvar *n-trace-print-length* ()
38 "*Print-length* will be bound to this value when trace is printing.")
39
40 (defvar *n-trace-print-level* ()
41 "*Print-level* will be bound to this value when trace is printing.")
42
43
44
45 ;;;; TRACE.
46
47 ;;; WITH-KEYWORDS -- Internal.
48 ;;;
49 ;;; This takes an options list of the following form:
50 ;;; (<option-name> <value> ...)
51 ;;; It also takes a keyword binding spec of the following form:
52 ;;; ((<keyword> <binding-var> <default>)
53 ;;; ...)
54 ;;; This returns a form that binds the variables to any provided value in
55 ;;; options-list or to the default.
56 ;;;
57 (defmacro with-keywords (option-list key-list &rest body)
58 `(let ,(mapcar #'(lambda (kl)
59 `(,(cadr kl) ;var
60 (or (getf ,option-list ,(car kl))
61 ,(caddr kl)))) ;default
62 key-list)
63 ,@body))
64
65 ;;; N-TRACE -- Public.
66 ;;;
67 (defmacro n-trace (&rest specs)
68 "Establishes tracing for specified functions and pushes their names on
69 *n-traced-function-list*. Each specification is either the name of a function
70 or a list of the form:
71 (function-name <trace-option> <value> <trace-option> <value> ...)
72 If you supply no specifications, TRACE returns the list of traced functions.
73 The following options are valid:
74 :condition
75 A form to EVAL to determine whether TRACE should display anything.
76 :break
77 A form to EVAL to determine whether to call BREAK before the call.
78 :break-after
79 Like :break, but takes effect after the call.
80 :break-all
81 Like :break, but takes effect before and after call.
82 :wherein
83 A function name or list of names in which TRACE will display a call.
84 :print
85 A list of forms for EVAL whose results TRACE will display in addition
86 to other information before the call.
87 :print-after
88 Like :print, but takes effect after the call.
89 :print-all
90 Like :print, but takes effect before and after the call."
91 (cond
92 ((not specs) '*n-traced-function-list*)
93 (t
94 (let ((name-list nil)
95 (trace-1-forms nil))
96 (dolist (spec specs `(progn
97 ;; Make sure every name has a definition.
98 ,@(mapcar #'(lambda (x) `#',x) name-list)
99 ,@trace-1-forms
100 ',(nreverse name-list)))
101 (multiple-value-bind
102 (name options)
103 (typecase spec
104 (symbol
105 (values spec nil))
106 (list
107 (unless (symbolp (car spec))
108 (error "Illegal function name: ~S." (car spec)))
109 (when (eq (car spec) 'quote)
110 (error "I bet you don't want to trace QUOTE."))
111 (values (car spec) (cdr spec)))
112 (t (error "Illegal trace spec: ~S." spec)))
113 (push name name-list)
114 (with-keywords options
115 ((:condition condition nil)
116 (:break break nil)
117 (:break-after break-after nil)
118 (:break-all break-all nil)
119 (:wherein wherein nil)
120 (:print print nil)
121 (:print-after print-after nil)
122 (:print-all print-all nil))
123 (when break-all
124 (setf break (setf break-after break-all)))
125 (when print-all
126 (setf print (setf print-after print-all)))
127 ;; Wherein must be a list of symbols or nil.
128 (setf wherein
129 (typecase wherein
130 (null nil)
131 (symbol (list wherein))
132 (list (dolist (fun wherein wherein)
133 (unless (symbolp fun)
134 (error "Illegal function name, ~S, in :wherein."
135 fun))))
136 (t (error "Illegal :wherein option: ~S." wherein))))
137 ;; Print and print-after must be lists.
138 (unless (listp print)
139 (error "Illegal form list, ~S, for :print." print))
140 (unless (listp print-after)
141 (error "Illegal form list, ~S, for :print-after." print-after))
142 (push `(n-trace-1 ',name ',condition ',break ',break-after
143 ',wherein ',print ',print-after)
144 trace-1-forms))))))))
145
146 ;;; This is a list of function-end-cookies, which we use to note distinct
147 ;;; dynamic entries into functions.
148 ;;;
149 ;;; The length of this list tells us the indentation to use for printing TRACE
150 ;;; messages.
151 ;;;
152 ;;; This list also helps us synchronize the TRACE facility dynamically for
153 ;;; detecting non-local flow of control that affects TRACE'ing. Whenever
154 ;;; execution hits a :function-end breakpoint used for TRACE'ing, we look for
155 ;;; the function-end-cookie at the top of *traced-entries*. If it is not
156 ;;; there, we can adjust our indentation and the contents of the list
157 ;;; accordingly, printing a warning that some TRACE'd entries have been fouled.
158 ;;;
159 (defvar *traced-entries* nil)
160
161 ;;; This maps function names to the two breakpoints created in TRACE-1, so we
162 ;;; can get rid of them in UNTRACE-1.
163 ;;;
164 (defvar *trace-breakpoints* (make-hash-table :test #'eq))
165
166 ;;; N-TRACE-1 -- Internal.
167 ;;;
168 ;;; This establishes :function-start and :function-end breakpoints with
169 ;;; appropriate hook functions to TRACE function-name as described by the user.
170 ;;;
171 (defun n-trace-1 (function-name condition break break-after wherein print
172 print-after)
173 (declare (ignore condition break break-after wherein print print-after))
174 (cond
175 ((member function-name *n-traced-function-list*)
176 (warn "Function ~S already TRACE'd, ignoring this request."
177 function-name))
178 (t
179 (let* ((debug-fun (di:function-debug-function (fdefinition function-name)))
180 (start (di:make-breakpoint #'print-trace-start
181 debug-fun
182 :kind :function-start))
183 (end (di:make-breakpoint #'print-trace-end
184 debug-fun
185 :kind :function-end
186 :function-end-cookie
187 #'(lambda (x) (push x *traced-entries*)))))
188 (setf (gethash function-name *trace-breakpoints*) (cons start end))
189 ;; This works TOTALLY SLIMY by the order of the next two calls.
190 (di:activate-breakpoint start)
191 (di:activate-breakpoint end))
192 (push function-name *n-traced-function-list*))))
193
194 ;;; PRINT-TRACE-START -- Internal.
195 ;;;
196 ;;; This prints a representation of the call establishing frame.
197 ;;;
198 (defun print-trace-start (frame bpt)
199 (declare (ignore bpt))
200 (let ((*print-length* (or *n-trace-print-length* *print-length*))
201 (*print-level* (or *n-trace-print-level* *print-level*)))
202 (fresh-line)
203 (print-trace-indentation)
204 (print-frame-call-1 frame nil)
205 (terpri)))
206
207 ;;; PRINT-TRACE-END -- Internal.
208 ;;;
209 ;;; This prints a representation of the return values delivered to frame by the
210 ;;; function for which bpt is a :function-end breakpoint. First, this checks
211 ;;; to see that cookie is at the top of *traced-entries*; if it is not, then we
212 ;;; need to adjust this list to determine the correct indentation for output.
213 ;;;
214 (defun print-trace-end (frame bpt values cookie)
215 (declare (ignore frame bpt))
216 (unless (eq cookie (car *traced-entries*))
217 (setf *traced-entries* (member cookie *traced-entries*))
218 (fresh-line)
219 (write-line "WARNING: dynamic flow of control occurred while TRACE'ing."))
220 (print-trace-indentation)
221 (pop *traced-entries*)
222 (write-string "returned ")
223 (dolist (v values)
224 (prin1 v)
225 (write-char #\space))
226 (terpri))
227
228 (defun print-trace-indentation ()
229 (let ((len (length (the list *traced-entries*))))
230 (dotimes (i len) (write-string " "))
231 (prin1 len)
232 (write-string ": ")))
233
234
235
236 ;;;; N-UNTRACE.
237
238 (defmacro n-untrace (&rest names)
239 "Removes tracing from the functions named. With no args, untraces all
240 functions."
241 (let ((names (or names *n-traced-function-list*))
242 (untrace-1-forms nil))
243 (dolist (name names `(progn ,@(nreverse untrace-1-forms) t))
244 (if (symbolp name)
245 (push `(n-untrace-1 ',name) untrace-1-forms)
246 (error "Illegal function name -- ~S." name)))))
247
248 (defun n-untrace-1 (name)
249 (cond ((member name *n-traced-function-list*)
250 (let ((breakpoints (gethash name *trace-breakpoints*)))
251 (di:delete-breakpoint (car breakpoints))
252 (di:delete-breakpoint (cdr breakpoints))
253 (setf (gethash name *trace-breakpoints*) nil))
254 (setf *n-traced-function-list* (delete name *n-traced-function-list*)))
255 (t (warn "Function is not TRACE'd -- ~S." name))))

  ViewVC Help
Powered by ViewVC 1.1.5