From e9211546b9f7a0b862aa0665ff57701be143f533 Mon Sep 17 00:00:00 2001
From: gerd <gerd>
Date: Fri, 23 May 2003 13:34:05 +0000
Subject: [PATCH] 	Add fwrappers.  Rewrite TRACE and PROFILE to use
 fwrappers. 	To bootstrap, use boot12.lisp with pmai's scripts.

	* src/bootfiles/18e/boot12.lisp: New file.

	* src/tools/worldload.lisp, src/tools/worldcom.lisp:
	* src/tools/worldbuild.lisp: Add code:fwrappers.

	* src/docs/cmu-user/extensions.tex (Function Wrappers):
	New section.

	* src/code/fwrappers.lisp: New file.

	* src-fw/pcl/defs.lisp (gdefinition): Don't check for profiled
	functions.

	* src-fw/code/exports.lisp: Add walker and fwrappers.

	* src-fw/code/fdefinition.lisp (fdefn-init): Set
	*valid-function-names* to nil.
	(encapsulation): Structure removed.
	(do-encapsulations, encapsulation, last-encapsulation)
	(push-encapsulation, encapsulate, unencapsulate, encapsulated-p):
	Removed.  There is a compatibility layer in fwrappers.lisp.
	(fdefinition, %set-fdefinition): Rewritten.

	* src/code/profile.lisp: Remove #+cmu and #-cmu.
	("PROFILE"): Use fwrappers.
	(*profile-info*): Removed.
	(profile-info): Redefined.
	(*existing-encapsulations*): Removed.
	(reset-profile-info, profile-info-profiling-values): New functions.
	(make-profile-encapsulation): Removed.
	(profile): New function name syntax.
	(make-profile-fwrapper-name, make-profile-fwrapper): New functions.
	(def-profile-fwrapper): Precompute some fwrappers.
	(ensure-profile-fwrapper, find-profile-fwrapper, pi-or-lose):
	New functions.
	(profile-1-function): Rewritten.
	(unprofile-1-function): Ditto.
	(re-profile-redefined-function): New function.
	(toplevel): Push it on *setf-fdefinition-hook*.

	* src/code/ntrace.lisp (trace-call): Removed.
	(trace-fwrapper): New fwrapper.
	(trace-1): Use fwrap instead of encapsulate.
	(untrace-1): Use funwrap instead of unencapsulate.
---
 bootfiles/18e/boot12.lisp    |  40 +++
 code/exports.lisp            |  37 +-
 code/fdefinition.lisp        |  98 +-----
 code/ntrace.lisp             |  32 +-
 code/profile.lisp            | 655 ++++++++++++++++-------------------
 docs/cmu-user/extensions.tex | 144 ++++++++
 general-info/release-19a.txt |   8 +-
 pcl/defs.lisp                |   7 +-
 tools/worldbuild.lisp        |   3 +-
 tools/worldcom.lisp          |   3 +-
 tools/worldload.lisp         |   3 +-
 11 files changed, 566 insertions(+), 464 deletions(-)
 create mode 100644 bootfiles/18e/boot12.lisp

