/[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.39 by rtoy, Thu Sep 13 04:11:44 2007 UTC revision 1.40 by rtoy, Thu Oct 18 22:26:08 2007 UTC
# Line 158  Line 158 
158  ;;; :FUNCALLABLE-INSTANCE.  ;;; :FUNCALLABLE-INSTANCE.
159  ;;;  ;;;
160  (defun trace-fdefinition (x)  (defun trace-fdefinition (x)
161    (multiple-value-bind (res named-p)    (multiple-value-bind (res named-p local)
162        (typecase x        (typecase x
163          (symbol          (symbol
164           (cond ((special-operator-p x)           (cond ((special-operator-p x)
# Line 169  Line 169 
169          (function x)          (function x)
170          ((cons (member flet labels))          ((cons (member flet labels))
171           ;; An extended function name for flet/labels functions.           ;; An extended function name for flet/labels functions.
172           (values x t))           (values (fdefinition (car (last x))) t x))
173          (t (values (fdefinition x) t)))          (t (values (fdefinition x) t)))
174      (if (eval:interpreted-function-p res)      (if (eval:interpreted-function-p res)
175          (values res named-p (if (eval:interpreted-function-closure res)          (values res named-p (if (eval:interpreted-function-closure res)
# Line 179  Line 179 
179             (values (kernel:%closure-function res) named-p :compiled-closure))             (values (kernel:%closure-function res) named-p :compiled-closure))
180            (#.vm:funcallable-instance-header-type            (#.vm:funcallable-instance-header-type
181             (values res named-p :funcallable-instance))             (values res named-p :funcallable-instance))
182            (t (values res named-p :compiled))))))            (t (values res named-p :compiled local))))))
183    
184    
185  ;;; TRACE-REDEFINED-UPDATE  --  Internal  ;;; TRACE-REDEFINED-UPDATE  --  Internal
# Line 189  Line 189 
189  ;;;  ;;;
190  (defun trace-redefined-update (fname new-value)  (defun trace-redefined-update (fname new-value)
191    (when (fboundp fname)    (when (fboundp fname)
192      (let* ((fun (trace-fdefinition fname))      (multiple-value-bind (fun named kind local)
193             (info (gethash fun *traced-functions*)))          (trace-fdefinition fname)
194        (when (and info (trace-info-named info))        (let* ((fkey (or local fun))
195          (untrace-1 fname)               (info (gethash fkey *traced-functions*)))
196          (trace-1 fname info new-value)))))          (flet ((handle-local-funs ()
197                     ;; FIXME: This is gross.  We need to grovel over the
198                     ;; *traced-functions* to see if any flet/labels functions
199                     ;; have been traced in the function we're redefining.
200                     (maphash #'(lambda (key info)
201                                  (when (and (listp key)
202                                             (eq fname (car (last key))))
203                                    (when info
204                                      (untrace-1 key)
205                                      (trace-1 key info new-value))))
206                              *traced-functions*)))
207              (when (and info (trace-info-named info))
208                (untrace-1 fname)
209                (trace-1 fname info new-value))
210              (handle-local-funs))))))
211    
212  ;;;  ;;;
213  (push #'trace-redefined-update ext:*setf-fdefinition-hook*)  (push #'trace-redefined-update ext:*setf-fdefinition-hook*)
214    
# Line 428  Line 443 
443  ;;; automatically retracing; this  ;;; automatically retracing; this
444  ;;;  ;;;
445  (defun trace-1 (function-or-name info &optional definition)  (defun trace-1 (function-or-name info &optional definition)
446    (multiple-value-bind (fun named kind)    (multiple-value-bind (fun named kind local)
447        (if definition      (if definition
448            (values definition t          ;; Tracing a new definition.  If function-or-name looks like a
449                    (nth-value 2 (trace-fdefinition definition)))          ;; local function, we trace the new definition with the local
450            ;; function.  Otherwise, we do what we used to do.
451            (if (and (valid-function-name-p function-or-name)
452                     (typep function-or-name '(cons (member flet labels))))
453                (multiple-value-bind (fun named kind)
454                    (trace-fdefinition definition)
455                  (values fun t kind function-or-name))
456                (values definition t
457                        (nth-value 2 (trace-fdefinition definition))))
458            (trace-fdefinition function-or-name))            (trace-fdefinition function-or-name))
459      (when (gethash fun *traced-functions*)      (when (gethash (or local fun) *traced-functions*)
460        (warn "Function ~S already TRACE'd, retracing it." function-or-name)        (warn "Function ~S already TRACE'd, retracing it." function-or-name)
461        (untrace-1 fun))        (untrace-1 fun))
462    
463      (let* ((debug-fun (di:function-debug-function fun))      (let* ((debug-fun (di:function-debug-function fun :local-name local))
464             (encapsulated             (encapsulated
465              (if (eq (trace-info-encapsulated info) :default)              (if (eq (trace-info-encapsulated info) :default)
466                  (let ((encapsulate-p                  (let ((encapsulate-p
# Line 517  Line 540 
540              (di:activate-breakpoint start)              (di:activate-breakpoint start)
541              (di:activate-breakpoint end)))))              (di:activate-breakpoint end)))))
542    
543        (setf (gethash fun *traced-functions*) info)))        (setf (gethash (or local fun) *traced-functions*) info)))
544    
545    function-or-name)    function-or-name)
546    
# Line 756  Line 779 
779  ;;;    Untrace one function.  ;;;    Untrace one function.
780  ;;;  ;;;
781  (defun untrace-1 (function-or-name)  (defun untrace-1 (function-or-name)
782    (let* ((fun (trace-fdefinition function-or-name))    (multiple-value-bind (fun named kind local)
783           (info (gethash fun *traced-functions*)))        (trace-fdefinition function-or-name)
784      (cond ((not info)      (declare (ignore named kind))
785             (warn "Function is not TRACE'd -- ~S." function-or-name))      (let* ((key (or local fun))
786            (t             (info (gethash key *traced-functions*)))
787             (cond ((trace-info-encapsulated info)        (cond ((not info)
788                    (funwrap (trace-info-what info) :type 'trace))               (warn "Function is not TRACE'd -- ~S." function-or-name))
789                   (t              (t
790                    (di:delete-breakpoint (trace-info-start-breakpoint info))               (cond ((trace-info-encapsulated info)
791                    (di:delete-breakpoint (trace-info-end-breakpoint info))))                      (funwrap (trace-info-what info) :type 'trace))
792             (setf (trace-info-untraced info) t)                     (t
793             (remhash fun *traced-functions*)))))                      (di:delete-breakpoint (trace-info-start-breakpoint info))
794                        (di:delete-breakpoint (trace-info-end-breakpoint info))))
795                 (setf (trace-info-untraced info) t)
796                 (remhash key *traced-functions*))))))
797    
798  ;;; UNTRACE-ALL  --  Internal  ;;; UNTRACE-ALL  --  Internal
799  ;;;  ;;;

Legend:
Removed from v.1.39  
changed lines
  Added in v.1.40

  ViewVC Help
Powered by ViewVC 1.1.5