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

Diff of /src/code/ntrace.lisp

Parent Directory Parent Directory | Revision Log Revision Log | View Patch Patch

revision 1.1 by chiles, Sun Oct 13 14:29:30 1991 UTC revision 1.2 by chiles, Sun Nov 3 17:21:16 1991 UTC
# Line 20  Line 20 
20  ;;; **********************************************************************  ;;; **********************************************************************
21  ;;;  ;;;
22    
23  (in-package "DEBUG")  (in-package "LISP")
24    
25  ;;; BECAUSE SOMEONE SLOPPILY MADE THE "DEBUG" PACKAGE USE "EXT", I HAVE TO BEND  (export '(trace untrace))
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.  (in-package "DEBUG")
 ;;;  
29    
30  (export '(*n-trace-print-level* *n-trace-print-length* *n-traced-function-list*  (export '(*trace-print-level* *trace-print-length* *traced-function-list*
31            n-trace n-untrace))            *trace-frame* *max-trace-indentation*))
32    
33  (defvar *n-traced-function-list* ()  (defvar *traced-function-list* nil
34    "A list of function names which are traced.")    "A list of function names which are traced.")
35    
36  (defvar *n-trace-print-length* ()  (defvar *trace-print-length* nil
37    "*Print-length* will be bound to this value when trace is printing.")    "Tracing output occurs with *print-length* bound to this value.")
38    
39    (defvar *trace-print-level* nil
40      "Tracing output occurs with *print-level* bound to this value.")
41    
42  (defvar *n-trace-print-level* ()  (defvar *trace-frame* nil
43    "*Print-level* will be bound to this value when trace is printing.")    "TRACE causes expressions for its switches to evaluate within a context
44       where this is bound to the appropriate control stack frame.")
45    
46    (defvar *max-trace-indentation* nil
47      "This is currently unused.")
48    
49    
50  ;;;; TRACE.  ;;;; TRACE.
51    
52    (eval-when (compile eval)
53    
54  ;;; WITH-KEYWORDS -- Internal.  ;;; WITH-KEYWORDS -- Internal.
55  ;;;  ;;;
56  ;;; This takes an options list of the following form:  ;;; This takes an options list of the following form:
# Line 62  Line 69 
69                   key-list)                   key-list)
70       ,@body))       ,@body))
71    
72  ;;; N-TRACE -- Public.  ) ;EVAL-WHEN
73    
74    
75    ;;; TRACE -- Public.
76  ;;;  ;;;
77  (defmacro n-trace (&rest specs)  (defmacro trace (&rest specs)
78    "Establishes tracing for specified functions and pushes their names on    "Establishes tracing for specified functions and pushes their names on
79     *n-traced-function-list*.  Each specification is either the name of a function     *traced-function-list*.  Each specification is either the name of a function
80     or a list of the form:     or a list of the form:
81        (function-name <trace-option> <value> <trace-option> <value> ...)        (function-name <trace-option> <value> <trace-option> <value> ...)
82     If you supply no specifications, TRACE returns the list of traced functions.     If you supply no specifications, TRACE returns the list of traced functions.
# Line 87  Line 97 
97        :print-after        :print-after
98           Like :print, but takes effect after the call.           Like :print, but takes effect after the call.
99        :print-all        :print-all
100           Like :print, but takes effect before and after the call."           Like :print, but takes effect before and after the call.
101    
102       While the provided expression evaluate, debug:*trace-frame* is bound to the
103       appropriate frame for accessing locals of the TRACE'd function.  Therefore,
104       you can use DI:PREPROCESS-FOR-EVAL (and DI:DEBUG-FUNCTION-START-LOCATION if
105       necessary) and with its resulting function, provide an expression including
106       a FUNCALL of the function and debug:*trace-frame*."
107    (cond    (cond
108     ((not specs) '*n-traced-function-list*)     ((not specs) '*traced-function-list*)
109     (t     (t
110      (let ((name-list nil)      (let ((name-list nil)
111            (trace-1-forms nil))            (trace-1-forms nil))
# Line 104  Line 120 
120                (symbol                (symbol
121                 (values spec nil))                 (values spec nil))
122                (list                (list
123                 (unless (symbolp (car spec))                 (let ((fun (car spec)))
124                   (error "Illegal function name:  ~S." (car spec)))                   (cond ((eq fun 'quote)
125                 (when (eq (car spec) 'quote)                          (error "Do NOT quote function names."))
126                   (error "I bet you don't want to trace QUOTE."))                         ((symbolp fun)
127                 (values (car spec) (cdr spec)))                          (values fun (cdr spec)))
128                           ((not (and (consp fun) (= (length fun) 2)))
129                            (error "Illegal function name:  ~S." fun))
130                           ((eq (car fun) 'setf)
131                            (values fun (cdr spec)))
132                           (t (error "Illegal function name:  ~S." fun)))))
133                (t (error "Illegal trace spec:  ~S." spec)))                (t (error "Illegal trace spec:  ~S." spec)))
134            (push name name-list)            (push name name-list)
135            (with-keywords options            (with-keywords options
# Line 130  Line 151 
151                      (null nil)                      (null nil)
152                      (symbol (list wherein))                      (symbol (list wherein))
153                      (list (dolist (fun wherein wherein)                      (list (dolist (fun wherein wherein)
154                              (unless (symbolp fun)                              (unless (or (symbolp fun)
155                                            (and (consp fun)
156                                                 (= (length fun) 2)
157                                                 (eq (car fun) 'setf)))
158                                (error "Illegal function name, ~S, in :wherein."                                (error "Illegal function name, ~S, in :wherein."
159                                       fun))))                                       fun))))
160                      (t (error "Illegal :wherein option:  ~S." wherein))))                      (t (error "Illegal :wherein option:  ~S." wherein))))
# Line 139  Line 163 
163                (error "Illegal form list, ~S, for :print." print))                (error "Illegal form list, ~S, for :print." print))
164              (unless (listp print-after)              (unless (listp print-after)
165                (error "Illegal form list, ~S, for :print-after." print-after))                (error "Illegal form list, ~S, for :print-after." print-after))
166              (push `(n-trace-1 ',name ',condition ',break ',break-after              (push `(trace-1 ',name ',condition ',break ',break-after
167                              ',wherein ',print ',print-after)                              ',wherein ',print ',print-after)
168                    trace-1-forms))))))))                    trace-1-forms))))))))
169    
# Line 162  Line 186 
186  ;;; can get rid of them in UNTRACE-1.  ;;; can get rid of them in UNTRACE-1.
187  ;;;  ;;;
188  (defvar *trace-breakpoints* (make-hash-table :test #'eq))  (defvar *trace-breakpoints* (make-hash-table :test #'eq))
189    ;;;
190    (defun clear-trace-breakpoint-record (fname new-value)
191      (declare (ignore new-value))
192      (let ((bpts (gethash fname *trace-breakpoints*)))
193        (when bpts
194          ;; Free breakpoint bookkeeping data.
195          (di:delete-breakpoint (car bpts))
196          (di:delete-breakpoint (cdr bpts))
197          ;; Free TRACE bookkeeping data.
198          (setf (gethash fname *trace-breakpoints*) nil))))
199    ;;;
200    (push #'clear-trace-breakpoint-record ext:*setf-fdefinition-hook*)
201    
202  ;;; N-TRACE-1 -- Internal.  ;;; TRACE-1 -- Internal.
203  ;;;  ;;;
204  ;;; This establishes :function-start and :function-end breakpoints with  ;;; This establishes :function-start and :function-end breakpoints with
205  ;;; appropriate hook functions to TRACE function-name as described by the user.  ;;; appropriate hook functions to TRACE function-name as described by the user.
206  ;;;  ;;;
207  (defun n-trace-1 (function-name condition break break-after wherein print  (defun trace-1 (function-name condition break break-after where-in print
208                   print-after)                   print-after)
   (declare (ignore condition break break-after wherein print print-after))  
209    (cond    (cond
210     ((member function-name *n-traced-function-list*)     ((member function-name *traced-function-list*)
211      (warn "Function ~S already TRACE'd, ignoring this request."      (warn "Function ~S already TRACE'd, ignoring this request."
212            function-name))            function-name))
213     (t     (t
214        (when where-in
215          (dolist (f where-in)
216            (unless (fboundp f)
217              (error "Undefined :where-in name -- ~S." f))))
218      (let* ((debug-fun (di:function-debug-function (fdefinition function-name)))      (let* ((debug-fun (di:function-debug-function (fdefinition function-name)))
219             (start (di:make-breakpoint #'print-trace-start             ;; The start and end hooks use conditionp for communication.
220                                        debug-fun             (conditionp nil)
221                                        :kind :function-start))             (start (di:make-breakpoint
222             (end (di:make-breakpoint #'print-trace-end                     #'(lambda (frame bpt)
223                                      debug-fun                         (let ((*trace-frame* frame))
224                                      :kind :function-end                           (cond ((and (or (not condition) ;Save a call to EVAL
225                                      :function-end-cookie                                           (eval condition))
226                                      #'(lambda (x) (push x *traced-entries*)))))                                       (or (not where-in)
227                                             (trace-where-in-p frame where-in)))
228                                    (setf conditionp t)
229                                    (print-trace-start frame bpt print))
230                                   (t (setf conditionp nil)))
231                             (when (and break (eval break))
232                               (break "Breaking before TRACE'd call to ~S."
233                                      (di:debug-function-name
234                                       (di:frame-debug-function frame))))))
235                       debug-fun :kind :function-start))
236               (end (di:make-breakpoint
237                     #'(lambda (frame bpt values cookie)
238                         (let ((*trace-frame* frame))
239                           (when conditionp
240                             (print-trace-end frame bpt values cookie print-after))
241                           (pop *traced-entries*)
242                           (when (and break-after (eval break-after))
243                             (break "Breaking after TRACE'd call to ~S."
244                                    (di:debug-function-name
245                                     (di:frame-debug-function frame))))))
246                     debug-fun :kind :function-end
247                     :function-end-cookie
248                     #'(lambda (frame x)
249                         (when (and *traced-entries*
250                                    (not (di:function-end-cookie-valid-p
251                                          frame (car *traced-entries*))))
252                           (format t "~&WARNING: dynamic flow of control occurred ~
253                                      while TRACE'ing.~%")
254                           (loop
255                             (pop *traced-entries*)
256                             (when (or (not *traced-entries*)
257                                       (di:function-end-cookie-valid-p
258                                        frame (car *traced-entries*)))
259                               (return))))
260                         (push x *traced-entries*)))))
261        (setf (gethash function-name *trace-breakpoints*) (cons start end))        (setf (gethash function-name *trace-breakpoints*) (cons start end))
262        ;; This works TOTALLY SLIMY by the order of the next two calls.        ;; The next two forms must be in the order in which they appear.  They
263          ;; rely on a documented property that later activated breakpoint hooks
264          ;; run first, and the end breakpoint establishes a starting helper bpt.
265        (di:activate-breakpoint start)        (di:activate-breakpoint start)
266        (di:activate-breakpoint end))        (di:activate-breakpoint end))
267      (push function-name *n-traced-function-list*))))      (push function-name *traced-function-list*))))
268    
269  ;;; PRINT-TRACE-START -- Internal.  ;;; PRINT-TRACE-START -- Internal.
270  ;;;  ;;;
271  ;;; This prints a representation of the call establishing frame.  ;;; This prints a representation of the call establishing frame.
272  ;;;  ;;;
273  (defun print-trace-start (frame bpt)  (defun print-trace-start (frame bpt &optional print)
274    (declare (ignore bpt))    (declare (ignore bpt))
275    (let ((*print-length* (or *n-trace-print-length* *print-length*))    (let ((*print-length* (or *trace-print-length* *print-length*))
276          (*print-level* (or *n-trace-print-level* *print-level*)))          (*print-level* (or *trace-print-level* *print-level*)))
277      (fresh-line)      (fresh-line)
278      (print-trace-indentation)      (print-trace-indentation)
279      (print-frame-call-1 frame nil)      (print-frame-call-1 frame nil)
280        (dolist (ele print)
281          (fresh-line)
282          (print-trace-indentation)
283          (prin1 (eval ele)))
284      (terpri)))      (terpri)))
285    
286  ;;; PRINT-TRACE-END -- Internal.  ;;; PRINT-TRACE-END -- Internal.
# Line 211  Line 290 
290  ;;; to see that cookie is at the top of *traced-entries*; if it is not, then we  ;;; to see that cookie is at the top of *traced-entries*; if it is not, then we
291  ;;; need to adjust this list to determine the correct indentation for output.  ;;; need to adjust this list to determine the correct indentation for output.
292  ;;;  ;;;
293  (defun print-trace-end (frame bpt values cookie)  (defun print-trace-end (frame bpt values cookie &optional print-after)
294    (declare (ignore frame bpt))    (declare (ignore frame bpt))
295    (unless (eq cookie (car *traced-entries*))    (unless (eq cookie (car *traced-entries*))
296      (setf *traced-entries* (member cookie *traced-entries*))      (setf *traced-entries* (member cookie *traced-entries*))
297      (fresh-line)      (fresh-line)
298      (write-line "WARNING: dynamic flow of control occurred while TRACE'ing."))      (write-line "WARNING: dynamic flow of control occurred while TRACE'ing."))
299    (print-trace-indentation)    (print-trace-indentation)
   (pop *traced-entries*)  
300    (write-string "returned ")    (write-string "returned ")
301    (dolist (v values)    (dolist (v values)
302      (prin1 v)      (prin1 v)
303      (write-char #\space))      (write-char #\space))
304      (dolist (ele print-after)
305        (terpri)
306        (print-trace-indentation)
307        (prin1 (eval ele)))
308    (terpri))    (terpri))
309    
310  (defun print-trace-indentation ()  (defun print-trace-indentation ()
# Line 231  Line 313 
313      (prin1 len)      (prin1 len)
314      (write-string ": ")))      (write-string ": ")))
315    
316    ;;; TRACE-WHERE-IN-P -- Internal.
317    ;;;
318    ;;; The TRACE hooks use this for the :where-in arg.
319    ;;;
320    (defun trace-where-in-p (frame names)
321      (do ((frame (di:frame-down frame) (di:frame-down frame)))
322          ((not frame) nil)
323        (when (member (di:debug-function-name (di:frame-debug-function frame))
324                      names :test #'equal)
325          (return t))))
326    
327    
328    
329  ;;;; N-UNTRACE.  ;;;; N-UNTRACE.
330    
331  (defmacro n-untrace (&rest names)  (defmacro untrace (&rest names)
332    "Removes tracing from the functions named.  With no args, untraces all    "Removes tracing from the functions named.  With no args, untraces all
333     functions."     functions."
334    (let ((names (or names *n-traced-function-list*))    (let ((names (or names *traced-function-list*))
335          (untrace-1-forms nil))          (untrace-1-forms nil))
336      (dolist (name names `(progn ,@(nreverse untrace-1-forms) t))      (dolist (name names `(progn ,@(nreverse untrace-1-forms) t))
337        (if (symbolp name)        (if (symbolp name)
338            (push `(n-untrace-1 ',name) untrace-1-forms)            (push `(untrace-1 ',name) untrace-1-forms)
339            (error "Illegal function name -- ~S." name)))))            (error "Illegal function name -- ~S." name)))))
340    
341  (defun n-untrace-1 (name)  (defun untrace-1 (name)
342    (cond ((member name *n-traced-function-list*)    (cond ((member name *traced-function-list*)
343           (let ((breakpoints (gethash name *trace-breakpoints*)))           (let ((breakpoints (gethash name *trace-breakpoints*)))
344             (di:delete-breakpoint (car breakpoints))             (di:delete-breakpoint (car breakpoints))
345             (di:delete-breakpoint (cdr breakpoints))             (di:delete-breakpoint (cdr breakpoints))
346             (setf (gethash name *trace-breakpoints*) nil))             (setf (gethash name *trace-breakpoints*) nil))
347           (setf *n-traced-function-list* (delete name *n-traced-function-list*)))           (setf *traced-function-list* (delete name *traced-function-list*)))
348          (t (warn "Function is not TRACE'd -- ~S." name))))          (t (warn "Function is not TRACE'd -- ~S." name))))

Legend:
Removed from v.1.1  
changed lines
  Added in v.1.2

  ViewVC Help
Powered by ViewVC 1.1.5