/[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.28.12.2 by rtoy, Mon Dec 19 01:09:52 2005 UTC revision 1.48 by rtoy, Tue Feb 22 22:56:15 2011 UTC
# Line 16  Line 16 
16  ;;; **********************************************************************  ;;; **********************************************************************
17  ;;;  ;;;
18  (in-package "LISP")  (in-package "LISP")
19    (intl:textdomain "cmucl")
20    
21  (export '(trace untrace))  (export '(trace untrace))
22    
# Line 60  Line 61 
61  ;;; A hash-table that maps each traced function to the TRACE-INFO.  The entry  ;;; A hash-table that maps each traced function to the TRACE-INFO.  The entry
62  ;;; for a closure is the shared function-entry object.  ;;; for a closure is the shared function-entry object.
63  ;;;  ;;;
64  (defvar *traced-functions* (make-hash-table :test #'eq))  (defvar *traced-functions* (make-hash-table :test #'equal))
65    
66  ;;; The TRACE-INFO structure represents all the information we need to trace a  ;;; The TRACE-INFO structure represents all the information we need to trace a
67  ;;; given function.  ;;; given function.
# Line 93  Line 94 
94    ;; The list of function names for wherein.  NIL means unspecified.    ;; The list of function names for wherein.  NIL means unspecified.
95    (wherein nil :type list)    (wherein nil :type list)
96    ;;    ;;
97      ;; Like wherein, but only if the caller is in the list.
98      (wherein-only nil :type list)
99      ;;
100    ;; The following slots represent the forms that we are supposed to evaluate    ;; The following slots represent the forms that we are supposed to evaluate
101    ;; on each iteration.  Each form is represented by a cons (Form . Function),    ;; on each iteration.  Each form is represented by a cons (Form . Function),
102    ;; where the Function is the cached result of coercing Form to a function.    ;; where the Function is the cached result of coercing Form to a function.
# Line 155  Line 159 
159  ;;; :FUNCALLABLE-INSTANCE.  ;;; :FUNCALLABLE-INSTANCE.
160  ;;;  ;;;
161  (defun trace-fdefinition (x)  (defun trace-fdefinition (x)
162    (multiple-value-bind (res named-p)    (multiple-value-bind (res named-p local)
163        (typecase x        (typecase x
164          (symbol          (symbol
165           (cond ((special-operator-p x)           (cond ((special-operator-p x)
166                  (error "Can't trace special form ~S." x))                  (error (intl:gettext "Can't trace special form ~S.") x))
167                 ((macro-function x))                 ((macro-function x))
168                 (t                 (t
169                  (values (fdefinition x) t))))                  (values (fdefinition x) t))))
170          (function x)          (function x)
171            ((cons (member flet labels))
172             ;; An extended function name for flet/labels functions.
173             (values (fdefinition (car (last x))) t x))
174          (t (values (fdefinition x) t)))          (t (values (fdefinition x) t)))
175      (if (eval:interpreted-function-p res)      (if (eval:interpreted-function-p res)
176          (values res named-p (if (eval:interpreted-function-closure res)          (values res named-p (if (eval:interpreted-function-closure res)
# Line 173  Line 180 
180             (values (kernel:%closure-function res) named-p :compiled-closure))             (values (kernel:%closure-function res) named-p :compiled-closure))
181            (#.vm:funcallable-instance-header-type            (#.vm:funcallable-instance-header-type
182             (values res named-p :funcallable-instance))             (values res named-p :funcallable-instance))
183            (t (values res named-p :compiled))))))            (t (values res named-p :compiled local))))))
184    
185    
186  ;;; TRACE-REDEFINED-UPDATE  --  Internal  ;;; TRACE-REDEFINED-UPDATE  --  Internal
# Line 183  Line 190 
190  ;;;  ;;;
191  (defun trace-redefined-update (fname new-value)  (defun trace-redefined-update (fname new-value)
192    (when (fboundp fname)    (when (fboundp fname)
193      (let* ((fun (trace-fdefinition fname))      (multiple-value-bind (fun named kind local)
194             (info (gethash fun *traced-functions*)))          (trace-fdefinition fname)
195        (when (and info (trace-info-named info))        (let* ((fkey (or local fun))
196          (untrace-1 fname)               (info (gethash fkey *traced-functions*)))
197          (trace-1 fname info new-value)))))          (flet ((handle-local-funs ()
198                     ;; FIXME: This is gross.  We need to grovel over the
199                     ;; *traced-functions* to see if any flet/labels functions
200                     ;; have been traced in the function we're redefining.
201                     (maphash #'(lambda (key info)
202                                  (when (and (listp key)
203                                             (eq fname (car (last key))))
204                                    (when info
205                                      (untrace-1 key)
206                                      (trace-1 key info new-value))))
207                              *traced-functions*)))
208              (when (and info (trace-info-named info))
209                (untrace-1 fname)
210                (trace-1 fname info new-value))
211              (handle-local-funs))))))
212    
213  ;;;  ;;;
214  (push #'trace-redefined-update ext:*setf-fdefinition-hook*)  (push #'trace-redefined-update ext:*setf-fdefinition-hook*)
215    
# Line 252  Line 274 
274        (when (member frame-name names :test #'equal)        (when (member frame-name names :test #'equal)
275          (return t)))))          (return t)))))
276    
277    ;;; TRACE-WHEREIN-ONLY-P -- Internal
278    ;;;
279    ;;;    Like, TRACE-WHEREIN-ONLY-P, except true only if the last stack
280    ;;;    frame Frame has the given name.
281    (defun trace-wherein-only-p (frame name)
282      (let ((caller-frame (di::frame-down frame)))
283        (when caller-frame
284          (let ((frame-name (di:debug-function-name (di:frame-debug-function caller-frame))))
285            (member frame-name name :test #'equal)))))
286    
287  ;;; TRACE-PRINT  --  Internal  ;;; TRACE-PRINT  --  Internal
288  ;;;  ;;;
289  ;;;    Handle print and print-after options.  ;;;    Handle print and print-after options.
# Line 270  Line 302 
302    (when (and break (funcall (cdr break) frame))    (when (and break (funcall (cdr break) frame))
303      (di:flush-frames-above frame)      (di:flush-frames-above frame)
304      (let ((*stack-top-hint* frame))      (let ((*stack-top-hint* frame))
305        (break "Breaking ~A traced call to ~S:" where        (break (intl:gettext "Breaking ~A traced call to ~S:") where
306               (trace-info-what info)))))               (trace-info-what info)))))
307    
308  ;;; DISCARD-INVALID-ENTRIES  --  Internal  ;;; DISCARD-INVALID-ENTRIES  --  Internal
# Line 305  Line 337 
337           (declare (ignore bpt))           (declare (ignore bpt))
338           (discard-invalid-entries frame)           (discard-invalid-entries frame)
339           (let ((condition (trace-info-condition info))           (let ((condition (trace-info-condition info))
340                 (wherein (trace-info-wherein info)))                 (wherein (trace-info-wherein info))
341                   (wherein-only (trace-info-wherein-only info)))
342             (setq conditionp             (setq conditionp
343                   (and (not *in-trace*)                   (and (not *in-trace*)
344                        (or (not condition)                        (or (not condition)
345                            (funcall (cdr condition) frame))                            (funcall (cdr condition) frame))
346                        (or (not wherein)                        (or (not wherein)
347                            (trace-wherein-p frame wherein)))))                            (trace-wherein-p frame wherein))
348                          (or (not wherein-only)
349                              (trace-wherein-only-p frame wherein-only)))))
350    
351           (when conditionp           (when conditionp
352             (let ((*print-length* (or *debug-print-length* *print-length*))             (let ((*print-length* (or *debug-print-length* *print-length*))
# Line 363  Line 398 
398              (pprint-logical-block (*standard-output* nil)              (pprint-logical-block (*standard-output* nil)
399                (print-trace-indentation)                (print-trace-indentation)
400                (pprint-indent :current 2)                (pprint-indent :current 2)
401                (format t "~S returned" (trace-info-what info))                (format t (intl:gettext "~S returned") (trace-info-what info))
402                (dolist (v *trace-values*)                (dolist (v *trace-values*)
403                  (write-char #\space)                  (write-char #\space)
404                  (pprint-newline :linear)                  (pprint-newline :linear)
# Line 409  Line 444 
444  ;;; automatically retracing; this  ;;; automatically retracing; this
445  ;;;  ;;;
446  (defun trace-1 (function-or-name info &optional definition)  (defun trace-1 (function-or-name info &optional definition)
447    (multiple-value-bind (fun named kind)    (multiple-value-bind (fun named kind local)
448        (if definition      (if definition
449            (values definition t          ;; Tracing a new definition.  If function-or-name looks like a
450                    (nth-value 2 (trace-fdefinition definition)))          ;; local function, we trace the new definition with the local
451            ;; function.  Otherwise, we do what we used to do.
452            (if (and (valid-function-name-p function-or-name)
453                     (typep function-or-name '(cons (member flet labels))))
454                (multiple-value-bind (fun named kind)
455                    (trace-fdefinition definition)
456                  (values fun t kind function-or-name))
457                (values definition t
458                        (nth-value 2 (trace-fdefinition definition))))
459            (trace-fdefinition function-or-name))            (trace-fdefinition function-or-name))
460      (when (gethash fun *traced-functions*)      (when (gethash (or local fun) *traced-functions*)
461        (warn "Function ~S already TRACE'd, retracing it." function-or-name)        (warn (intl:gettext "Function ~S already TRACE'd, retracing it.") function-or-name)
462        (untrace-1 fun))        (untrace-1 fun))
463    
464      (let* ((debug-fun (di:function-debug-function fun))      (let* ((debug-fun (di:function-debug-function fun :local-name local))
465             (encapsulated             (encapsulated
466              (if (eq (trace-info-encapsulated info) :default)              (if (eq (trace-info-encapsulated info) :default)
467                  (let ((encapsulate-p                  (let ((encapsulate-p
# Line 429  Line 472 
472                       encapsulate-p)                       encapsulate-p)
473                      (:compiled-closure                      (:compiled-closure
474                       (unless (functionp function-or-name)                       (unless (functionp function-or-name)
475                         (warn "Tracing shared code for ~S:~%  ~S"                         (warn (intl:gettext "Tracing shared code for ~S:~%  ~S")
476                               function-or-name fun))                               function-or-name fun))
477                       encapsulate-p)                       encapsulate-p)
478                      ((:interpreted :interpreted-closure                      ((:interpreted :interpreted-closure
# Line 444  Line 487 
487                    :named named                    :named named
488                    :encapsulated encapsulated                    :encapsulated encapsulated
489                    :wherein (trace-info-wherein info)                    :wherein (trace-info-wherein info)
490                      :wherein-only (trace-info-wherein-only info)
491                    :condition (coerce-form (trace-info-condition info) loc)                    :condition (coerce-form (trace-info-condition info) loc)
492                    :break (coerce-form (trace-info-break info) loc)                    :break (coerce-form (trace-info-break info) loc)
493                    :print (coerce-form-list (trace-info-print info) loc)                    :print (coerce-form-list (trace-info-print info) loc)
# Line 453  Line 497 
497                    :print-after                    :print-after
498                    (coerce-form-list (trace-info-print-after info) nil))))                    (coerce-form-list (trace-info-print-after info) nil))))
499    
500        (dolist (wherein (trace-info-wherein info))        (flet ((verify-wherein (wherein-info type)
501          (multiple-value-bind (validp block-name)                 (dolist (wherein wherein-info)
502              (ext:valid-function-name-p wherein)                   (multiple-value-bind (validp block-name)
503          (unless (or (stringp block-name)                       (ext:valid-function-name-p wherein)
504                      (fboundp block-name))                     (declare (ignore validp))
505            (warn ":WHEREIN name is not a defined global function: ~S"                     (unless (or (stringp block-name)
506                  wherein))))                                 (fboundp block-name))
507                         (warn (intl:gettext "~S name is not a defined global function: ~S")
508                               type wherein))))))
509            (verify-wherein (trace-info-wherein info) :wherein)
510            (verify-wherein (trace-info-wherein-only info) :wherein-only))
511    
512    
513        (cond        (cond
514         (encapsulated         (encapsulated
515          (unless named          (unless named
516            (error "Can't use encapsulation to trace anonymous function ~S."            (error (intl:gettext "Can't use encapsulation to trace anonymous function ~S.")
517                   fun))                   fun))
518            (when (and (listp function-or-name)
519                       (member function-or-name '(flet labels)))
520              (error (intl:gettext "Can't use encapsulation to trace local flet/labels function ~S.")
521                     function-or-name))
522          (fwrap function-or-name #'trace-fwrapper :type 'trace          (fwrap function-or-name #'trace-fwrapper :type 'trace
523                 :user-data info))                 :user-data info))
524         (t         (t
# Line 489  Line 542 
542              (di:activate-breakpoint start)              (di:activate-breakpoint start)
543              (di:activate-breakpoint end)))))              (di:activate-breakpoint end)))))
544    
545        (setf (gethash fun *traced-functions*) info)))        (setf (gethash (or local fun) *traced-functions*) info)))
546    
547    function-or-name)    function-or-name)
548    
# Line 516  Line 569 
569  ;;;  ;;;
570  (defun parse-trace-options (specs info)  (defun parse-trace-options (specs info)
571    (let ((current specs))    (let ((current specs))
572      (loop      (flet ((collect-names (value)
573        (when (endp current) (return))               (collect ((new-names))
574        (let ((option (first current))                 (dolist (name (if (listp (car value)) (car value) value))
575              (value (cons (second current) nil)))                   (cond ((and (consp name) (eq (car name) 'method)
576          (case option                               (ext:valid-function-name-p name))
577            (:condition (setf (trace-info-condition info) value))                          ;; This needs to be coordinated with how the
578            (:condition-after                          ;; debugger prints method names.  So this is
579             (setf (trace-info-condition info) (cons nil nil))                          ;; what this code does.  Any method qualifiers
580             (setf (trace-info-condition-after info) value))                          ;; appear as a list in the debugger.  No
581            (:condition-all                          ;; qualifiers show up as NIL.  We also take the
582             (setf (trace-info-condition info) value)                          ;; method and add a pcl::fast-method in case the
583             (setf (trace-info-condition-after info) value))                          ;; method wasn't compiled.  (Do we need to do this?)
584            (:wherein                          (let ((method (cond ((atom (third name))
585             (collect ((new-names))                                               `(,(second name) (,(third name)) ,@(cdddr name)))
586               (dolist (name (if (listp (car value)) (car value) value))                                              (t
587                 (cond ((and (consp name) (eq (car name) 'method)                                               `(,(second name) nil ,@(cddr name))))))
588                             (ext:valid-function-name-p name))                            (new-names `(pcl::fast-method ,@method))
589                        ;; This needs to be coordinated with how the                            (new-names `(method ,@method))))
590                        ;; debugger prints method names.  So this is                         (t
591                        ;; what this code does.  Any method qualifiers                          (new-names name))))
592                        ;; appear as a list in the debugger.  No                 (new-names))))
593                        ;; qualifiers show up as NIL.  We also take the        (loop
594                        ;; method and add a pcl::fast-method in case the           (when (endp current) (return))
595                        ;; method wasn't compiled.  (Do we need to do this?)           (let ((option (first current))
596                        (let ((method (cond ((atom (third name))                 (value (cons (second current) nil)))
597                                             `(,(second name) (,(third name)) ,@(cdddr name)))             (case option
598                                            (t               (:condition (setf (trace-info-condition info) value))
599                                             `(,(second name) nil ,@(cddr name))))))               (:condition-after
600                          (new-names `(pcl::fast-method ,@method))                (setf (trace-info-condition info) (cons nil nil))
601                          (new-names `(method ,@method))))                (setf (trace-info-condition-after info) value))
602                       (t               (:condition-all
603                        (new-names name))))                (setf (trace-info-condition info) value)
604               (setf (trace-info-wherein info) (new-names))))                (setf (trace-info-condition-after info) value))
605            (:encapsulate               (:wherein
606             (setf (trace-info-encapsulated info) (car value)))                (setf (trace-info-wherein info) (collect-names value)))
607            (:break (setf (trace-info-break info) value))               (:wherein-only
608            (:break-after (setf (trace-info-break-after info) value))                (setf (trace-info-wherein-only info) (collect-names value)))
609            (:break-all               (:encapsulate
610             (setf (trace-info-break info) value)                (setf (trace-info-encapsulated info) (car value)))
611             (setf (trace-info-break-after info) value))               (:break (setf (trace-info-break info) value))
612            (:print               (:break-after (setf (trace-info-break-after info) value))
613             (setf (trace-info-print info)               (:break-all
614                   (append (trace-info-print info) (list value))))                (setf (trace-info-break info) value)
615            (:print-after                (setf (trace-info-break-after info) value))
616             (setf (trace-info-print-after info)               (:print
617                   (append (trace-info-print-after info) (list value))))                (setf (trace-info-print info)
618            (:print-all                      (append (trace-info-print info) (list value))))
619             (setf (trace-info-print info)               (:print-after
620                   (append (trace-info-print info) (list value)))                (setf (trace-info-print-after info)
621             (setf (trace-info-print-after info)                      (append (trace-info-print-after info) (list value))))
622                   (append (trace-info-print-after info) (list value))))               (:print-all
623            (t (return)))                (setf (trace-info-print info)
624          (pop current)                      (append (trace-info-print info) (list value)))
625          (unless current                (setf (trace-info-print-after info)
626            (error "Missing argument to ~S TRACE option." option))                      (append (trace-info-print-after info) (list value))))
627          (pop current)))               (t (return)))
628      current))             (pop current)
629               (unless current
630                 (error (intl:gettext "Missing argument to ~S TRACE option.") option))
631               (pop current)))
632          current)))
633    
634    
635  ;;; EXPAND-TRACE  --  Internal  ;;; EXPAND-TRACE  --  Internal
# Line 605  Line 662 
662                            (trace-1 name ',options))))))                            (trace-1 name ',options))))))
663             ((and (keywordp name)             ((and (keywordp name)
664                   (not (or (fboundp name) (macro-function name))))                   (not (or (fboundp name) (macro-function name))))
665              (error "Unknown TRACE option: ~S" name))              (error (intl:gettext "Unknown TRACE option: ~S") name))
666             ;;             ;;
667             ;; Method name -> trace method functions.             ;; Method name -> trace method functions.
668             ((and (consp name) (eq (car name) 'method))             ((and (consp name) (eq (car name) 'method))
# Line 641  Line 698 
698     CLOS methods can be traced by specifying a name of the form     CLOS methods can be traced by specifying a name of the form
699     (METHOD {Qualifier}* ({Specializer}*)).     (METHOD {Qualifier}* ({Specializer}*)).
700    
701       Labels and Flet functions can be traced by specifying a name of the form
702       (LABELS <lfun> <fun>) or (FLET <lfun> <fun>) where <lfun> is the Labels/Flet
703       function in <fun>.
704    
705     TRACE causes a printout on *TRACE-OUTPUT* each time that one of the named     TRACE causes a printout on *TRACE-OUTPUT* each time that one of the named
706     functions is entered or returns (the Names are not evaluated.)  The output     functions is entered or returns (the Names are not evaluated.)  The output
707     is indented according to the number of pending traced calls, and this trace     is indented according to the number of pending traced calls, and this trace
# Line 667  Line 728 
728         nothing unless a call to one of those functions encloses the call to         nothing unless a call to one of those functions encloses the call to
729         this function (i.e. it would appear in a backtrace.)  Anonymous         this function (i.e. it would appear in a backtrace.)  Anonymous
730         functions have string names like \"DEFUN FOO\".         functions have string names like \"DEFUN FOO\".
731       :WHEREIN-ONLY Names
732           Like :WHEREIN, but only if the immediate caller is one of Names,
733           instead of being any where in a backtrace.
734    
735     :BREAK Form     :BREAK Form
736     :BREAK-AFTER Form     :BREAK-AFTER Form
# Line 717  Line 781 
781  ;;;    Untrace one function.  ;;;    Untrace one function.
782  ;;;  ;;;
783  (defun untrace-1 (function-or-name)  (defun untrace-1 (function-or-name)
784    (let* ((fun (trace-fdefinition function-or-name))    (multiple-value-bind (fun named kind local)
785           (info (gethash fun *traced-functions*)))        (trace-fdefinition function-or-name)
786      (cond ((not info)      (declare (ignore named kind))
787             (warn "Function is not TRACE'd -- ~S." function-or-name))      (let* ((key (or local fun))
788            (t             (info (gethash key *traced-functions*)))
789             (cond ((trace-info-encapsulated info)        (cond ((not info)
790                    (funwrap (trace-info-what info) :type 'trace))               (warn (intl:gettext "Function is not TRACE'd -- ~S.") function-or-name))
791                   (t              (t
792                    (di:delete-breakpoint (trace-info-start-breakpoint info))               (cond ((trace-info-encapsulated info)
793                    (di:delete-breakpoint (trace-info-end-breakpoint info))))                      (funwrap (trace-info-what info) :type 'trace))
794             (setf (trace-info-untraced info) t)                     (t
795             (remhash fun *traced-functions*)))))                      (di:delete-breakpoint (trace-info-start-breakpoint info))
796                        (di:delete-breakpoint (trace-info-end-breakpoint info))))
797                 (setf (trace-info-untraced info) t)
798                 (remhash key *traced-functions*))))))
799    
800  ;;; UNTRACE-ALL  --  Internal  ;;; UNTRACE-ALL  --  Internal
801  ;;;  ;;;

Legend:
Removed from v.1.28.12.2  
changed lines
  Added in v.1.48

  ViewVC Help
Powered by ViewVC 1.1.5