diff --git a/bootfiles/18e/boot12.lisp b/bootfiles/18e/boot12.lisp
new file mode 100644
index 000000000..70b14498e
--- /dev/null
+++ b/bootfiles/18e/boot12.lisp
@@ -0,0 +1,40 @@
+;;;
+;;; Boot file for adding fwrappers, and making TRACE and PROFILE
+;;; use fwrappers.  To bootstrap, copy this file to target:bootstrap.lisp
+;;; using Pierre Mai's build scripts, and do a full build.
+;;;
+
+(in-package :user)
+
+;;;
+;;; Move FDEFN-OR-LOSE to KERNEL and export it from there.
+;;;
+(setf (fdefinition 'kernel::fdefn-or-lose)
+      (fdefinition 'lisp::fdefn-or-lose))
+(unintern 'cl::fdefn-or-lose :cl)
+(export 'kernel::fdefn-or-lose :kernel)
+
+
+(in-package :profile)
+
+(defmacro defstruct! (name &rest stuff)
+  `(handler-bind ((error (lambda (c)
+			   (declare (ignore c))
+			   (invoke-restart 'kernel::clobber-it))))
+     (defstruct ,name ,@stuff)))
+
+(defstruct! (profile-info
+	     (:conc-name pi-)
+	     (:constructor make-profile-info (function-name callers-p)))
+  function-name
+  (callers-p nil :type boolean)
+  (count 0 :type fixnum)
+  (time 0 :type time-type)
+  (consed-h 0 :type dfixnum:dfparttype)
+  (consed-l 0 :type dfixnum:dfparttype)
+  (consed-w/c-h 0 :type dfixnum:dfparttype)
+  (consed-w/c-l 0 :type dfixnum:dfparttype)
+  (profile 0 :type integer)
+  (callers () :type list))
+
+;;; end of file
diff --git a/code/exports.lisp b/code/exports.lisp
index af5a44162..264270afc 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.211 2003/05/20 20:08:05 gerd Exp $")
+  "$Header: /Volumes/share2/src/cmucl/cvs2git/cvsroot/src/code/exports.lisp,v 1.212 2003/05/23 13:34:05 gerd Exp $")
 ;;;
 ;;; **********************************************************************
 ;;;
@@ -1719,6 +1719,7 @@
 	   "VALUES-TYPES" "VALUES-TYPES-INTERSECT" "VOID"
 	   "WITH-CIRCULARITY-DETECTION" "WRONG-NUMBER-OF-INDICES-ERROR"
 	   "FDEFN" "MAKE-FDEFN" "FDEFN-P" "FDEFN-NAME" "FDEFN-FUNCTION"
+	   "FDEFN-OR-LOSE"
 	   "FDEFN-MAKUNBOUND" "%COERCE-TO-FUNCTION" "FUNCTION-SUBTYPE"
 	   "*MAXIMUM-ERROR-DEPTH*" "%SET-SYMBOL-PLIST"
 	   "INFINITE-ERROR-PROTECT"
@@ -1828,3 +1829,37 @@
 	   "PROCESS-WHOSTATE" "PROCESS-YIELD" "PROCESSP" "RESTART-PROCESS" 
 	   "SHOW-PROCESSES" "STACK-GROUP-RESUME" "WITHOUT-SCHEDULING"
 	   "WITH-LOCK-HELD" "WITH-TIMEOUT"))
+
+(defpackage "WALKER"
+  (:use "COMMON-LISP" "EXT")
+  (:export "DEFINE-WALKER-TEMPLATE"
+	   "WALK-FORM"
+	   "WALK-FORM-EXPAND-MACROS-P"
+	   "NESTED-WALK-FORM"
+	   "VARIABLE-LEXICAL-P"
+	   "VARIABLE-SPECIAL-P"
+	   "VARIABLE-GLOBALLY-SPECIAL-P"
+	   "*VARIABLE-DECLARATIONS*"
+	   "VARIABLE-DECLARATION"
+	   "MACROEXPAND-ALL"))
+
+(defpackage "FWRAPPERS"
+  (:use "COMMON-LISP" "EXT" "KERNEL")
+  (:export "DEFINE-FWRAPPER"
+	   "FWRAPPER"
+	   "CALL-NEXT-FUNCTION"
+	   "FWRAP"
+	   "FUNWRAP"
+	   "FIND-FWRAPPER"
+	   "FWRAPPER-TYPE" "FWRAPPER-NEXT" "FWRAPPER-USER-DATA"
+	   "FWRAPPER-CONSTRUCTOR"
+	   "UPDATE-FWRAPPER" "UPDATE-FWRAPPERS"
+	   "SET-FWRAPPERS"
+	   "LIST-FWRAPPERS"
+	   "PUSH-FWRAPPER"
+	   "DELETE-FWRAPPER"
+	   "LAST-FWRAPPER"
+	   "DO-FWRAPPERS"
+	   ))
+
+
diff --git a/code/fdefinition.lisp b/code/fdefinition.lisp
index df5990aeb..a1815eae5 100644
--- a/code/fdefinition.lisp
+++ b/code/fdefinition.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/fdefinition.lisp,v 1.23 2003/05/17 11:06:29 gerd Exp $")
+  "$Header: /Volumes/share2/src/cmucl/cvs2git/cvsroot/src/code/fdefinition.lisp,v 1.24 2003/05/23 13:34:05 gerd Exp $")
 ;;;
 ;;; **********************************************************************
 ;;;
@@ -29,7 +29,7 @@
 (in-package "KERNEL")
 
 (export '(fdefn make-fdefn fdefn-p fdefn-name fdefn-function fdefn-makunbound
-	  %coerce-to-function raw-definition))
+	  fdefn-or-lose %coerce-to-function raw-definition))
 
 
 (in-package "LISP")
@@ -138,6 +138,7 @@
 (defvar *initial-fdefn-objects*)
 
 (defun fdefn-init ()
+  (setq *valid-function-names* nil)
   (dolist (fdefn *initial-fdefn-objects*)
     (setf (info function definition (fdefn-name fdefn)) fdefn))
   (makunbound '*initial-fdefn-objects*))
@@ -192,91 +193,6 @@
   (let ((fdefn (fdefinition-object name t)))
     (setf (fdefn-function fdefn) function)))
 
-
-
-;;;; Definition Encapsulation.
-
-(defstruct (encapsulation
-	    (:alternate-metaclass funcallable-instance
-				  funcallable-structure-class
-				  make-funcallable-structure-class)
-	    (:type funcallable-structure))
-  ;;
-  ;; Something like the symbol TRACE for an encapsulation done
-  ;; by TRACE, for instance.
-  type
-  ;;
-  ;; The function definition before this encapsulation was added.
-  (next #'null :type function))
-
-(defmacro do-encapsulations ((var fdefn &optional result) &body body)
-  "Evaluate BODY with VAR bound to consecutive encapsulations of
-   FDEFN.  Return RESULT at the end."
-  `(loop for ,var = (encapsulation (fdefn-function ,fdefn))
-	 then (encapsulation (encapsulation-next ,var))
-	 while ,var do (locally ,@body)
-	 finally (return ,result)))
-
-(defun encapsulation (fun)
-  "Return FUN if it is an encapsulation or NIL if it isn't."
-  (and (functionp fun)
-       ;; Necessary for cold-load reasons.
-       (= (get-type fun) vm:funcallable-instance-header-type)
-       (encapsulation-p fun)
-       fun))
-
-(declaim (inline last-encapsulation))
-(defun last-encapsulation (fdefn)
-  "Return tha last encapsulation of FDEFN or NIL if none."
-  (declare (type fdefn fdefn))
-  (do-encapsulations (e fdefn)
-    (when (null (encapsulation (encapsulation-next e)))
-      (return e))))
-
-(defun push-encapsulation (e name)
-  "Prepend encapsulation E to the definition of NAME.
-   Signal an error if NAME is an undefined function."
-  (declare (type encapsulation e))
-  (let ((fdefn (fdefn-or-lose name)))
-    (setf (encapsulation-next e) (fdefn-function fdefn))
-    (setf (fdefn-function fdefn) e)))
-
-(defun encapsulate (name type body)
-  "Replace the definition of NAME with a function that binds NAME's
-   arguments to a variable named ARGUMENT-LIST, binds NAME's
-   definition to a variable named BASIC-DEFINITION, and evaluates BODY
-   in that context.  TYPE is whatever you would like to associate with
-   this encapsulation for identification in case you need multiple
-   encapsulations of the same name."
-  (let ((e (make-encapsulation :type type)))
-    (setf (funcallable-instance-function e)
-	  #'(instance-lambda (&rest argument-list)
-	      (declare (special argument-list))
-	      (let ((basic-definition (encapsulation-next e)))
-		(declare (special basic-definition))
-		(eval body))))
-    (push-encapsulation e name)))
-
-(defun unencapsulate (name type)
-  "Remove the first encapsulation of type TYPE, if any, from the
-  definition of NAME."
-  (let ((fdefn (fdefinition-object name nil))
-	(prev nil))
-    (do-encapsulations (e fdefn)
-      (when (eq (encapsulation-type e) type)
-	(if prev
-	    (setf (encapsulation-next prev) (encapsulation-next e))
-	    (setf (fdefn-function fdefn) (encapsulation-next e)))
-	  (return))
-      (setq prev e))))
-
-(defun encapsulated-p (name type)
-  "Return true if NAME has an encapsulation of type TYPE."
-  (do-encapsulations (e (fdefinition-object name nil))
-    (when (eq (encapsulation-type e) type)
-      (return t))))
-
-
 
 ;;;; FDEFINITION.
 
@@ -285,9 +201,9 @@
    encapsulations and to return the innermost encapsulated definition.
    This is SETF'able."
   (let* ((fdefn (fdefn-or-lose name))
-	 (last (last-encapsulation fdefn)))
+	 (last (fwrappers:last-fwrapper fdefn)))
       (if last
-	  (encapsulation-next last)
+	  (fwrappers:fwrapper-next last)
 	  (fdefn-function fdefn))))
 
 (defvar *setf-fdefinition-hook* nil
@@ -301,9 +217,9 @@
     (when (boundp '*setf-fdefinition-hook*)
       (dolist (f *setf-fdefinition-hook*)
 	(funcall f name new-value)))
-    (let ((last (last-encapsulation fdefn)))
+    (let ((last (fwrappers:last-fwrapper fdefn)))
       (if last
-	  (setf (encapsulation-next last) new-value)
+	  (setf (fwrappers:fwrapper-next last) new-value)
 	  (setf (fdefn-function fdefn) new-value)))))
 
 (defsetf fdefinition %set-fdefinition)
diff --git a/code/ntrace.lisp b/code/ntrace.lisp
index 0eb61fe54..ab7e8afbb 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.24 2003/05/15 12:28:56 gerd Exp $")
+  "$Header: /Volumes/share2/src/cmucl/cvs2git/cvsroot/src/code/ntrace.lisp,v 1.25 2003/05/23 13:34:04 gerd Exp $")
 ;;;
 ;;; **********************************************************************
 ;;;
@@ -24,6 +24,8 @@
 (export '(*trace-values* *max-trace-indentation* *trace-encapsulate-default*
 	  *trace-encapsulate-package-names*))
 
+(use-package :fwrappers)
+
 (defvar *trace-values* nil
   "This is bound to the returned values when evaluating :BREAK-AFTER and
    :PRINT-AFTER forms.")
@@ -370,26 +372,27 @@
 			     "after" frame)))))
 
 
-;;; TRACE-CALL  --  Internal
+;;; TRACE-FWRAPPER  --  Internal
 ;;;
 ;;;    This function is called by the trace encapsulation.  It calls the
 ;;; breakpoint hook functions with NIL for the breakpoint and cookie, which
 ;;; we have cleverly contrived to work for our hook functions.
 ;;;
