From 620750d02da46b1f8c1aff4fbe08da9397b1206f Mon Sep 17 00:00:00 2001 From: rtoy <rtoy> Date: Thu, 18 Oct 2007 22:26:08 +0000 Subject: [PATCH] Slight reimplemention of how tracing of local functions is done. We don't do the hackish list-of-name to find local debug function anymore. This change allows us to retrace local functions when the function is redefined. code/debug-int.lisp: o Add :LOCAL-NAME keyword parameter to tell us to look for the local function within the given FUN. The bizarre hack using a list as the FUN to do this is now gone. code/ntrace.lisp: o Change TRACE-FDEFINITION to return a fourth value if the function is a local function. The fourth value is the name of the local function. o TRACE-1 recognizes the extra value from TRACE-FDEFINITION to determine if this is a local function that needs to be traced. Also, if DEFINITION is given, we process that carefully so we can trace the new definition with a local function. o UNTRACE-1 likewise updated to recognize and handle local functions. o TRACE-REFINED-UPDATE modified so that when a function is redefined, we retrace the function itself if it was traced (as before). But we also look through the traced functions to see if we need to retrace the local definitions in this new function. --- code/debug-int.lisp | 40 ++++++---------------- code/ntrace.lisp | 82 +++++++++++++++++++++++++++++---------------- 2 files changed, 64 insertions(+), 58 deletions(-) diff --git a/code/debug-int.lisp b/code/debug-int.lisp index 92a18efdf..53ff9486e 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 e481afa0d..72e9b6e95 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 ;;; -- GitLab