/[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.6 by wlott, Tue Mar 10 18:37:08 1992 UTC revision 1.7 by ram, Fri May 15 18:31:05 1992 UTC
# Line 28  Line 28 
28  (in-package "DEBUG")  (in-package "DEBUG")
29    
30  (export '(*trace-print-level* *trace-print-length* *traced-function-list*  (export '(*trace-print-level* *trace-print-length* *traced-function-list*
31            *trace-frame* *max-trace-indentation*))            *trace-frame* *trace-values* *max-trace-indentation*))
32    
33  (defvar *traced-function-list* nil  (defvar *traced-function-list* nil
34    "A list of functions which are traced.")    "A list of functions which are traced.")
# Line 43  Line 43 
43    "TRACE causes expressions for its switches to evaluate within a context    "TRACE causes expressions for its switches to evaluate within a context
44     where this is bound to the appropriate control stack frame.")     where this is bound to the appropriate control stack frame.")
45    
46    (defvar *trace-values* nil
47      "This is bound to the returned values when evaluating :BREAK-AFTER and
48       :PRINT-AFTER forms.")
49    
50  (defvar *max-trace-indentation* nil  (defvar *max-trace-indentation* nil
51    "This is currently unused.")    "This is currently unused.")
52    
# Line 88  Line 92 
92      (let ((name-list nil)      (let ((name-list nil)
93            (trace-1-forms nil))            (trace-1-forms nil))
94        (dolist (spec specs `(progn        (dolist (spec specs `(progn
                              ;; Make sure every name has a definition.  
                              ,@(mapcar #'(lambda (x) `#',x) name-list)  
95                               ,@trace-1-forms                               ,@trace-1-forms
96                               ',(nreverse name-list)))                               ',(reverse name-list)))
97          (multiple-value-bind          (multiple-value-bind
98              (name options)              (name options)
99              (typecase spec              (typecase spec
# Line 139  Line 141 
141                              ',wherein ',print ',print-after)                              ',wherein ',print ',print-after)
142                    trace-1-forms))))))))                    trace-1-forms))))))))
143    
144    
145    ;;; TRACE-FDEFINITION  --  Internal
146    ;;;
147    ;;;    Given a function or macro name, return the definition.  Error if a
148    ;;; special form.  If already a function, just return it.
149    ;;;
150    (defun trace-fdefinition (x)
151      (typecase x
152        (symbol
153         (cond ((special-form-p x)
154                (error "Can't trace special form ~S." x))
155               ((macro-function x))
156               (t
157                (fdefinition x))))
158        (function x)
159        (t (fdefinition x))))
160    
161    
162  ;;; This is a list of function-end-cookies, which we use to note distinct  ;;; This is a list of function-end-cookies, which we use to note distinct
163  ;;; dynamic entries into functions.  ;;; dynamic entries into functions.
164  ;;;  ;;;
# Line 162  Line 182 
182  (defun clear-trace-breakpoint-record (fname new-value)  (defun clear-trace-breakpoint-record (fname new-value)
183    (declare (ignore new-value))    (declare (ignore new-value))
184    (when (fboundp fname)    (when (fboundp fname)
185      (let* ((fun (fdefinition fname))      (let* ((fun (trace-fdefinition fname))
186             (bpts (gethash fun *trace-breakpoints*)))             (bpts (gethash fun *trace-breakpoints*)))
187        (when bpts        (when bpts
188          ;; Free breakpoint bookkeeping data.          ;; Free breakpoint bookkeeping data.
# Line 178  Line 198 
198  ;;; This establishes :function-start and :function-end breakpoints with  ;;; This establishes :function-start and :function-end breakpoints with
199  ;;; appropriate hook functions to TRACE function-name as described by the user.  ;;; appropriate hook functions to TRACE function-name as described by the user.
200  ;;;  ;;;
201  (defun trace-1 (function-or-name condition break break-after where-in print  (defun trace-1 (function-or-name condition break break-after wherein print
202                   print-after)                   print-after)
203    (let ((fun (if (functionp function-or-name)    (let ((fun (trace-fdefinition function-or-name)))
204                   function-or-name      (when (member fun *traced-function-list*)
205                   (fdefinition function-or-name))))        (warn "Function ~S already TRACE'd, retracing it." function-or-name)
206      (cond        (untrace-1 fun))
207       ((member fun *traced-function-list*)  
208        (warn "Function ~S already TRACE'd, ignoring this request."      (when wherein
209              fun))        (dolist (f wherein)
210       (t          (unless (fboundp f)
211        (when where-in            (error "Undefined :wherein name -- ~S." f))))
212          (dolist (f where-in)      (let* ((debug-fun (di:function-debug-function fun))
213            (unless (fboundp f)             ;; The start and end hooks use conditionp for communication.
214              (error "Undefined :where-in name -- ~S." f))))             (conditionp nil)
215        (let* ((debug-fun (di:function-debug-function fun))             (start (di:make-breakpoint
216               ;; The start and end hooks use conditionp for communication.                     #'(lambda (frame bpt)
217               (conditionp nil)                         (let ((*trace-frame* frame))
218               (start (di:make-breakpoint                           (cond ((and (or (not condition) ;Save a call to EVAL
219                       #'(lambda (frame bpt)                                           (eval condition))
220                                         (or (not wherein)
221                                             (trace-wherein-p frame wherein)))
222                                    (setf conditionp t)
223                                    (print-trace-start frame bpt print))
224                                   (t (setf conditionp nil)))
225                             (when (and break (eval break))
226                               (di:flush-frames-above frame)
227                               (let ((*stack-top-hint* frame))
228                                 (break "Breaking before TRACE'd call to ~S."
229                                        function-or-name)))))
230                       debug-fun :kind :function-start))
231               (end (di:make-breakpoint
232                     #'(lambda (frame bpt *trace-values* cookie)
233                         (if (member fun *traced-function-list*)
234                           (let ((*trace-frame* frame))                           (let ((*trace-frame* frame))
235                             (cond ((and (or (not condition) ;Save a call to EVAL                             (when conditionp
236                                             (eval condition))                               (print-trace-end frame bpt *trace-values* cookie
237                                         (or (not where-in)                                                print-after))
238                                             (trace-where-in-p frame where-in)))                             (pop *traced-entries*)
239                                    (setf conditionp t)                             (when (and break-after (eval break-after))
                                   (print-trace-start frame bpt print))  
                                  (t (setf conditionp nil)))  
                            (when (and break (eval break))  
240                               (di:flush-frames-above frame)                               (di:flush-frames-above frame)
241                               (let ((*stack-top-hint* frame))                               (let ((*stack-top-hint* frame))
242                                 (break "Breaking before TRACE'd call to ~S."                                 (break "Breaking after TRACE'd call to ~S."
243                                        function-or-name)))))                                        function-or-name))))
244                       debug-fun :kind :function-start))                           (pop *traced-entries*)))
245               (end (di:make-breakpoint                   debug-fun :kind :function-end
246                     #'(lambda (frame bpt values cookie)                   :function-end-cookie
247                         (if (member fun *traced-function-list*)                   #'(lambda (frame x)
248                             (let ((*trace-frame* frame))                       (when (and *traced-entries*
249                               (when conditionp                                  (not (di:function-end-cookie-valid-p
250                                 (print-trace-end frame bpt values cookie                                        frame (car *traced-entries*))))
251                                                  print-after))                         (loop
252                               (pop *traced-entries*)                           (pop *traced-entries*)
253                               (when (and break-after (eval break-after))                           (when (or (not *traced-entries*)
254                                 (di:flush-frames-above frame)                                     (di:function-end-cookie-valid-p
255                                 (let ((*stack-top-hint* frame))                                      frame (car *traced-entries*)))
256                                   (break "Breaking after TRACE'd call to ~S."                             (return))))
257                                          function-or-name))))                       (push x *traced-entries*)))))
258                             (pop *traced-entries*)))        (assert (not (gethash fun *trace-breakpoints*)))
259                     debug-fun :kind :function-end        (setf (gethash fun *trace-breakpoints*) (cons start end))
260                     :function-end-cookie        ;; The next two forms must be in the order in which they appear.  They
261                     #'(lambda (frame x)        ;; rely on a documented property that later activated breakpoint hooks
262                         (when (and *traced-entries*        ;; run first, and the end breakpoint establishes a starting helper bpt.
263                                    (not (di:function-end-cookie-valid-p        (di:activate-breakpoint start)
264                                          frame (car *traced-entries*))))        (di:activate-breakpoint end))
265                           (loop      (push fun *traced-function-list*)))
                            (pop *traced-entries*)  
                            (when (or (not *traced-entries*)  
                                      (di:function-end-cookie-valid-p  
                                       frame (car *traced-entries*)))  
                              (return))))  
                        (push x *traced-entries*)))))  
         (setf (gethash fun *trace-breakpoints*) (cons start end))  
         ;; The next two forms must be in the order in which they appear.  They  
         ;; rely on a documented property that later activated breakpoint hooks  
         ;; run first, and the end breakpoint establishes a starting helper bpt.  
         (di:activate-breakpoint start)  
         (di:activate-breakpoint end))  
       (push fun *traced-function-list*)))))  
266    
267  ;;; PRINT-TRACE-START -- Internal.  ;;; PRINT-TRACE-START -- Internal.
268  ;;;  ;;;
# Line 291  Line 309 
309      (prin1 len)      (prin1 len)
310      (write-string ": ")))      (write-string ": ")))
311    
312  ;;; TRACE-WHERE-IN-P -- Internal.  ;;; TRACE-WHEREIN-P -- Internal.
313  ;;;  ;;;
314  ;;; The TRACE hooks use this for the :where-in arg.  ;;; The TRACE hooks use this for the :wherein arg.
315  ;;;  ;;;
316  (defun trace-where-in-p (frame names)  (defun trace-wherein-p (frame names)
317    (do ((frame (di:frame-down frame) (di:frame-down frame)))    (do ((frame (di:frame-down frame) (di:frame-down frame)))
318        ((not frame) nil)        ((not frame) nil)
319      (when (member (di:debug-function-name (di:frame-debug-function frame))      (when (member (di:debug-function-name (di:frame-debug-function frame))
# Line 309  Line 327 
327  (defmacro untrace (&rest specs)  (defmacro untrace (&rest specs)
328    "Removes tracing from the specified functions.  With no args, untraces all    "Removes tracing from the specified functions.  With no args, untraces all
329     functions."     functions."
330    (let ((specs (or specs *traced-function-list*))    (let ((specs (or specs *traced-function-list*)))
331          (untrace-1-forms nil))      `(progn
332      (dolist (spec specs `(progn ,@(nreverse untrace-1-forms) t))         ,@(mapcar #'(lambda (spec)
333        (let ((fun (typecase spec                       `(untrace-1 ',(if (consp spec) (car spec) spec)))
334                     (symbol (fdefinition spec))                   specs)
335                     (function spec)         t)))
336                     (list  
337                      (let ((fun (car spec)))  (defun untrace-1 (function-or-name)
338                        (cond ((eq fun 'quote)    (let ((fun (trace-fdefinition function-or-name)))
339                               (error "Do NOT quote function names."))      (cond ((member fun *traced-function-list*)
340                              ((symbolp fun)             (let ((breakpoints (gethash fun *trace-breakpoints*)))
341                               (fdefinition fun))               (di:delete-breakpoint (car breakpoints))
342                              ((functionp fun)               (di:delete-breakpoint (cdr breakpoints))
343                               fun)               (setf (gethash fun *trace-breakpoints*) nil))
344                              ((not (and (consp fun) (= (length fun) 2)))             (setf *traced-function-list* (delete fun *traced-function-list*)))
345                               (error "Illegal function specifier:  ~S." fun))            (t (warn "Function is not TRACE'd -- ~S." fun)))))
                             ((eq (car fun) 'setf)  
                              (fdefinition fun))  
                             (t (error "Illegal function specifier:  ~S." fun)))))  
                    (t (error "Illegal function specifier:  ~S." spec)))))  
         (push `(untrace-1 ',fun) untrace-1-forms)))))  
   
 (defun untrace-1 (fun)  
   (cond ((member fun *traced-function-list*)  
          (let ((breakpoints (gethash fun *trace-breakpoints*)))  
            (di:delete-breakpoint (car breakpoints))  
            (di:delete-breakpoint (cdr breakpoints))  
            (setf (gethash fun *trace-breakpoints*) nil))  
          (setf *traced-function-list* (delete fun *traced-function-list*)))  
         (t (warn "Function is not TRACE'd -- ~S." fun))))  

Legend:
Removed from v.1.6  
changed lines
  Added in v.1.7

  ViewVC Help
Powered by ViewVC 1.1.5