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