[e90b2f]: src / lsp / trace.lsp Maximize Restore History

Download this file

trace.lsp    329 lines (298 with data), 11.4 kB

  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
;;;; -*- Mode: Lisp; Syntax: Common-Lisp; Package: SYSTEM -*-
;;;;
;;;; Copyright (c) 1990, Giuseppe Attardi.
;;;; Copyright (c) 2001, Juan Jose Garcia Ripoll.
;;;;
;;;; This program is free software; you can redistribute it and/or
;;;; modify it under the terms of the GNU Library General Public
;;;; License as published by the Free Software Foundation; either
;;;; version 2 of the License, or (at your option) any later version.
;;;;
;;;; See file '../Copyright' for full details.
;;;; Tracer package for Common Lisp
(in-package "SYSTEM")
(defparameter *trace-level* 0)
;; (defparameter *trace-list* nil) ; In all_symbols.d !
(defparameter *trace-max-indent* 20)
(defmacro trace (&rest r)
"Syntax: (trace ({function-name | ({function-name}+)} {keyword [form]\}*)
Begins tracing the specified functions. With no FUNCTION-NAMEs, returns a
list of functions currently being traced. The printed information consists of
the name of function followed at entry by its arguments and on exit by its
return values.
The keywords allow to control when and how tracing is performed.
The possible keywords are:
:BREAK a breakpoint is entered after printing the entry trace
information, but before applying the traced function to its
arguments, if form evaluates to non-nil
:BREAK-AFTER like :BREAK but the breakpoint is entered after the function
has been executed and the exit trace information has been
printed and before control returns
:COND-BEFORE information is printed upon entry if form evaluates to non-nil
:COND-AFTER information is printed upon exit if form evaluates to non-nil
:COND specifies a single condition for both entry and exit
:PRINT prints the values of the forms in the list upon entry.
They are preceeded by a backslash (\\)
:PRINT-AFTER prints the values of the forms in the list upon exit from the
function. They are preceeded by a backslash (\\)
:STEP turns on the stepping facility
Forms can refer to the list of arguments of the function through the variable
SI::ARGS."
`(trace* ',r))
(defun trace* (r)
(if (null r)
(mapcar #'first *trace-list*)
(mapc #'trace-one r)))
(defmacro untrace (&rest r)
"Syntax: (untrace {function-name}*)
Ends tracing the specified functions. With no FUNCTION-NAMEs, ends tracing
all functions."
`(untrace* ',r))
(defun untrace* (r)
(mapc #'untrace-one (or r (trace* nil))))
(defparameter *inside-trace* nil)
(defun trace-one (spec)
(let* (break exitbreak (entrycond t) (exitcond t) entry exit
step (barfp t) fname oldf)
(cond ((si::valid-function-name-p spec)
(setq fname spec))
((si::proper-list-p spec)
(error "Not a valid argument to TRACE: ~S" spec))
((si::valid-function-name-p (first spec))
(setq fname (first spec))
(do ((specs (cdr spec) (cdr specs)))
((null specs))
(case (car specs)
(:break (setq barfp specs specs (cdr specs) break (car specs)))
(:break-after (setq barfp specs specs (cdr specs) exitbreak (car specs)))
(:step (setq step t))
(:cond (setq barfp specs specs (cdr specs))
(setq exitcond (setq entrycond (car specs))))
(:cond-before (setq barfp specs specs (cdr specs) entrycond (car specs)))
(:cond-after (setq barfp specs specs (cdr specs) exitcond (car specs)))
(:print (setq barfp specs specs (cdr specs) entry (car specs)))
(:print-after (setq barfp specs specs (cdr specs) exit (car specs)))
(t (error "Meaningless TRACE keyword: ~S" (car specs))))
(unless barfp (error "Parameter missing"))))
((si::proper-list-p (first spec))
(let (results)
(dolist (fname (first spec))
(push (trace-one (list* fname (rest spec))) results))
(return-from trace-one (nreverse results))))
(t
(error "Not a valid argument to TRACE: ~S" spec)))
(when (null (fboundp fname))
(warn "The function ~S is not defined." fname)
(return-from trace-one nil))
(when (symbolp fname)
(when (special-operator-p fname)
(warn "Unable to trace special form ~S." fname)
(return-from trace-one nil))
(when (macro-function fname)
(warn "Unable to trace macro ~S." fname)
(return-from trace-one nil)))
(let ((record (trace-record fname)))
(when record
(cond ((traced-and-redefined-p record)
(delete-from-trace-list fname))
(t
(warn "The function ~S is already traced." fname)
(return-from trace-one nil)))))
(setq oldf (fdefinition fname))
(eval
`(defun ,fname (&rest args)
(let* (values (*trace-level* (1+ *trace-level*)))
(if *inside-trace*
(setq values (multiple-value-list (apply ',oldf args)))
(let ((*inside-trace* t))
,@(when entrycond
(if (eq t entrycond)
`((trace-print 'ENTER ',fname args ,@entry))
`((when ,entrycond
(trace-print 'ENTER ',fname args ,@entry)))))
,@(when break
`((when ,break (let (*inside-trace*)
(break "tracing ~S" ',fname)))))
(setq values
(let (*inside-trace*)
(multiple-value-list
(apply ',oldf args)
#+nil
,(if step
`(let (*step-quit*)
(applyhook ',oldf args #'stepper nil))
`(apply ',oldf args)))))
,@(when exitcond
(if (eq t exitcond)
`((trace-print 'EXIT ',fname values ,@exit))
`((when ,exitcond
(trace-print 'EXIT ',fname values ,@exit)))))
,@(when exitbreak
`((when ,exitbreak
(let (*inside-trace*)
(break "after tracing ~S" ',fname)))))))
(values-list values))))
(add-to-trace-list fname oldf)
(list fname)))
(defun trace-print (direction fname vals &rest extras)
(let ((indent (min (* (1- *trace-level*) 2) *trace-max-indent*))
(*print-circle* t))
(fresh-line *trace-output*)
(case direction
(ENTER
(multiple-value-bind (bars rem)
(floor indent 4)
(dotimes (i bars) (princ (if (< i 10) "| " "| ") *trace-output*))
(when (plusp rem) (format *trace-output* "~V,,,' A" rem "|")))
(format *trace-output*
"~D> (~S~{ ~S~})~%"
*trace-level* fname vals))
(EXIT
(multiple-value-bind (bars rem)
(floor indent 4)
(dotimes (i bars) (princ "| " *trace-output*))
(when (plusp rem) (format *trace-output* "~V,,,' A" rem "|")))
(format *trace-output*
"<~D (~S~{ ~S~})~%"
*trace-level*
fname vals)
))
(when extras
(multiple-value-bind (bars rem)
(floor indent 4)
(dotimes (i bars) (princ "| " *trace-output*))
(when (plusp rem) (format *trace-output* "~V,,,' A" rem "|")))
(format *trace-output*
"~0,4@T\\\\ ~{ ~S~}~%"
extras))))
(defun trace-record (fname)
(declare (si::c-local))
(find fname *trace-list* :key #'first :test #'equal))
(defun trace-record-name (record)
(declare (si::c-local))
(first record))
(defun trace-record-definition (record)
(declare (si::c-local))
(second record))
(defun trace-record-old-definition (record)
(declare (si::c-local))
(third record))
(defun traced-old-definition (fname)
(let ((record (trace-record fname)))
(when record
(unless (traced-and-redefined-p record)
(trace-record-old-definition record)))))
(defun delete-from-trace-list (fname)
(setq *trace-list* (delete fname *trace-list* :key #'first :test #'equal)))
(defun add-to-trace-list (fname old-definition)
(push (list fname (fdefinition fname) old-definition)
*trace-list*))
(defun traced-and-redefined-p (record)
(declare (si::c-local))
(and record (not (eq (trace-record-definition record)
(fdefinition (trace-record-name record))))))
(defun untrace-one (fname)
(let ((record (trace-record fname)))
(cond ((null record)
(warn "The function ~S was not traced." fname))
((traced-and-redefined-p record)
(warn "The function ~S was traced, but redefined." fname))
(t
(sys:fset fname (trace-record-old-definition record))))
(delete-from-trace-list fname)
(values)))
(defparameter *step-level* 0)
(defparameter *step-action* nil)
(defparameter *step-form* nil)
(defparameter *step-tag* (cons nil nil))
(defparameter *step-functions* nil)
(defconstant step-commands
`("Stepper commands"
((:newline) (step-next) :constant
"newline Advance to the next form"
"newline [Stepper command]~@
~@
Step to next form.~%")
((:s :skip) step-skip nil
":s(kip) Skip current form or until function"
":skip &optional arg [Stepper command]~@
:s &optional arg [Abbreviation]~@
~@
Continue evaluation without stepping. Without argument, resume
stepping after the current form. With numeric argument (n),
resume stepping at the n-th level above. With function name, resume
when given function is called.~%")
((:pr :print) (step-print) :constant
":pr(int) Pretty print current form"
":print [Stepper command]~@
:p [Abbreviation]~@
~@
Pretty print current form.~%")
((:form) *step-form* :constant
":form Current form"
":form [Stepper command]~@
~@
Return the current form. Nothing is done, but the current form~@
is returned as the value of this command. As a consequence,~@
it is printed by the top level in the usual way and saved in~@
the variable *. The main purpose of this command is to allow~@
the current form to be examined further by accessing *.~%")
((:x :exit) (step-quit) :constant
":x or :exit Finish evaluation and exit stepper"
":exit [Stepper command]~@
:x [Abbreviation]~@
~@
Finish evaluation without stepping.~%")
))
(defmacro step (form)
"Syntax: (step form)
Evaluates FORM in the Stepper mode and returns all its values. See ECL Report
for Stepper mode commands."
`(step* ',form))
(defun step* (form)
(let* ((*step-action* t)
(*step-level* 0)
(*step-functions* (make-hash-table :size 128 :test 'eq)))
(catch *step-tag*
(si:eval-with-env form nil t))))
(defun steppable-function (form)
(let ((*step-action* nil))
(or (gethash form *step-functions*)
(multiple-value-bind (f env name)
(function-lambda-expression form)
(if (and (not (trace-record name)) f)
(setf (gethash form *step-functions*)
(eval-with-env `(function ,f) env t))
form)))))
(defun stepper (form)
(when (typep form '(or symbol function))
(return-from stepper (steppable-function (coerce form 'function))))
(let* ((*step-form* form)
(*step-action* nil)
(indent (min (* *tpl-level* 2) 20))
prompt)
(setq prompt
#'(lambda ()
(format *debug-io* "~VT" indent)
(write form :stream *debug-io* :pretty nil
:level 2 :length 2)
(princ #\space *debug-io*)
(princ #\- *debug-io*)))
(when (catch *step-tag*
(tpl :quiet t
:commands (adjoin step-commands
(adjoin break-commands *tpl-commands*))
:broken-at 'stepper
:prompt-hook prompt))
(throw *step-tag* t))))
(defun step-next ()
(throw *step-tag* nil))
(defun step-skip (&optional (when 0))
(setf *step-action* 0)
(throw *step-tag* nil))
(defun step-print ()
(write *step-form* :stream *debug-io* :pretty t :level nil :length nil)
(terpri)
(values))
(defun step-quit ()
(throw *step-tag* t))