diff --git a/code/debug-int.lisp b/code/debug-int.lisp index 92a18efdf1a6e10472c369eca1834997a9f684d1..53ff9486ea9148d87c870b3040f6db0a74613822 100644 --- a/code/debug-int.lisp +++ b/code/debug-int.lisp @@ -5,7 +5,7 @@ ;;; Carnegie Mellon University, and has been placed in the public domain. ;;; (ext:file-comment - "$Header: /Volumes/share2/src/cmucl/cvs2git/cvsroot/src/code/debug-int.lisp,v 1.129 2007/10/02 15:21:26 rtoy Exp $") + "$Header: /Volumes/share2/src/cmucl/cvs2git/cvsroot/src/code/debug-int.lisp,v 1.130 2007/10/18 22:26:08 rtoy Exp $") ;;; ;;; ********************************************************************** ;;; @@ -1923,7 +1923,9 @@ The result is a symbol or nil if the routine cannot be found." ;;; FUNCTION-DEBUG-FUNCTION -- Public. ;;; -(defun function-debug-function (fun) +;;; If LOCAL-NAME is given, try to return the debug function for the +;;; local function (labels or flet). +(defun function-debug-function (fun &key local-name) "Returns a debug-function that represents debug information for function." (case (get-type fun) (#.vm:closure-header-type @@ -1936,12 +1938,15 @@ The result is a symbol or nil if the routine cannot be found." (t (function-debug-function (funcallable-instance-function fun))))) ((#.vm:function-header-type #.vm:closure-function-header-type) - (let* ((name (kernel:%function-name fun)) + (let* ((name (if (and local-name + (valid-function-name-p local-name)) + local-name + (kernel:%function-name fun))) (component (kernel:function-code-header fun)) (res (find-if #'(lambda (x) (and (c::compiled-debug-function-p x) - (eq (c::compiled-debug-function-name x) name) + (equal (c::compiled-debug-function-name x) name) (eq (c::compiled-debug-function-kind x) nil))) (get-debug-info-function-map (kernel:%code-debug-info component))))) @@ -1955,32 +1960,7 @@ The result is a symbol or nil if the routine cannot be found." (debug-function-from-pc component (* (- (kernel:function-word-offset fun) (kernel:get-header-data component)) - vm:word-bytes))))) - (#.vm:list-pointer-type - ;; FIXME: Kind of gross, but this is how we recognize LABELS/FLET - ;; functions: we're given a list of the function name. - (unless (valid-function-name-p fun) - (error "Invalid function name: ~A~%" fun)) - (let* ((external (fdefinition (car (last fun)))) - (component (kernel:function-code-header external)) - (res - ;; Look through all the debug functions until we find one - ;; that matches our name. - (find-if - #'(lambda (x) - (and (c::compiled-debug-function-p x) - (equal (c::compiled-debug-function-name x) fun) - (eq (c::compiled-debug-function-kind x) nil))) - (get-debug-info-function-map - (kernel:%code-debug-info component))))) - (if res - (make-compiled-debug-function res - (kernel:function-code-header external)) - (if (and (listp fun) - (member (car fun) '(flet labels))) - (error "No such function ~A. ~ - Perhaps it has been inlined?~%" fun) - (error "No such function ~A.~%" fun))))))) + vm:word-bytes))))))) ;;; DEBUG-FUNCTION-KIND -- Public. diff --git a/code/ntrace.lisp b/code/ntrace.lisp index e481afa0db1bcd902882c69e5cbd70cf7e64c56c..72e9b6e95aa0c58a5d1c488836bf26c9699775d3 100644 --- a/code/ntrace.lisp +++ b/code/ntrace.lisp @@ -5,7 +5,7 @@ ;;; Carnegie Mellon University, and has been placed in the public domain. ;;; (ext:file-comment - "$Header: /Volumes/share2/src/cmucl/cvs2git/cvsroot/src/code/ntrace.lisp,v 1.39 2007/09/13 04:11:44 rtoy Exp $") + "$Header: /Volumes/share2/src/cmucl/cvs2git/cvsroot/src/code/ntrace.lisp,v 1.40 2007/10/18 22:26:08 rtoy Exp $") ;;; ;;; ********************************************************************** ;;; @@ -158,7 +158,7 @@ ;;; :FUNCALLABLE-INSTANCE. ;;; (defun trace-fdefinition (x) - (multiple-value-bind (res named-p) + (multiple-value-bind (res named-p local) (typecase x (symbol (cond ((special-operator-p x) @@ -169,7 +169,7 @@ (function x) ((cons (member flet labels)) ;; An extended function name for flet/labels functions. - (values x t)) + (values (fdefinition (car (last x))) t x)) (t (values (fdefinition x) t))) (if (eval:interpreted-function-p res) (values res named-p (if (eval:interpreted-function-closure res) @@ -179,7 +179,7 @@ (values (kernel:%closure-function res) named-p :compiled-closure)) (#.vm:funcallable-instance-header-type (values res named-p :funcallable-instance)) - (t (values res named-p :compiled)))))) + (t (values res named-p :compiled local)))))) ;;; TRACE-REDEFINED-UPDATE -- Internal @@ -189,11 +189,26 @@ ;;; (defun trace-redefined-update (fname new-value) (when (fboundp fname) - (let* ((fun (trace-fdefinition fname)) - (info (gethash fun *traced-functions*))) - (when (and info (trace-info-named info)) - (untrace-1 fname) - (trace-1 fname info new-value))))) + (multiple-value-bind (fun named kind local) + (trace-fdefinition fname) + (let* ((fkey (or local fun)) + (info (gethash fkey *traced-functions*))) + (flet ((handle-local-funs () + ;; FIXME: This is gross. We need to grovel over the + ;; *traced-functions* to see if any flet/labels functions + ;; have been traced in the function we're redefining. + (maphash #'(lambda (key info) + (when (and (listp key) + (eq fname (car (last key)))) + (when info + (untrace-1 key) + (trace-1 key info new-value)))) + *traced-functions*))) + (when (and info (trace-info-named info)) + (untrace-1 fname) + (trace-1 fname info new-value)) + (handle-local-funs)))))) + ;;; (push #'trace-redefined-update ext:*setf-fdefinition-hook*) @@ -428,16 +443,24 @@ ;;; automatically retracing; this ;;; (defun trace-1 (function-or-name info &optional definition) - (multiple-value-bind (fun named kind) - (if definition - (values definition t - (nth-value 2 (trace-fdefinition definition))) + (multiple-value-bind (fun named kind local) + (if definition + ;; Tracing a new definition. If function-or-name looks like a + ;; local function, we trace the new definition with the local + ;; function. Otherwise, we do what we used to do. + (if (and (valid-function-name-p function-or-name) + (typep function-or-name '(cons (member flet labels)))) + (multiple-value-bind (fun named kind) + (trace-fdefinition definition) + (values fun t kind function-or-name)) + (values definition t + (nth-value 2 (trace-fdefinition definition)))) (trace-fdefinition function-or-name)) - (when (gethash fun *traced-functions*) + (when (gethash (or local fun) *traced-functions*) (warn "Function ~S already TRACE'd, retracing it." function-or-name) (untrace-1 fun)) - (let* ((debug-fun (di:function-debug-function fun)) + (let* ((debug-fun (di:function-debug-function fun :local-name local)) (encapsulated (if (eq (trace-info-encapsulated info) :default) (let ((encapsulate-p @@ -517,7 +540,7 @@ (di:activate-breakpoint start) (di:activate-breakpoint end))))) - (setf (gethash fun *traced-functions*) info))) + (setf (gethash (or local fun) *traced-functions*) info))) function-or-name) @@ -756,18 +779,21 @@ ;;; Untrace one function. ;;; (defun untrace-1 (function-or-name) - (let* ((fun (trace-fdefinition function-or-name)) - (info (gethash fun *traced-functions*))) - (cond ((not info) - (warn "Function is not TRACE'd -- ~S." function-or-name)) - (t - (cond ((trace-info-encapsulated info) - (funwrap (trace-info-what info) :type 'trace)) - (t - (di:delete-breakpoint (trace-info-start-breakpoint info)) - (di:delete-breakpoint (trace-info-end-breakpoint info)))) - (setf (trace-info-untraced info) t) - (remhash fun *traced-functions*))))) + (multiple-value-bind (fun named kind local) + (trace-fdefinition function-or-name) + (declare (ignore named kind)) + (let* ((key (or local fun)) + (info (gethash key *traced-functions*))) + (cond ((not info) + (warn "Function is not TRACE'd -- ~S." function-or-name)) + (t + (cond ((trace-info-encapsulated info) + (funwrap (trace-info-what info) :type 'trace)) + (t + (di:delete-breakpoint (trace-info-start-breakpoint info)) + (di:delete-breakpoint (trace-info-end-breakpoint info)))) + (setf (trace-info-untraced info) t) + (remhash key *traced-functions*)))))) ;;; UNTRACE-ALL -- Internal ;;;