-(defun trace-call (info)
-  (let* ((name (trace-info-what info))
-	 (fdefn (lisp::fdefinition-object name nil)))
-    (letf (((lisp::fdefn-function fdefn) (fdefinition name)))
+(define-fwrapper trace-fwrapper (&rest args)
+  (let* ((info (fwrapper-user-data fwrapper))
+	 (name (trace-info-what info))
+	 (fdefn (lisp::fdefinition-object name nil))
+	 (basic-definition (fwrapper-next fwrapper))
+	 (argument-list args))
+    (declare (special basic-definition argument-list))
+    (letf (((lisp::fdefn-function fdefn) basic-definition))
       (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))))
+	    (let ((vals (multiple-value-list (call-next-function))))
 	      (funcall (trace-end-breakpoint-fun info) frame nil vals nil)
 	      (values-list vals))))))))
 
@@ -459,8 +462,8 @@
 	(unless named
 	  (error "Can't use encapsulation to trace anonymous function ~S."
 		 fun))
-	(without-package-locks
-	 (encapsulate function-or-name 'trace `(trace-call ',info))))
+	(fwrap function-or-name #'trace-fwrapper :type 'trace
+	       :user-data info))
        (t
 	(multiple-value-bind
 	    (start-fun cookie-fun)
@@ -636,7 +639,7 @@
        evaluates to true at the time of the call.  :CONDITION-AFTER is
        similar, but suppresses the initial printout, and is tested when the
        function returns.  :CONDITION-ALL tries both before and after.
-
+p
    :WHEREIN Names
        If specified, Names is a function name or list of names.  TRACE does
        nothing unless a call to one of those functions encloses the call to
@@ -698,8 +701,7 @@
 	   (warn "Function is not TRACE'd -- ~S." function-or-name))
 	  (t
 	   (cond ((trace-info-encapsulated info)
-		  (without-package-locks
-		   (unencapsulate (trace-info-what info) 'trace)))
+		  (funwrap (trace-info-what info) :type 'trace))
 		 (t
 		  (di:delete-breakpoint (trace-info-start-breakpoint info))
 		  (di:delete-breakpoint (trace-info-end-breakpoint info))))
diff --git a/code/profile.lisp b/code/profile.lisp
index b6ed4bd01..39653603b 100644
--- a/code/profile.lisp
+++ b/code/profile.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/profile.lisp,v 1.35 2003/05/15 12:28:56 gerd Exp $")
+  "$Header: /Volumes/share2/src/cmucl/cvs2git/cvsroot/src/code/profile.lisp,v 1.36 2003/05/23 13:34:04 gerd Exp $")
 ;;;
 ;;; **********************************************************************
 ;;;
@@ -32,7 +32,7 @@
 ;;;
 
 (defpackage "PROFILE"
-  (:use :common-lisp :ext)
+  (:use :common-lisp :ext :fwrappers)
   (:export *timed-functions* profile profile-all unprofile reset-time 
 	   report-time report-time-custom *default-report-time-printfunction*
 	   with-spacereport print-spacereports reset-spacereports
@@ -44,36 +44,21 @@
 
 ;;;; Implementation dependent interfaces:
 
-
-(progn
-  #-cmu
-  (eval-when (compile eval)
-    (warn
-     "You may want to supply an implementation-specific ~
-     Quickly-Get-Time function."))
-
-  ;; In CMUCL, get-internal-run-time is good enough, so we just use it.
-
-  (defconstant quick-time-units-per-second internal-time-units-per-second)
+(defconstant quick-time-units-per-second internal-time-units-per-second)
   
-  (defmacro quickly-get-time ()
-    `(the time-type (get-internal-run-time))))
-
+(defmacro quickly-get-time ()
+  `(the time-type (get-internal-run-time)))
 
+;;;
 ;;; The type of the result from quickly-get-time.
-#+cmu
+;;;
 (deftype time-type () '(unsigned-byte 29))
-#-cmu
-(deftype time-type () 'unsigned-byte)
 
-
-;;; To avoid unnecessary consing in the "encapsulation" code, we find out the
-;;; number of required arguments, and use &rest to capture only non-required
-;;; arguments.  The function Required-Arguments returns two values: the first
-;;; is the number of required arguments, and the second is T iff there are any
-;;; non-required arguments (e.g. &optional, &rest, &key).
-
-#+cmu 
+;;; 
+;;; Return two values: the first is the number of required arguments,
+;;; and the second is T iff NAME has any non-required arguments
+;;; (e.g. &OPTIONAL, &REST, &KEY).
+;;;
 (defun required-arguments (name)
   (let ((type (ext:info function type name)))
     (cond ((not (kernel:function-type-p type))
@@ -85,45 +70,19 @@
 			   (kernel:function-type-rest type))
 		       t nil))))))
 
-#-cmu
-(progn
- (eval-when (compile eval)
-   (warn
-    "You may want to add an implementation-specific Required-Arguments function."))
- (eval-when (load eval)
-   (defun required-arguments (name)
-     (declare (ignore name))
-     (values 0 t))))
-
-
-
-;;; The Total-Consing macro is called to find the total number of bytes consed
+;;;
+;;; TOTAL-CONSING is called to find the total number of bytes consed
 ;;; since the beginning of time.
-
+;;;
 (declaim (inline total-consing))
-#+cmu
 (defun total-consing () (ext:get-bytes-consed-dfixnum))
 
-#-cmu
-(eval-when (compile eval)
-  (error "No consing will be reported unless a Total-Consing function is ~
-           defined."))
-
-#-cmu
-(progn
-  (eval-when (compile eval)
-    (warn "No consing will be reported unless a Total-Consing function is ~
-           defined."))
-
-  (defmacro total-consing () '0))
-
-
+;;;
 ;;; The type of the result of TOTAL-CONSING.
-#+cmu
+;;;
 (deftype consing-type () '(and fixnum unsigned-byte))
-#-cmu
-(deftype consing-type () 'unsigned-byte)
 
+;;;
 ;;; On the CMUCL x86 port the return address is represented as a SAP
 ;;; and to save the costly calculation of the SAPs code object the
 ;;; profiler maintains callers as SAPs. These SAPs will become invalid
@@ -131,69 +90,91 @@
 ;;; use of purify or by moving code objects into an older generation
 ;;; when using GENCGC.
 ;;;
-#+cmu
-(progn
-  (defmacro get-caller-info ()
-    `(nth-value 1 (kernel:%caller-frame-and-pc)))
-  #-(and cmu x86)
-  (defun print-caller-info (info stream)
-    (prin1 (kernel:lra-code-header info) stream))
-  #+(and cmu x86)
-  (defun print-caller-info (info stream)
-    (prin1 (nth-value 1 (di::compute-lra-data-from-pc info)) stream)))
-
-#-cmu
-(progn
-  (defmacro get-caller-info () 'unknown)
-  (defun print-caller-info (info stream)
-    (prin1 "no caller info" stream)))
+(defmacro get-caller-info ()
+  `(nth-value 1 (kernel:%caller-frame-and-pc)))
+
+#-x86
+(defun print-caller-info (info stream)
+  (prin1 (kernel:lra-code-header info) stream))
+
+#+x86
+(defun print-caller-info (info stream)
+  (prin1 (nth-value 1 (di::compute-lra-data-from-pc info)) stream))
 
 
 ;;;; Global data structures:
 
 (defvar *timed-functions* ()
   "List of functions that are currently being timed.")
+
 (defvar *no-calls* nil
   "A list of profiled functions which weren't called.")
+
 (defvar *no-calls-limit* 20
   "If the number of profiled functions that were not called is less than
 this, the functions are listed.  If NIL, then always list the functions.")
 
-;;; We associate a PROFILE-INFO structure with each profiled function name.
-;;; This holds the functions that we call to manipulate the closure which
-;;; implements the encapsulation.
 ;;;
-(defvar *profile-info* (make-hash-table :test #'equal))
-(defstruct profile-info
-  (name nil)
-  (old-definition (ext:required-argument) :type function)
-  (new-definition (ext:required-argument) :type function)
-  (read-time (ext:required-argument) :type function)
-  (reset-time (ext:required-argument) :type function))
+;;; This is stored as user-data of profile fwrappers.
+;;;
+(defstruct (profile-info
+	     (:conc-name pi-)
+	     (:constructor make-profile-info (function-name callers-p)))
+  ;;
+  ;; The name of the function being profiled.
+  function-name
+  ;;
+  ;; True if :CALLERS arg was given to PROFILE.
+  (callers-p nil :type boolean)
+  ;;
+  ;; Various counters for profiling.
+  (count 0 :type fixnum)
+  (time 0 :type time-type)
+  (consed-h 0 :type dfixnum:dfparttype)
+  (consed-l 0 :type dfixnum:dfparttype)
+  (consed-w/c-h 0 :type dfixnum:dfparttype)
+  (consed-w/c-l 0 :type dfixnum:dfparttype)
+  (profile 0 :type integer)
+  (callers () :type list))
 
-;;; PROFILE-INFO-OR-LOSE  --  Internal
 ;;;
-(defun profile-info-or-lose (name)
-  (or (gethash name *profile-info*)
-      (error "~S is not a profiled function." name)))
-
-
-;;; We keep around a bunch of functions that make encapsulations, one of each
-;;; (min-args . optional-p) signature we have encountered so far.  We also
-;;; precompute a bunch of encapsulation functions.
+;;; Reset counters of the given PROFILE-INFO
 ;;;
-(defvar *existing-encapsulations* (make-hash-table :test #'equal))
+(defun reset-profile-info (info)
+  (setf (pi-count info) 0
+	(pi-time info) 0
+	(pi-consed-h info) 0
+	(pi-consed-l info) 0
+	(pi-consed-w/c-h info) 0
+	(pi-consed-w/c-l info) 0
+	(pi-profile info) 0
+	(pi-callers info) ()))
 
+;;;
+;;; Return various profiling information from INFO as multiple values.
+;;;
+(defun profile-info-profiling-values (info)
+  (values (pi-count info)
+	  (pi-time info)
+	  (dfixnum:dfixnum-pair-integer (pi-consed-h info)
+					(pi-consed-l info))
+	  (dfixnum:dfixnum-pair-integer (pi-consed-w/c-h info)
+					(pi-consed-w/c-l info))
+	  (pi-profile info)
+	  (pi-callers info)))
 
-;;; These variables are used to subtract out the time and consing for recursive
-;;; and other dynamically nested profiled calls.  The total resource consumed
-;;; for each nested call is added into the appropriate variable.  When the
-;;; outer function returns, these amounts are subtracted from the total.
 ;;;
-;;; *enclosed-consing-h* and *enclosed-consing-l* represent the total
+;;; These variables are used to subtract out the time and consing for
+;;; recursive and other dynamically nested profiled calls.  The total
+;;; resource consumed for each nested call is added into the
+;;; appropriate variable.  When the outer function returns, these
+;;; amounts are subtracted from the total.
+;;;
+;;; *ENCLOSED-CONSING-H* and *ENCLOSED-CONSING-L* represent the total
 ;;; consing as a pair of fixnum-sized integers to reduce consing and
 ;;; allow for about 2^58 bytes of total consing.  (Assumes positive
 ;;; fixnums are 29 bits long).
+;;;
 (defvar *enclosed-time* 0)
 (defvar *enclosed-consing-h* 0)
 (defvar *enclosed-consing-l* 0)
@@ -204,17 +185,21 @@ this, the functions are listed.  If NIL, then always list the functions.")
 (declaim (fixnum *enclosed-profilings*))
 
 
-;;; The number of seconds a bare function call takes.  Factored into the other
-;;; overheads, but not used for itself.
+;;;
+;;; The number of seconds a bare function call takes.  Factored into
+;;; the other overheads, but not used for itself.
 ;;;
 (defvar *call-overhead*)
 
-;;; The number of seconds that will be charged to a profiled function due to
-;;; the profiling code.
+;;;
+;;; The number of seconds that will be charged to a profiled function
+;;; due to the profiling code.
+;;;
 (defvar *internal-profile-overhead*)
 
-;;; The number of seconds of overhead for profiling that a single profiled call
-;;; adds to the total runtime for the program.
+;;;
+;;; The number of seconds of overhead for profiling that a single
+;;; profiled call adds to the total runtime for the program.
 ;;;
 (defvar *total-profile-overhead*)
 
@@ -224,174 +209,158 @@ this, the functions are listed.  If NIL, then always list the functions.")
 
 ;;;; Profile encapsulations:
 
-(eval-when (compile load eval)
-
-(defun make-profile-encapsulation (min-args optionals-p)
-  (let ((required-args ()))
-    (dotimes (i min-args)
-      (push (gensym) required-args))
-    `(lambda (name callers-p)
-       (let* ((time 0)
-	      (count 0)
-	      (consed-h 0)
-	      (consed-l 0)
-	      (consed-w/c-h 0)
-	      (consed-w/c-l 0)
-	      (profile 0)
-	      (callers ())
-	      (old-definition (fdefinition name)))
-	 (declare (type time-type time)
-		  (type dfixnum:dfparttype consed-h consed-l)
-		  (type dfixnum:dfparttype consed-w/c-h consed-w/c-l)
-		  (fixnum count))
-	 (pushnew name *timed-functions*)
-
-	 (without-package-locks
-	  (setf (fdefinition name)
-		#'(lambda (,@required-args
-			   ,@(if optionals-p
-				 #+cmu
-				 `(c:&more arg-context arg-count)
-				 #-cmu
-				 `(&rest optional-args)))
-		    (incf count)
-		    (when callers-p
-		      (let ((caller (get-caller-info)))
-			(do ((prev nil current)
-			     (current callers (cdr current)))
-			    ((null current)
-			     (push (cons caller 1) callers))
-			  (let ((old-caller-info (car current)))
-			    (when #-(and cmu x86) (eq caller
-						      (car old-caller-info))
-				  #+(and cmu x86) (sys:sap=
-						   caller (car old-caller-info))
-				  (if prev
-				      (setf (cdr prev) (cdr current))
-				      (setq callers (cdr current)))
-				  (setf (cdr old-caller-info)
-					(the fixnum
-					  (+ (cdr old-caller-info) 1)))
-				  (setf (cdr current) callers)
-				  (setq callers current)
-				  (return))))))
+(eval-when (:compile-toplevel :load-toplevel :execute)
+
+   ;;;
+   ;;; Names of fwrappers look like (PROFILE <nreq> <optionals-p>).
+   ;;; <Nreq> is the number of required parameters, <optionals-p> is
+   ;;; true if the fwrapper is for functions with optional arguments.
+   ;;;
+  (define-function-name-syntax profile (name)
+    (when (integerp (cadr name))
+      (values t 'profile)))
+
+  ;;;
+  ;;; Return the profile fwrapper name for profiling a function
+  ;;; with NREQ required arguments and optional arguments according
+  ;;; to OPTIONALS-P.
+  ;;;
+  (defun make-profile-fwrapper-name (nreq optionals-p)
+    `(profile ,nreq ,optionals-p))
+
+  ;;;
+  ;;; Return a DEFINE-FWRAPPER form for profiling a function with
+  ;;; arguments according to NREQ and OPTIONALS-P.
+  ;;;
+  (defun make-profile-fwrapper (nreq optionals-p)
+    (let ((req (loop repeat nreq collect (gensym)))
+	  (name (make-profile-fwrapper-name nreq optionals-p)))
+      `(define-fwrapper ,name (,@req ,@(if optionals-p `(&rest .rest.)))
+	 (let* ((info (fwrapper-user-data fwrapper))
+		(fn-name (pi-function-name info))
+		(fdefn (lisp::fdefinition-object fn-name nil)))
+	   ;;
+	   ;; "Deactivate" the profile fwrapper for the time it is
+	   ;; running to ease profiling of functions used in the
+	   ;; implementation of PROFILE itself.
+	   (letf (((lisp::fdefn-function fdefn) (fwrapper-next fwrapper)))
+	     (incf (pi-count info))
+	     ;;
+	     ;; If :CALLERS was specified for profiling, record caller
+	     ;; information.
+	     (when (pi-callers-p info)
+	       (let ((caller (get-caller-info)))
+		 (do ((prev nil current)
+		      (current (pi-callers info) (cdr current)))
+		     ((null current)
+		      (push (cons caller 1) (pi-callers info)))
+		   (let ((old-caller-info (car current)))
+		     (when (progn #-x86 (eq caller (car old-caller-info))
+				  #+x86 (sys:sap= caller (car old-caller-info)))
+		       (if prev
+			   (setf (cdr prev) (cdr current))
+			   (setf (pi-callers info) (cdr current)))
+		       (setf (cdr old-caller-info)
+			     (the fixnum (+ (cdr old-caller-info) 1)))
+		       (setf (cdr current) (pi-callers info))
+		       (setf (pi-callers info) current)
+		       (return))))))
 			       
-		    (let ((time-inc 0)
-			  (cons-inc-h 0)
-			  (cons-inc-l 0)
-			  (profile-inc 0))
-		      (declare (type time-type time-inc)
-			       (type dfixnum:dfparttype cons-inc-h cons-inc-l)
-			       (fixnum profile-inc))
-		      (multiple-value-prog1
-			  (let ((start-time (quickly-get-time))
-				(start-consed-h 0)
-				(start-consed-l 0)
-				(end-consed-h 0)
-				(end-consed-l 0)
-				(*enclosed-time* 0)
-				(*enclosed-consing-h* 0)
-				(*enclosed-consing-l* 0)
-				(*enclosed-profilings* 0))
-			    (dfixnum:dfixnum-set-pair start-consed-h
-						      start-consed-l
-						      (total-consing))
-			    (multiple-value-prog1
-				,(if optionals-p
-				     #+cmu
-				     `(multiple-value-call
-					  old-definition
-					(values ,@required-args)
-					(c:%more-arg-values arg-context
-							    0
-							    arg-count))
-				     #-cmu
-				     `(apply old-definition
-					     ,@required-args optional-args)
-				     `(funcall old-definition ,@required-args))
-			      (setq time-inc
-				    #-BSD
-				    (- (quickly-get-time) start-time)
-				    #+BSD
-				    (max (- (quickly-get-time) start-time) 0))
-			      ;; How much did we cons so far?
-			      (dfixnum:dfixnum-set-pair end-consed-h
-							end-consed-l
-							(total-consing))
-			      (dfixnum:dfixnum-copy-pair cons-inc-h cons-inc-l
-							 end-consed-h
-							 end-consed-l)
-			      (dfixnum:dfixnum-dec-pair cons-inc-h cons-inc-l
-							start-consed-h
-							start-consed-l)
-			      ;; (incf consed (- cons-inc *enclosed-consing*))
-			      (dfixnum:dfixnum-inc-pair consed-h consed-l
-							cons-inc-h cons-inc-l)
-			      (dfixnum:dfixnum-inc-pair consed-w/c-h
-							consed-w/c-l
-							cons-inc-h cons-inc-l)
-
-			      (setq profile-inc *enclosed-profilings*)
-			      (incf time
-				    (the time-type
-				      #-BSD
-				      (- time-inc *enclosed-time*)
-				      #+BSD
-				      (max (- time-inc *enclosed-time*) 0)))
-			      (dfixnum:dfixnum-dec-pair consed-h consed-l
-							*enclosed-consing-h*
-							*enclosed-consing-l*)
-			      (incf profile profile-inc)))
-			(incf *enclosed-time* time-inc)
-			;; *enclosed-consing* = *enclosed-consing + cons-inc
-			(dfixnum:dfixnum-inc-pair *enclosed-consing-h*
-						  *enclosed-consing-l*
-						  cons-inc-h
-						  cons-inc-l))))))
-	 
-	 (setf (gethash name *profile-info*)
-	       (make-profile-info
-		:name name
-		:old-definition old-definition
-		:new-definition (fdefinition name)
-		:read-time
-		#'(lambda ()
-		    (values count time
-			    (dfixnum:dfixnum-pair-integer consed-h consed-l)
-			    (dfixnum:dfixnum-pair-integer consed-w/c-h
-							  consed-w/c-l)
-			    profile callers))
-		:reset-time
-		#'(lambda ()
-		    (setq count 0)
-		    (setq time 0)
-		    (setq consed-h 0)
-		    (setq consed-l 0)
-		    (setq consed-w/c-h 0)
-		    (setq consed-w/c-l 0)
-		    (setq profile 0)
-		    (setq callers ())
-		    t)))))))
-
-); EVAL-WHEN (COMPILE LOAD EVAL)
-
-
-
-;;; Precompute some encapsulation functions:
-;;;
-(macrolet ((frob ()
-	     (let ((res ()))
-	       (dotimes (i 4)
-		 (push `(setf (gethash '(,i . nil) *existing-encapsulations*)
-			      #',(make-profile-encapsulation i nil))
-		       res))
-	       (dotimes (i 2)
-		 (push `(setf (gethash '(,i . t) *existing-encapsulations*)
-			      #',(make-profile-encapsulation i t))
-		       res))
-	       `(progn ,@res))))
-  (frob))
-
+	     (let ((time-inc 0)
+		   (cons-inc-h 0)
+		   (cons-inc-l 0)
+		   (profile-inc 0))
+	       (declare (type time-type time-inc)
+			(type dfixnum:dfparttype cons-inc-h cons-inc-l)
+			(fixnum profile-inc))
+	       (multiple-value-prog1
+		   (let ((start-time (quickly-get-time))
+			 (start-consed-h 0)
+			 (start-consed-l 0)
+			 (end-consed-h 0)
+			 (end-consed-l 0)
+			 (*enclosed-time* 0)
+			 (*enclosed-consing-h* 0)
+			 (*enclosed-consing-l* 0)
+			 (*enclosed-profilings* 0))
+		     (dfixnum:dfixnum-set-pair start-consed-h
+					       start-consed-l
+					       (total-consing))
+		     (multiple-value-prog1
+			 (call-next-function)
+		       (setq time-inc
+			     #-BSD (- (quickly-get-time) start-time)
+			     #+BSD (max (- (quickly-get-time) start-time) 0))
+		       ;; How much did we cons so far?
+		       (dfixnum:dfixnum-set-pair end-consed-h
+						 end-consed-l
+						 (total-consing))
+		       (dfixnum:dfixnum-copy-pair cons-inc-h cons-inc-l
+						  end-consed-h
+						  end-consed-l)
+		       (dfixnum:dfixnum-dec-pair cons-inc-h cons-inc-l
+						 start-consed-h
+						 start-consed-l)
+		       ;; (incf consed (- cons-inc *enclosed-consing*))
+		       (dfixnum:dfixnum-inc-pair (pi-consed-h info)
+						 (pi-consed-l info)
+						 cons-inc-h cons-inc-l)
+		       (dfixnum:dfixnum-inc-pair (pi-consed-w/c-h info)
+						 (pi-consed-w/c-l info)
+						 cons-inc-h cons-inc-l)
+		       (setq profile-inc *enclosed-profilings*)
+		       (incf (pi-time info)
+			     (the time-type
+			       #-BSD
+			       (- time-inc *enclosed-time*)
+			       #+BSD
+			       (max (- time-inc *enclosed-time*) 0)))
+		       (dfixnum:dfixnum-dec-pair (pi-consed-h info)
+						 (pi-consed-l info)
+						 *enclosed-consing-h*
+						 *enclosed-consing-l*)
+		       (incf (pi-profile info) profile-inc)))
+		 (incf *enclosed-time* time-inc)
+		 ;; *enclosed-consing* = *enclosed-consing + cons-inc
+		 (dfixnum:dfixnum-inc-pair *enclosed-consing-h*
+					   *enclosed-consing-l*
+					   cons-inc-h
+					   cons-inc-l)))))))))
+
+;;;
+;;; Pre-define some profile fwrappers.
+;;;
+(macrolet ((def-profile-fwrapper (nreq)
+	     `(progn
+	       ,(make-profile-fwrapper nreq t)
+	       ,(make-profile-fwrapper nreq nil))))
+  (def-profile-fwrapper 0)
+  (def-profile-fwrapper 1)
+  (def-profile-fwrapper 2)
+  (def-profile-fwrapper 3))
+
+(defun ensure-profile-fwrapper (nreq optionals-p)
+  "Ensure that a profile fwrapper for functions with NREQ required
+   arguments and optional arguments according to OPTIONALS-P exists.
+   Return the name of that fwrapper."
+  (let ((name (make-profile-fwrapper-name nreq optionals-p)))
+    (unless (fboundp name)
+      (without-package-locks
+       (eval (make-profile-fwrapper nreq optionals-p))
+       (compile name)))
+    name))
+
+(defun find-profile-fwrapper (name)
+  "Return the profile FWRAPPER object on function NAME, if any."
+  (find-fwrapper name :type 'profile))
+
+(defun pi-or-lose (name)
+  "Return the PROFILE-INFO for function NAME.
+   Signal an error if NAME is not profiled."
+  (let ((f (find-profile-fwrapper name)))
+    (if f
+	(fwrapper-user-data f)
+	(error "No profile info for ~s" name))))
 
 
 ;;; Interfaces:
@@ -401,22 +370,17 @@ this, the functions are listed.  If NIL, then always list the functions.")
 ;;;    Profile the function Name.  If already profiled, unprofile first.
 ;;;
 (defun profile-1-function (name callers-p)
-  (cond ((fboundp name)
-	 (when (gethash name *profile-info*)
-	   (warn "~S already profiled, so unprofiling it first." name)
-	   (unprofile-1-function name))
-	 (multiple-value-bind (min-args optionals-p)
-			      (required-arguments name)
-	   (funcall (or (gethash (cons min-args optionals-p)
-				 *existing-encapsulations*)
-			(setf (gethash (cons min-args optionals-p)
-				       *existing-encapsulations*)
-			      (compile nil (make-profile-encapsulation
-					    min-args optionals-p))))
-		    name
-		    callers-p)))
-	(t
-	 (warn "Ignoring undefined function ~S." name))))
+  (if (fboundp name)
+      (multiple-value-bind (nreq optionals-p)
+	  (required-arguments name)
+	(when (find-profile-fwrapper name)
+	  (warn "~s already profiled, unprofiling it first" name)
+	  (unprofile-1-function name))
+	(let ((ctor (ensure-profile-fwrapper nreq optionals-p)))
+	  (fwrap name ctor :type 'profile
+		 :user-data (make-profile-info name callers-p))
+	  (push name *timed-functions*)))
+      (warn "Ignoring undefined function ~s" name)))
 
 
 ;;; PROFILE  --  Public
@@ -553,16 +517,20 @@ this, the functions are listed.  If NIL, then always list the functions.")
 ;;; UNPROFILE-1-FUNCTION  --  Internal
 ;;;
 (defun unprofile-1-function (name)
-  (let ((info (profile-info-or-lose name)))
-    (remhash name *profile-info*)
-    (setq *timed-functions*
-	  (delete name *timed-functions*
-		  :test #'equal))
-    (without-package-locks
-     (if (eq (fdefinition name) (profile-info-new-definition info))
-	 (setf (fdefinition name) (profile-info-old-definition info))
-	 (warn "Preserving current definition of redefined function ~S."
-	       name)))))
+  (funwrap name :type 'profile)
+  (setq *timed-functions* (delete name *timed-functions* :test #'equal)))
+
+
+(defun re-profile-redefined-function (name new-value)
+  (declare (ignore new-value))
+  (let (f)
+    (when (and (fboundp name)
+	       (setq f (find-profile-fwrapper name)))
+      (profile-1-function name (pi-callers (fwrapper-user-data f))))))
+
+(push #'re-profile-redefined-function ext:*setf-fdefinition-hook*)
+
+
 
 ;;; COMPENSATE-TIME  --  Internal
 ;;;
@@ -707,15 +675,9 @@ this, the functions are listed.  If NIL, then always list the functions.")
   (let ((info ())
 	(no-call ()))
     (dolist (name names)
-      (let ((pinfo (profile-info-or-lose name)))
-	(unless (eq (fdefinition name)
-		    (profile-info-new-definition pinfo))
-	  (warn "Function ~S has been redefined, so times may be inaccurate.~@
-	         PROFILE it again to record calls to the new definition."
-		name))
-	(multiple-value-bind
-	    (calls time consing consing-w/c profile callers)
-	    (funcall (profile-info-read-time pinfo))
+      (let ((pinfo (pi-or-lose name)))
+	(multiple-value-bind (calls time consing consing-w/c profile callers)
+	    (profile-info-profiling-values pinfo)
 	  (if (zerop calls)
 	      (push name no-call)
 	      (push (make-time-info name calls
@@ -759,15 +721,15 @@ this, the functions are listed.  If NIL, then always list the functions.")
 	  (format *trace-output*
 		  "~%These functions were not called:~%~{~<~%~:; ~S~>~}~%"
 		  (sort no-call #'string<
-			:key #'(lambda (n)
-				 (if (symbolp n)
-				     (symbol-name n)
-				     (multiple-value-bind (valid block-name)
-					 (ext:valid-function-name-p n)
-				       (declare (ignore valid))
-				       (if block-name
-					   block-name
-					   (princ-to-string n)))))))))
+			:key (lambda (n)
+			       (if (symbolp n)
+				   (symbol-name n)
+				   (multiple-value-bind (valid block-name)
+				       (ext:valid-function-name-p n)
+				     (declare (ignore valid))
+				     (if block-name
+					 block-name
+					 (princ-to-string n)))))))))
     (values)))
 
 
@@ -778,7 +740,7 @@ this, the functions are listed.  If NIL, then always list the functions.")
 
 (defun %reset-time (names)
   (dolist (name names)
-    (funcall (profile-info-reset-time (profile-info-or-lose name))))
+    (reset-profile-info (pi-or-lose name)))
   (values))
 
 
@@ -841,9 +803,9 @@ this, the functions are listed.  If NIL, then always list the functions.")
 	   (profile compute-time-overhead-aux)
 	   (frob *total-profile-overhead*)
 	   (decf *total-profile-overhead* *call-overhead*)
-	   (let ((pinfo (profile-info-or-lose 'compute-time-overhead-aux)))
+	   (let ((pinfo (pi-or-lose 'compute-time-overhead-aux)))
 	     (multiple-value-bind (calls time)
-		 (funcall (profile-info-read-time pinfo))
+		 (profile-info-profiling-values pinfo)
 	       (declare (ignore calls))
 	       (setq *internal-profile-overhead*
 		     (/ (float time)
@@ -851,9 +813,8 @@ this, the functions are listed.  If NIL, then always list the functions.")
 			(float timer-overhead-iterations))))))
       (unprofile compute-time-overhead-aux))))
 
-#+cmu
-(pushnew #'(lambda ()
-	     (makunbound '*call-overhead*))
+(pushnew (lambda ()
+	   (makunbound '*call-overhead*))
 	 ext:*before-save-initializations*)
 
 
@@ -908,7 +869,7 @@ this, the functions are listed.  If NIL, then always list the functions.")
       (when (listp e)
 	(incf length (deep-list-length e)))
       (incf length))
-    length))      
+    length))
 
 ;; bunch for tests for above
 #+nil
@@ -979,33 +940,33 @@ this, the functions are listed.  If NIL, then always list the functions.")
 				      start-l))))))
 
 (defun print-spacereports (&optional (stream *trace-output*))
-  (maphash #'(lambda (key value)
-	       (format
-		stream
-		"~&~10:D bytes ~9:D calls ~a b/call: ~a (sz ~d)~%"
-		(dfixnum:dfixnum-pair-integer
-		 (spacereport-info-consed-h value)
-		 (spacereport-info-consed-l value))
-		(spacereport-info-n value)
-		(format-quotient (dfixnum:dfixnum-pair-integer
-				  (spacereport-info-consed-h value)
-				  (spacereport-info-consed-l value))
-				 (spacereport-info-n value)
-				 10 2)
-		key
-		(spacereport-info-codesize value)))
+  (maphash (lambda (key value)
+	     (format
+	      stream
+	      "~&~10:D bytes ~9:D calls ~a b/call: ~a (sz ~d)~%"
+	      (dfixnum:dfixnum-pair-integer
+	       (spacereport-info-consed-h value)
+	       (spacereport-info-consed-l value))
+	      (spacereport-info-n value)
+	      (format-quotient (dfixnum:dfixnum-pair-integer
+				(spacereport-info-consed-h value)
+				(spacereport-info-consed-l value))
+			       (spacereport-info-n value)
+			       10 2)
+	      key
+	      (spacereport-info-codesize value)))
 	   *spacereports*))
 
 (defun reset-spacereports ()
-  (maphash #'(lambda (key value)
-	       (declare (ignore key))
-	       (setf (spacereport-info-consed-h value) 0)
-	       (setf (spacereport-info-consed-l value) 0)
-	       (setf (spacereport-info-n value) 0))
+  (maphash (lambda (key value)
+	     (declare (ignore key))
+	     (setf (spacereport-info-consed-h value) 0)
+	     (setf (spacereport-info-consed-l value) 0)
+	     (setf (spacereport-info-n value) 0))
 	   *spacereports*))
 
 (defun delete-spacereports ()
-  (maphash #'(lambda (key value)
-	       (declare (ignore value))
-	       (remhash key *spacereports*))
+  (maphash (lambda (key value)
+	     (declare (ignore value))
+	     (remhash key *spacereports*))
 	   *spacereports*))
diff --git a/docs/cmu-user/extensions.tex b/docs/cmu-user/extensions.tex
index 13c4be4af..387ae46e6 100644
--- a/docs/cmu-user/extensions.tex
+++ b/docs/cmu-user/extensions.tex
@@ -2182,6 +2182,10 @@ Method profiling is done analogously to \code{trace}:
   true, that is, method functions are compiled.
 \end{defvar}
 
+
+
+
+
 \section{Differences from ANSI Common Lisp}
 This section describes some of the known differences between \cmucl{}
 and ANSI \clisp{}.  Some may be non-compliance issues; same may be
@@ -2195,3 +2199,143 @@ extensions.
   than one value which are returned as multiple values.
 \end{defun}
 
+
+
+
+\section{Function Wrappers}
+\cindex{function wrappers}
+\cindex{fwrappers}
+
+Function wrappers, fwrappers for short, are a facility for efficiently
+encapsulating functions.
+
+Functions in \cmucl{} are represented by \code{kernel:fdefn}
+objects.  Each \code{fdefn} object contains a reference to its
+function's actual code, which we call the function's primary function.
+
+A function wrapper replaces the primary function in the \code{fdefn}
+object with a function of its own, and records the original function
+in an fwrapper object, a funcallable instance.  Thus, when the
+function is called, the fwrapper gets called, which in turn might call
+the primary function, or a previously installed fwrapper that was
+found in the \code{fdefn} object when the second fwrapper was
+installed.
+
+Example:
+
+\begin{lisp}
+(use-package :fwrappers)
+
+(define-fwrapper foo (x y)
+  (format t "x = ~s, y = ~s, user-data = ~s~%"
+          x y (fwrapper-user-data fwrapper))
+  (let ((value (call-next-function)))
+    (format t "value = ~s~%" value)
+    value))
+
+(defun bar (x y)
+  (+ x y))
+
+(fwrap 'bar #'foo :type 'foo :user-data 42)
+
+(bar 1 2)
+ =>
+ x = 1, y = 2, user-data = 42
+ value = 3
+ 3   
+\end{lisp}
+
+Fwrappers are used in the implementation of \code{trace} and
+\code{profile}.
+
+\begin{defmac}{fwrappers:}{define-fwrapper}{name lambda-list \ampbody body}
+  This macro is like \code{defun}, but defines a function named
+  \var{name} that can be used as an fwrapper definition.
+  
+  In \var{body}, the symbol \code{fwrapper} is bound to the current
+  fwrapper object.
+
+  The macro \code{call-next-function} can be used to invoke the next
+  fwrapper, or the primary function being fwrapped.  When called
+  with no arguments, \code{call-next-function} invokes the next
+  function with the original arguments passed to the fwrapper, unless
+  you modify one of the parameters.  When called with arguments,
+  \code{call-next-function} invokes the next function with the given
+  arguments.
+\end{defmac}
+
+\begin{defun}{fwrappers:}{fwrap}{function-name fwrapper \&key type
+    user-data}
+  This function wraps function \code{function-name} in an fwrapper
+  \var{fwrapper} which was defined with \code{define-fwrapper}.
+
+  The value of \var{type}, if supplied, is used as an identifying
+  tag that can be used in various other operations.
+  
+  The value of \var{user-data} is stored as user-supplied data in the
+  fwrapper object that is created for the function encapsulation.
+  User-data is accessible in the body of fwrappers defined with
+  \code{define-fwrapper} as \code{(fwrapper-user-data fwrapper)}.
+
+  Value is the fwrapper object created.
+\end{defun}
+
+\begin{defun}{fwrappers:}{funwrap}{function-name \&key type test}
+  Remove fwrappers from the function named \var{function-name}.  If
+  \var{type} is supplied, remove fwrappers whose type is \code{equal}
+  to \var{type}.  If \var{test} is supplied, remove fwrappers
+  satisfying \var{test}.
+\end{defun}
+
+\begin{defun}{fwrappers:}{find-fwrapper}{function-name \&key type test}
+  Find an fwrapper of \var{function-name}.  If \var{type} is supplied,
+  find an fwrapper whose type is \code{equal} to \var{type}.  If
+  \var{test} is supplied, find an fwrapper satisfying \var{test}.
+\end{defun}
+
+\begin{defun}{fwrappers:}{update-fwrapper}{fwrapper}
+  Update the funcallable instance function of the fwrapper object
+  \var{fwrapper} from the definition of its function that was 
+  defined with \code{define-fwrapper}.  This can be used to update
+  fwrappers after changing a \code{define-fwrapper}.
+\end{defun}
+
+\begin{defun}{fwrappers:}{update-fwrappers}{function-name \&key type test}
+  Update fwrappers of \var{function-name}; see \code{update-fwrapper}.
+  If \var{type} is supplied, update fwrappers whose type is
+  \code{equal} to \var{type}.  If \var{test} is supplied, update fwrappers
+  satisfying \var{test}.
+\end{defun}
+
+\begin{defun}{fwrappers:}{set-fwrappers}{function-name fwrappers}
+  Set \var{function-names}'s fwrappers to elements of the list
+  \var{fwrappers}, which is assumed to be ordered from outermost to
+  innermost.  \var{fwrappers} null means remove all fwrappers.
+\end{defun}
+
+\begin{defun}{fwrappers:}{list-fwrappers}{function-name}
+  Return a list of all fwrappers of \var{function-name}, ordered
+  from outermost to innermost.
+\end{defun}
+
+\begin{defun}{fwrappers:}{push-fwrapper}{fwrapper function-name}
+  Prepend fwrapper \var{fwrapper} to the definition of
+  \var{function-name}.  Signal an error if \var{function-name} is an
+  undefined function.
+\end{defun}
+
+\begin{defun}{fwrappers:}{delete-fwrapper}{fwrapper function-name}
+  Remove fwrapper \var{fwrapper} from the definition of
+  \var{function-name}.  Signal an error if \var{function-name} is an
+  undefined function.
+\end{defun}
+
+\begin{defmac}{fwrappers:}{do-fwrappers}{(var fdefn \ampoptional
+  result) \ampbody body}
+  Evaluate \var{body} with \var{var} bound to consecutive fwrappers of
+  \var{fdefn}.  Return \var{result} at the end.  Note that \var{fdefn}
+  must be an \code{fdefn} object.  You can use
+  \code{kernel:fdefn-or-lose}, for instance, to get the \code{fdefn}
+  object from a function name.
+\end{defmac}
+
diff --git a/general-info/release-19a.txt b/general-info/release-19a.txt
index 34e299a70..19f1b4c8f 100644
--- a/general-info/release-19a.txt
+++ b/general-info/release-19a.txt
@@ -44,6 +44,12 @@ New in this release:
      - Functions like GETHASH that are used in the implementation of 
        TRACE can now be traced.  See also
        DEBUG:*TRACE-ENCAPSULATE-PACKAGE-NAMES*.
+     - New facility for encapsulating functions, FWRAPPERS;
+       see also the CMUCL User Manual.
+     - TRACE and PROFILE have been reimplemented using fwrappers,
+       with the effect of tracing and profiling now working more
+       nicely together.
+     - When a profiled function is redefined, it is re-profiled.
 
   * Numerous ANSI compliance fixes:
      - Many bugs in CMUCL's type system detected by Paul Dietz'
@@ -127,7 +133,7 @@ New in this release:
   * Changes to rebuilding procedure:
       
   * Deprecated features:
-  
+     - EXT:ENCAPSULATE and associated functions; use fwrappers instead.
 
 This release is not binary compatible with code compiled using CMUCL
 18e; you will need to recompile FASL files. 
diff --git a/pcl/defs.lisp b/pcl/defs.lisp
index bdf6e38ad..05b440de3 100644
--- a/pcl/defs.lisp
+++ b/pcl/defs.lisp
@@ -59,12 +59,7 @@
 (declaim (inline gdefinition))
 
 (defun gdefinition (name)
-  (let ((fdefn (fdefinition name))
-	(info (gethash name profile::*profile-info*)))
-    (if (and info
-	     (eq fdefn (profile::profile-info-new-definition info)))
-	(profile::profile-info-old-definition info)
-	fdefn)))
+  (fdefinition name))
 
 ;;;
 ;;; If symbol names a function which is traced or advised, redefine
diff --git a/tools/worldbuild.lisp b/tools/worldbuild.lisp
index 5a4062772..bc99b2d77 100644
--- a/tools/worldbuild.lisp
+++ b/tools/worldbuild.lisp
@@ -7,7 +7,7 @@
 ;;; Scott Fahlman or slisp-group@cs.cmu.edu.
 ;;;
 (ext:file-comment
-  "$Header: /Volumes/share2/src/cmucl/cvs2git/cvsroot/src/tools/worldbuild.lisp,v 1.48 2003/04/11 15:28:11 emarsden Exp $")
+  "$Header: /Volumes/share2/src/cmucl/cvs2git/cvsroot/src/tools/worldbuild.lisp,v 1.49 2003/05/23 13:34:04 gerd Exp $")
 ;;;
 ;;; **********************************************************************
 ;;;
@@ -68,6 +68,7 @@
     "target:code/eval"
 
     "target:code/struct"
+    "target:code/fwrappers"
     "target:code/typedefs"
     "target:code/class"
     "target:code/type"
diff --git a/tools/worldcom.lisp b/tools/worldcom.lisp
index b3f486a03..42c3d185e 100644
--- a/tools/worldcom.lisp
+++ b/tools/worldcom.lisp
@@ -7,7 +7,7 @@
 ;;; Scott Fahlman or slisp-group@cs.cmu.edu.
 ;;;
 (ext:file-comment
-  "$Header: /Volumes/share2/src/cmucl/cvs2git/cvsroot/src/tools/worldcom.lisp,v 1.86 2003/04/18 10:24:32 gerd Exp $")
+  "$Header: /Volumes/share2/src/cmucl/cvs2git/cvsroot/src/tools/worldcom.lisp,v 1.87 2003/05/23 13:34:04 gerd Exp $")
 ;;;
 ;;; **********************************************************************
 ;;;
@@ -109,6 +109,7 @@
 (comf "target:code/globals")
 (comf "target:code/kernel")
 (comf "target:code/lispinit")
+(comf "target:code/fwrappers")
 (comf "target:code/fdefinition")
 
 (comf "target:code/error")
diff --git a/tools/worldload.lisp b/tools/worldload.lisp
index 3d6f9c1cd..fb8d4e3a3 100644
--- a/tools/worldload.lisp
+++ b/tools/worldload.lisp
@@ -6,7 +6,7 @@
 ;;; If you want to use this code or any part of CMU Common Lisp, please contact
 ;;; Scott Fahlman or slisp-group@cs.cmu.edu.
 ;;;
-;;; $Header: /Volumes/share2/src/cmucl/cvs2git/cvsroot/src/tools/worldload.lisp,v 1.99 2003/03/02 18:56:43 toy Exp $
+;;; $Header: /Volumes/share2/src/cmucl/cvs2git/cvsroot/src/tools/worldload.lisp,v 1.100 2003/05/23 13:34:04 gerd Exp $
 ;;;
 ;;; **********************************************************************
 ;;;
@@ -113,6 +113,7 @@
 (maybe-byte-load "code:describe")
 #+random-mt19937 (maybe-byte-load "code:rand-mt19937")
 #-random-mt19937 (maybe-byte-load "code:rand")
+(maybe-byte-load "code:fwrappers")
 (maybe-byte-load "code:ntrace")
 #-runtime (maybe-byte-load "code:profile")
 (maybe-byte-load "code:weak")
-- 
GitLab