From d517659e44c8a9b7c1ae15eb5d08c44fb2f70723 Mon Sep 17 00:00:00 2001
From: gerd <gerd>
Date: Thu, 15 May 2003 11:24:34 +0000
Subject: [PATCH] 	Functions used in the implementation of TRACE can be
 traced using 	encapsulation.  Use encapsulation for functions from a given
 list 	of packages to automate this.

	* src/code/ntrace.lisp (*trace-encapsulate-package-names*): New
	variable.
	(trace-call): Temporarily restore the unencapsulated definition of
	the function.
	(encapsulate-by-package-p): New function.
	(trace-1): Use it.

	* src/code/exports.lisp ("DEBUG"): Export
	*trace-encapsulate-package-names*.

	* src/docs/cmu-user/debugger.tex (section{Function Tracing}):
	Add *trace-encapsulate-package-names*.
---
 code/exports.lisp            |  3 +-
 code/ntrace.lisp             | 85 +++++++++++++++++++++++++-----------
 docs/cmu-user/debugger.tex   |  8 ++++
 general-info/release-19a.txt |  3 ++
 4 files changed, 72 insertions(+), 27 deletions(-)

diff --git a/code/exports.lisp b/code/exports.lisp
index c1dca5c90..e6a05f169 100644
--- a/code/exports.lisp
+++ b/code/exports.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/exports.lisp,v 1.209 2003/05/14 13:22:16 toy Exp $")
+  "$Header: /Volumes/share2/src/cmucl/cvs2git/cvsroot/src/code/exports.lisp,v 1.210 2003/05/15 11:24:34 gerd Exp $")
 ;;;
 ;;; **********************************************************************
 ;;;
@@ -906,6 +906,7 @@
 	     "*ONLY-BLOCK-START-LOCATIONS*" "*STACK-TOP-HINT*"
 	     "*TRACE-VALUES*" "DO-DEBUG-COMMAND"
 	     "*TRACE-ENCAPSULATE-DEFAULT*"
+	     "*TRACE-ENCAPSULATE-PACKAGE-NAMES*"
 	     "*DEFAULT-PRINT-FRAME-CALL-VERBOSITY*"))
 
 (intern "CHAR" "LISP")
diff --git a/code/ntrace.lisp b/code/ntrace.lisp
index 569eef6b3..fe50b29fe 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.22 2003/05/11 08:57:13 gerd Exp $")
+  "$Header: /Volumes/share2/src/cmucl/cvs2git/cvsroot/src/code/ntrace.lisp,v 1.23 2003/05/15 11:24:34 gerd Exp $")
 ;;;
 ;;; **********************************************************************
 ;;;
@@ -21,7 +21,8 @@
 
 (in-package "DEBUG")
 
-(export '(*trace-values* *max-trace-indentation* *trace-encapsulate-default*))
+(export '(*trace-values* *max-trace-indentation* *trace-encapsulate-default*
+	  *trace-encapsulate-package-names*))
 
 (defvar *trace-values* nil
   "This is bound to the returned values when evaluating :BREAK-AFTER and
@@ -34,6 +35,21 @@
 (defvar *trace-encapsulate-default* :default
   "The default value for the :ENCAPSULATE option to trace.")
 
+(defvar *trace-encapsulate-package-names*
+  '("COMMON-LISP"
+    "CONDITIONS"
+    "DEBUG"
+    "EXTENSIONS"
+    "FORMAT"
+    "KERNEL"
+    "LOOP"
+    "PRETTY-PRINT"
+    "SYSTEM"
+    "TRACE")
+  "List of package names.  Encapsulate functions from these packages
+   by default.  This should at least include the packages of functions
+   used by TRACE, directly or indirectly.")
+
 
 ;;;; Internal state:
 
@@ -361,19 +377,21 @@
 ;;; we have cleverly contrived to work for our hook functions.
 ;;;
 (defun trace-call (info)
-  (multiple-value-bind
-      (start cookie)
-      (trace-start-breakpoint-fun info)
-    (let ((frame (di:frame-down (di:top-frame))))
-      (funcall start frame nil)
-      (let ((*traced-entries* *traced-entries*))
-	(declare (special basic-definition argument-list))
-	(funcall cookie frame nil)
-	(let ((vals
-	       (multiple-value-list
-		(apply basic-definition argument-list))))
-	  (funcall (trace-end-breakpoint-fun info) frame nil vals nil)
-	  (values-list vals))))))
+  (let* ((name (trace-info-what info))
+	 (fdefn (lisp::fdefinition-object name nil)))
+    (letf (((lisp::fdefn-function fdefn) (fdefinition name)))
+      (multiple-value-bind (start cookie)
+	  (trace-start-breakpoint-fun info)
+	(let ((frame (di:frame-down (di:top-frame))))
+	  (funcall start frame nil)
+	  (let ((*traced-entries* *traced-entries*))
+	    (declare (special basic-definition argument-list))
+	    (funcall cookie frame nil)
+	    (let ((vals
+		   (multiple-value-list
+		    (apply basic-definition argument-list))))
+	      (funcall (trace-end-breakpoint-fun info) frame nil vals nil)
+	      (values-list vals))))))))
 
 
 ;;; TRACE-1 -- Internal.
