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