-
Notifications
You must be signed in to change notification settings - Fork 2
/
Copy pathctrace.lisp
334 lines (266 loc) · 11.4 KB
/
ctrace.lisp
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
256
257
258
259
260
261
262
263
264
265
266
267
268
269
270
271
272
273
274
275
276
277
278
279
280
281
282
283
284
285
286
287
288
289
290
291
292
293
294
295
296
297
298
299
300
301
302
303
304
305
306
307
308
309
310
311
312
313
314
315
316
317
318
319
320
321
322
323
324
325
326
327
328
329
330
331
332
333
334
(in-package :mt)
#| ######################################################################
CTRACE - internal tracing facility
Copyright (c) 1994-97 Michael Travers
Permission is given to use and modify this code
as long as the copyright notice is preserved.
Send questions, comments, and fixes to [email protected].
-------------------------------------------------------------------------
An advanced tracing facility.
The standard trace package does not work well in situations where I/O is being
done, such as event handlers. This package performs tracing by creating a list
structure to record function entrances and exits. This structure can be displayed
or processed after the fact. The package also includes the concept of a tracing
level, so that varying amount of detail can be recorded.
Todo:
- handle multiple processes (use let-globally, record *current-process*)
- include options for live (printing) tracing as well as structure building
- perhaps use objects rather than lists for recording structure
Quick start:
(ctrace-function 'my-function1)
(ctrace-function 'my-function2) etc.
(ct (my-computation))
will run (my-computation) tracing calls to my-function1 and 2, and displays
the resulting trace in a Fred window.
Documentation:
(CTRACE item &optional level)
Record item if trace level is >= to level. CTRACE is used for putting trace
points in code.
(WITH-CTRACE (item &optional level) . body)
Record an item as in CTRACE, and all traces that occur in body will be
recorded as subitems.
(CTRACE-FUNCTION function-name &optional level)
Advises the function so that it has a WITH-CTRACE wrapped around it.
(UNCTRACE-FUNCTION &optional function-name)
Remove the WITH-CTRACE wrapper from a function (or all such functions if none is specified)
(CTRACE-ALL &optional (package *package*))
ctrace all functions in the given package
(WITH-CTRACING (&optional name level) . body)
Enables ctracing around the execution of body, and returns the the trace
(START-CTRACE &optional name level)
Enable ctracing globally
(STOP-CTRACE)
DIsable global ctracing, and returns the accumulated trace structure.
(VIEW-CTRACE &optional trace)
View a trace in its own window, pretty-printed.
(CT &body body)
Equivalent to (view-ctrace (with-ctracing () <body>)).
Todo:
separate out MCL dependent parts. Can I replace advise with pure CL?
History:
Ancestry: Henry Lieberman's ZStep, my own PSTEP/PTRACE.
6/25/95 13:08 packaged as separate facility.
6/26/95 17:50 made level arguments optional, flushed name args, improved UNCTRACE-FUNCTION
7/10/95 23:01 fix view-ctrace to invalidate view. Clean up examples.
Make trace headers (:local-ctrace, etc) into lists to make the thing easier to parse)
Interface to Lynch's twist-down for viewing (very preliminary)
10/13/95 18:23: add CTRACE-ALL. Too slow though, because ADVISE is slow
10/15/95 16:52 add *last-ctrace*, cleaned up function messages
12/10/95 22:51 with-ctracing was setting rather than binding *ctrace-top*
added error handling
added ct for convenience
12/20/95 1:21 add fboundp check and error message to ctrace-function
1/6/96 18:13 small improvements to twist-down hack
1/8/96 17:37 updated documentation and code formatting
1/14/96 19:15 added ctt, use geneva for trace-window
3/29/96 17:14 play safe, copy all list structure before recording it.
no, that's too much gunk, just do it for ctrace-function, in other cases
make callers handle it
11/23/96 13:13 ADVISE internals are different in 3.1/4.0
1/12/97 17:47 fix copy-list-recursive to deal with dotted-pair arguments
3/18/97 12:36 add without-interrupts to deal with multiple processes somewhat better
8/07/01 10:09 Make it run under ACL
11/09/07 Run under ABCL (NOT WORKING)
###################################################################### |#
;;; Bureaucracy
(eval-when (:compile-toplevel :load-toplevel :execute)
#+:ALLEGRO (pushnew :ACL *features*))
; ABCL relies on this encapsulate package, snarfed from OpenMCL.
;#+:ABCL
;(load "/misc/sourceforge/lsw/trunk/util/encapsulate.lisp")
;;; CTRACE
(defvar *ctrace-level* 0)
(defvar *ctrace-current-item* nil)
(defvar *ctrace-top*)
(defvar *last-ctrace*)
(defun copy-list-recursive (item)
(if (consp item)
(cons (copy-list-recursive (car item))
(copy-list-recursive (cdr item)))
item))
(defun ctrace-item-out (item)
(let ((newbie (list item)))
(when (cdr (last *ctrace-current-item*)) (error "foo?")) ; make sure we aren't clobbering anything
(rplacd (last *ctrace-current-item*) newbie)
(setf *ctrace-current-item* newbie)))
; make a ctrace entry. this is a macro so that the computation of the item
; can be done lazily.
(defmacro ctrace (item &optional (level 1))
`(when (<= ,level *ctrace-level*)
(ctrace-item-out ,item)
nil))
; make an entry that includes all activity inside dynamic context
(defmacro with-ctrace ((item &optional (level 1)) &body body)
`(let ((*ctrace-current-item*
(if (<= ,level *ctrace-level*)
(car (ctrace-item-out (list ,item)))
*ctrace-current-item*)))
,@body))
(defvar *ctraced-functions* nil)
;;; put a ctrace around an existing function
(defun ctrace-function (function-name &optional (level 1))
(assert (fboundp function-name) ()
"No definition for ~A" function-name)
(pushnew function-name *ctraced-functions*)
#+:CCL ;Written for ancient CCL, not clear if it still works
(let ((newsym (gensym "CTRACE")))
(ccl::advise-2
(eval (ccl::advise-global-def
function-name newsym :around
`(with-ctrace (`(calling (,',function-name ,@(copy-list-recursive arglist))) ,level)
(let ((result (:do-it)))
(ctrace `(,',function-name returned ,(copy-list-recursive result)) ,level)
result))))
newsym nil function-name :around 'ctrace nil))
#+:ACL
(excl:advise-1 function-name :around :ctrace 1
`((with-ctrace (`(calling (,',function-name ,@(copy-list-recursive arglist))) ,level)
(let ((result :do-it))
(ctrace `(,',function-name returned ,(copy-list-recursive result)) ,level)
result))))
;; not working yet. encapsulate:advise doesn't eval its args, so this wont work
;; wait, it's from LSW and OpenMCL...still doesn't work though (? say what?)
#+:ABCL
(let ((newsym (gensym "CTRACE")))
(encapsulate::advise-2
(encapsulate::advise-global-def
function-name newsym :around
`(with-ctrace (`(calling (,',function-name ,@(copy-list-recursive encapsulate::arglist))) ,level)
(let ((result (:do-it)))
(ctrace `(,',function-name returned ,(copy-list-recursive result)) ,level)
result)))
newsym nil function-name :around 'ctrace nil))
#-(OR :ACL :CCL :ABCL)
(error "i don't know how to advise functions in this lisp")
)
(defun unctrace-function (&optional function-name)
(if function-name
(unctrace-function-1 function-name)
(dolist (fn *ctraced-functions* ())
(unctrace-function-1 fn))))
(defun unctrace-function-1 (function-name)
(unctrace-function-2 function-name)
(deletef function-name *ctraced-functions*))
#+:CCL
(defun unctrace-function-2 (function-name)
(ccl::%unadvise-1 function-name :around 'ctrace))
#+:ACL
(defun unctrace-function-2 (function-name)
(excl:unadvise-1 function-name :around :ctrace))
#+:ABCL
;;; ??? who knows if this is right
(defun unctrace-function-2 (function-name)
(encapsulate::unadvise-1 function-name))
(defun ctrace-all (&optional (package *package*))
(let ((package (if (symbolp package)
(find-package package)
package)))
(do-symbols (symbol package)
(when (and (eq (symbol-package symbol) package)
(fboundp symbol)
(not (macro-function symbol)))
(ctrace-function symbol)))))
; top-level form to enable ctracing
(defmacro with-ctracing ((&optional (level 1)) &body body)
`(let ((*ctrace-level* ,level)
(*ctrace-top* (setf *ctrace-current-item* (list '(:local-ctrace)))))
(catch :ctrace-err
(handler-bind
((error #'(lambda (condition)
(ctrace `(error ,(with-output-to-string (stream)
#+:CCL (ccl::report-condition condition stream)
#-:CCL (print condition stream); +++
)))
(throw :ctrace-err *ctrace-top*))))
,@body))
(setf *last-ctrace* *ctrace-top*)))
;;; for maximal convenience
(defmacro ct (&body body)
`(view-ctrace
(with-ctracing ()
,@body)))
;;; enable ctracing in global context
(defun start-ctrace (&optional (level 1))
(setf *ctrace-level* level)
(setf *ctrace-top* (setf *ctrace-current-item* (list '(:global-ctrace)))))
(defun stop-ctrace ()
(setf *ctrace-level* 0)
(prog1 (setf *last-ctrace* *ctrace-top*)
(setf *ctrace-top* nil)))
; view the trace in an editor window
;;; mostly so they can all be flushed easily
(defclass trace-window (fred-window) ()
(:default-initargs :scratch-p t))
(defun view-ctrace (&optional (trace *ctrace-top*))
(pprint trace))
;;; the default method computes width based on the maximum width of chars. If you
;;; use Geneva, it actually fits LESS chars into a line. This is a crock to compensate.
(defmethod stream-line-length ((w trace-window))
(* 2 (call-next-method)))
#|
;;; Interface to twist-down
;;; very preliminary
;;; I wish opening was smoother (it redraws entiree bottom part of screen).
(load "others;lynch lib:ll-init")
; oodles-of-utils must have alias in CCL folder
(require :twist-down)
(defun string-truncate (string length)
(if (> (length string) length)
(subseq string 0 length)
string))
(defclass ctrace-twist-dialog (dialog) ())
(defmethod set-view-size :after ((view ctrace-twist-dialog) h &optional v)
(set-view-size (elt (view-subviews view) 0) (subtract-points (view-size view) #@(22 22))))
(defun view-ctrace-twist (ctrace)
(let ((w (make-instance 'ctrace-twist-dialog
:view-size #@(422 422)
:grow-icon-p t)))
(add-subviews w
(make-instance 'cl-user::twist-down
:view-nick-name 'ctrace
:view-font '("Geneva" 9 :plain)
:view-size #@(400 400)
:root ctrace
:node-string-function #'(lambda (node)
(string-truncate
(princ-to-string
(if (listp (first node))
(first node)
node))
255))
:children-function #'(lambda (node)
(if (listp (first node))
(rest node)
nil))))
w))
(defmacro ctt (&body body)
`(view-ctrace-twist
(with-ctracing ()
,@body)))
|#
#|
Examples:
(defun fact (n)
(declare (notinline fact)) ; necessary to trace recursive functions
(if (zerop n) 1 (* n (fact (1- n)))))
(ctrace-function 'fact)
(ct (fact 6))
;;; alternatively
(unctrace-function 'fact)
(defun fact (n)
(with-ctrace (`(calling (fact ,n)))
(let ((value (if (zerop n) 1 (* n (fact (1- n))))))
(ctrace `(returned ,value))
value)))
(ct (fact 6))
|#