@@ -396,19 +414,22 @@
       (untrace-1 fun))
     
     (let* ((debug-fun (di:function-debug-function fun))
-	   (end-breakpoint-p (di::can-set-function-end-breakpoint-p debug-fun))
 	   (encapsulated
 	    (if (eq (trace-info-encapsulated info) :default)
-		(ecase kind
-		  (:compiled (not end-breakpoint-p))
-		  (:compiled-closure
-		   (unless (functionp function-or-name)
-		     (warn "Tracing shared code for ~S:~%  ~S"
-			   function-or-name fun))
-		   (not end-breakpoint-p))
-		  ((:interpreted :interpreted-closure
-				 :funcallable-instance)
-		   t))
+		(let ((encapsulate-p
+		       (or (di::can-set-function-end-breakpoint-p debug-fun)
+			   (encapsulate-by-package-p function-or-name))))
+		  (ecase kind
+		    (:compiled
+		     encapsulate-p)
+		    (:compiled-closure
+		     (unless (functionp function-or-name)
+		       (warn "Tracing shared code for ~S:~%  ~S"
+			     function-or-name fun))
+		     encapsulate-p)
+		    ((:interpreted :interpreted-closure
+				   :funcallable-instance)
+		     t)))
 		(trace-info-encapsulated info)))
 	   (loc (if encapsulated
 		    :encapsulated
@@ -464,6 +485,18 @@
 
   function-or-name)
 
+;;;
+;;; Return true if FUNCTION-OR-NAME's package indicates that TRACE
+;;; should use encapsulation instead of function-end breakpoints.
+;;;
+(defun encapsulate-by-package-p (function-or-name)
+  (multiple-value-bind (valid block)
+      (valid-function-name-p function-or-name)
+    (when (and valid (symbolp block))
+      (let* ((pkg (symbol-package block))
+	     (pkg-name (and pkg (package-name pkg))))
+	(member pkg-name *trace-encapsulate-package-names* :test #'equal)))))
+
 
 ;;;; The TRACE macro:
 
diff --git a/docs/cmu-user/debugger.tex b/docs/cmu-user/debugger.tex
index 54438e024..8494cbcfa 100644
--- a/docs/cmu-user/debugger.tex
+++ b/docs/cmu-user/debugger.tex
@@ -1126,6 +1126,14 @@ function entry or exit.
   printout.  This variable is initially set to 40.
 \end{defvar}
 
+\begin{defvar}{debug:}{trace-encapsulate-package-names}
+  
+  A list of package names.  Functions from these packages are traced
+  using encapsulation instead of function-end breakpoints.  This list
+  should at least include those packages containing functions used
+  directly or indirectly in the implementation of \code{trace}.
+\end{defvar}
+
 
 \subsection{Encapsulation Functions}
 \cindex{encapsulation}
diff --git a/general-info/release-19a.txt b/general-info/release-19a.txt
index 703b78f5a..9e92a15d4 100644
--- a/general-info/release-19a.txt
+++ b/general-info/release-19a.txt
@@ -41,6 +41,9 @@ New in this release:
        breakpoints cannot be used.
      - INSPECT working on CLOS instances.
      - Callbacks from foreign code to Lisp.
+     - Functions like GETHASH that are used in the implementation of 
+       TRACE can now be traced.  See also
+       DEBUG:*TRACE-ENCAPSULATE-PACKAGE-NAMES*.
 
   * Numerous ANSI compliance fixes:
      - Many bugs in CMUCL's type system detected by Paul Dietz'
-- 
GitLab