From 1e08b23e730c7a1c9cda1b918e9fdca38b8c4e17 Mon Sep 17 00:00:00 2001 From: Christophe Rhodes Date: Mon, 23 Dec 2002 13:52:59 +0000 Subject: [PATCH] 0.7.10.31: Installed ctor.lisp MAKE-INSTANCE optimization (from Gerd Moellmann, via CSR sbcl-devel 2002-12-21) ... wrote tests for those bugs which it fixes ... do not delete fast-init.lisp yet; waiting for user feedback before destroying some CVS history ... update COPYING information to reflect the new copyright owner --- COPYING | 9 +- CREDITS | 5 +- NEWS | 12 +- src/cold/warm.lisp | 2 +- src/pcl/boot.lisp | 7 +- src/pcl/ctor.lisp | 591 ++++++++++++++++++++++++++++++++++++++++ src/pcl/generic-functions.lisp | 4 +- src/pcl/init.lisp | 150 +++++----- src/pcl/low.lisp | 7 +- src/pcl/macros.lisp | 8 +- src/pcl/methods.lisp | 17 +- src/pcl/std-class.lisp | 2 +- src/pcl/vector.lisp | 3 +- tests/clos.impure-cload.lisp | 26 ++ version.lisp-expr | 2 +- 15 files changed, 714 insertions(+), 131 deletions(-) create mode 100644 src/pcl/ctor.lisp diff --git a/COPYING b/COPYING index 811287e..2bdd04d 100644 --- a/COPYING +++ b/COPYING @@ -8,9 +8,10 @@ After CMU CL was was released into the public domain, it was maintained by volunteers, who continued the tradition of releasing their work into the public domain. -All changes to SBCL since the fork from CMU CL have been released -into the public domain. +All changes to SBCL since the fork from CMU CL have been released into +the public domain in jurisdictions where this is possible, or under +the FreeBSD licence where not. Thus, there are no known obstacles to copying, using, and modifying -SBCL freely, as long as the MIT, Symbolics, and Xerox copyright -notices are retained. +SBCL freely, as long as copyright notices of MIT, Symbolics, Xerox and +Gerd Moellmann are retained. diff --git a/CREDITS b/CREDITS index e3492ea..e15b787 100644 --- a/CREDITS +++ b/CREDITS @@ -579,7 +579,10 @@ Dave McDonald: Gerd Moellman: He has made many cleanups and improvements, small and large, in - CMU CL (mostly in PCL), which we have gratefully ported to SBCL. + CMU CL (mostly in PCL), which we have gratefully ported to SBCL. Of + particular note is his ctor MAKE-INSTANCE optimization, which is both + faster in the typical case than the old optimizations in PCL and + less buggy. William ("Bill") Newman: He continued to maintain SBCL after the fork, increasing ANSI diff --git a/NEWS b/NEWS index 6496715..ee200ee 100644 --- a/NEWS +++ b/NEWS @@ -1452,6 +1452,14 @@ changes in sbcl-0.7.11 relative to sbcl-0.7.10: answer. * the compiler is now able to derive types more accurately from the COERCE and COMPILE functions. + * fixed bug 223: functional binding is considered to be constant + only for symbols in the CL package. + * fixed bug 231: SETQ did not check the type of a variable being set + (reported by Robert E. Brown) + * a new optimization for MAKE-INSTANCE has been included, fixing + various bugs (including relating to :ALLOCATION :CLASS slots and + :DEFAULT-INITARGS over-eager evalueation). (thanks to Gerd + Moellmann) * fixed some more bugs revealed by Paul Dietz' test suite: ** As required by ANSI, LOOP now disallows anonymous collection clauses such as COLLECT I in conjunction with aggregate boolean @@ -1473,10 +1481,6 @@ changes in sbcl-0.7.11 relative to sbcl-0.7.10: * incremented fasl file version number, because of the incompatible change to the DEFSTRUCT-DESCRIPTION structure, and again because of the new implementation of DEFINE-COMPILER-MACRO. - * fixed bug 223: functional binding is considered to be constant - only for symbols in the CL package. - * fixed bug 231: SETQ did not check the type of a variable being set - (reported by Robert E. Brown) planned incompatible changes in 0.7.x: * (not done yet, but planned:) When the profiling interface settles diff --git a/src/cold/warm.lisp b/src/cold/warm.lisp index 8eb011d..676381b 100644 --- a/src/cold/warm.lisp +++ b/src/cold/warm.lisp @@ -146,7 +146,7 @@ "src/pcl/slots-boot" "src/pcl/combin" "src/pcl/dfun" - "src/pcl/fast-init" + "src/pcl/ctor" "src/pcl/braid" "src/pcl/dlisp3" "src/pcl/generic-functions" diff --git a/src/pcl/boot.lisp b/src/pcl/boot.lisp index c4b2bda..9bb5b50 100644 --- a/src/pcl/boot.lisp +++ b/src/pcl/boot.lisp @@ -347,10 +347,8 @@ bootstrapping. lambda-list body env) - (let ((*make-instance-function-keys* nil) - (*optimize-asv-funcall-p* t) + (let ((*optimize-asv-funcall-p* t) (*asv-readers* nil) (*asv-writers* nil) (*asv-boundps* nil)) - (declare (special *make-instance-function-keys*)) (multiple-value-bind (method-lambda unspecialized-lambda-list specializers) (add-method-declarations name qualifiers lambda-list body env) (multiple-value-bind (method-function-lambda initargs) @@ -380,9 +378,6 @@ bootstrapping. ;; intended. I hate that kind of bug (code which silently ;; gives the wrong answer), so we don't do a DECLAIM ;; here. -- WHN 20000229 - ,@(when *make-instance-function-keys* - `((get-make-instance-functions - ',*make-instance-function-keys*))) ,@(when (or *asv-readers* *asv-writers* *asv-boundps*) `((initialize-internal-slot-gfs* ',*asv-readers* ',*asv-writers* ',*asv-boundps*))) diff --git a/src/pcl/ctor.lisp b/src/pcl/ctor.lisp new file mode 100644 index 0000000..dde1c3f --- /dev/null +++ b/src/pcl/ctor.lisp @@ -0,0 +1,591 @@ +;;;; This file contains the optimization machinery for make-instance. + +;;;; This software is part of the SBCL system. See the README file for +;;;; more information. + +;;;; This software is derived from software originally released by +;;;; Gerd Moellmann. Copyright and release statements follow. Later +;;;; modifications to the software are in the public domain and are +;;;; provided with absolutely no warranty. See the COPYING and +;;;; CREDITS files for more information. + +;;; Copyright (C) 2002 Gerd Moellmann +;;; All rights reserved. +;;; +;;; Redistribution and use in source and binary forms, with or without +;;; modification, are permitted provided that the following conditions +;;; are met: +;;; +;;; 1. Redistributions of source code must retain the above copyright +;;; notice, this list of conditions and the following disclaimer. +;;; 2. Redistributions in binary form must reproduce the above copyright +;;; notice, this list of conditions and the following disclaimer in the +;;; documentation and/or other materials provided with the distribution. +;;; 3. The name of the author may not be used to endorse or promote +;;; products derived from this software without specific prior written +;;; permission. +;;; +;;; THIS SOFTWARE IS PROVIDED BY THE AUTHOR ``AS IS'' AND ANY EXPRESS +;;; OR IMPLIED WARRANTIES, INCLUDING, BUT NOT LIMITED TO, THE IMPLIED +;;; WARRANTIES OF MERCHANTABILITY AND FITNESS FOR A PARTICULAR PURPOSE +;;; ARE DISCLAIMED. IN NO EVENT SHALL THE AUTHOR OR CONTRIBUTORS BE +;;; LIABLE FOR ANY DIRECT, INDIRECT, INCIDENTAL, SPECIAL, EXEMPLARY, OR +;;; CONSEQUENTIAL DAMAGES (INCLUDING, BUT NOT LIMITED TO, PROCUREMENT +;;; OF SUBSTITUTE GOODS OR SERVICES; LOSS OF USE, DATA, OR PROFITS; OR +;;; BUSINESS INTERRUPTION) HOWEVER CAUSED AND ON ANY THEORY OF +;;; LIABILITY, WHETHER IN CONTRACT, STRICT LIABILITY, OR TORT +;;; (INCLUDING NEGLIGENCE OR OTHERWISE) ARISING IN ANY WAY OUT OF THE +;;; USE OF THIS SOFTWARE, EVEN IF ADVISED OF THE POSSIBILITY OF SUCH +;;; DAMAGE. + +;;; *************** +;;; Overview ***** +;;; *************** +;;; +;;; Compiler macro for MAKE-INSTANCE, and load-time generation of +;;; optimized instance constructor functions. +;;; +;;; ******************** +;;; Entry Points ****** +;;; ******************** +;;; +;;; UPDATE-CTORS must be called when methods are added/removed, +;;; classes are changed, etc., which affect instance creation. +;;; +;;; PRECOMPILE-CTORS can be called to precompile constructor functions +;;; for classes whose definitions are known at the time the function +;;; is called. + +(in-package "SB-PCL") + +;;; ****************** +;;; Utilities ******* +;;; ****************** + +(defun plist-keys (plist &key test) + (loop for (key . more) on plist by #'cddr + if (null more) do + (error "Not a property list: ~S" plist) + else if (or (null test) (funcall test key)) + collect key)) + +(defun plist-values (plist &key test) + (loop for (key . more) on plist by #'cddr + if (null more) do + (error "Not a property list: ~S" plist) + else if (or (null test) (funcall test (car more))) + collect (car more))) + +(defun constant-symbol-p (form) + (and (constantp form) + (let ((constant (eval form))) + (and (symbolp constant) + (not (null (symbol-package constant))))))) + + +;;; ***************** +;;; CTORS ********* +;;; ***************** +;;; +;;; Ctors are funcallable instances whose initial function is a +;;; function computing an optimized constructor function when called. +;;; When the optimized function is computed, the function of the +;;; funcallable instance is set to it. +;;; +(sb-kernel:!defstruct-with-alternate-metaclass ctor + :slot-names (function-name class-name class initargs) + :boa-constructor %make-ctor + :superclass-name pcl-funcallable-instance + :metaclass-name sb-kernel:random-pcl-class + :metaclass-constructor sb-kernel:make-random-pcl-class + :dd-type sb-kernel:funcallable-structure + :runtime-type-checks-p nil) + +;;; List of all defined ctors. + +(defvar *all-ctors* ()) + +(defun make-ctor-parameter-list (ctor) + (plist-values (ctor-initargs ctor) :test (complement #'constantp))) + +;;; +;;; Reset CTOR to use a default function that will compute an +;;; optimized constructor function when called. +;;; +(defun install-initial-constructor (ctor &key force-p) + (when (or force-p (ctor-class ctor)) + (setf (ctor-class ctor) nil) + (setf (sb-kernel:funcallable-instance-fun ctor) + #'(sb-kernel:instance-lambda (&rest args) + (install-optimized-constructor ctor) + (apply ctor args))) + (setf (sb-kernel:%funcallable-instance-info ctor 1) + (ctor-function-name ctor)))) + +;;; +;;; Keep this a separate function for testing. +;;; +(defun make-ctor-function-name (class-name initargs) + (let ((*package* *pcl-package*) + (*print-case* :upcase) + (*print-pretty* nil) + (*print-gensym* t)) + (intern (format nil "CTOR ~S::~S ~S ~S" + (package-name (symbol-package class-name)) + (symbol-name class-name) + (plist-keys initargs) + (plist-values initargs :test #'constantp)) + *pcl-package*))) + +;;; +;;; Keep this a separate function for testing. +;;; +(defun ensure-ctor (function-name class-name initargs) + (unless (fboundp function-name) + (make-ctor function-name class-name initargs))) + +;;; +;;; Keep this a separate function for testing. +;;; +(defun make-ctor (function-name class-name initargs) + (let ((ctor (%make-ctor function-name class-name nil initargs))) + (push ctor *all-ctors*) + (setf (symbol-function function-name) ctor) + (install-initial-constructor ctor :force-p t) + ctor)) + + +;;; *********************************************** +;;; Compile-Time Expansion of MAKE-INSTANCE ******* +;;; *********************************************** + +(define-compiler-macro make-instance (&whole form &rest args) + (declare (ignore args)) + (or (make-instance->constructor-call form) + form)) + +(defun make-instance->constructor-call (form) + (destructuring-bind (fn class-name &rest args) form + (declare (ignore fn)) + (flet (;; + ;; Return the name of parameter number I of a constructor + ;; function. + (parameter-name (i) + (let ((ps #(.p0. .p1. .p2. .p3. .p4. .p5.))) + (if (array-in-bounds-p ps i) + (aref ps i) + (intern (format nil ".P~D." i) *pcl-package*)))) + ;; + ;; Check if CLASS-NAME is a constant symbol. Give up if + ;; not. + (check-class () + (unless (and class-name (constant-symbol-p class-name)) + (return-from make-instance->constructor-call nil))) + ;; + ;; Check if ARGS are suitable for an optimized constructor. + ;; Return NIL from the outer function if not. + (check-args () + (loop for (key . more) on args by #'cddr do + (when (or (null more) + (not (constant-symbol-p key)) + (eq :allow-other-keys (eval key))) + (return-from make-instance->constructor-call nil))))) + (check-class) + (check-args) + ;; + ;; Collect a plist of initargs and constant values/parameter names + ;; in INITARGS. Collect non-constant initialization forms in + ;; VALUE-FORMS. + (multiple-value-bind (initargs value-forms) + (loop for (key value) on args by #'cddr and i from 0 + collect (eval key) into initargs + if (constantp value) + collect value into initargs + else + collect (parameter-name i) into initargs + and collect value into value-forms + finally + (return (values initargs value-forms))) + (let* ((class-name (eval class-name)) + (function-name (make-ctor-function-name class-name initargs))) + ;; + ;; Prevent compiler warnings for calling the ctor. + (sb-kernel:proclaim-as-fun-name function-name) + (sb-kernel:note-name-defined function-name :function) + (when (eq (info :function :where-from function-name) :assumed) + (setf (info :function :where-from function-name) :defined) + (when (info :function :assumed-type function-name) + (setf (info :function :assumed-type function-name) nil))) + ;; + ;; Return code constructing a ctor at load time, which, when + ;; called, will set its funcallable instance function to an + ;; optimized constructor function. + `(let ((.x. (load-time-value + (ensure-ctor ',function-name ',class-name ',initargs)))) + (declare (ignore .x.)) + ;;; ??? check if this is worth it. + (declare + (ftype (or (function ,(make-list (length value-forms) + :initial-element t) + t) + (function (&rest t) t)) + ,function-name)) + (,function-name ,@value-forms))))))) + + +;;; ************************************************** +;;; Load-Time Constructor Function Generation ******* +;;; ************************************************** + +;;; +;;; The system-supplied primary INITIALIZE-INSTANCE and +;;; SHARED-INITIALIZE methods. One cannot initialized these variables +;;; to the right values here because said functions don't exist yet +;;; when this file is first loaded. +;;; +(defvar *the-system-ii-method* nil) +(defvar *the-system-si-method* nil) + +(defun install-optimized-constructor (ctor) + (let ((class (find-class (ctor-class-name ctor)))) + (unless (class-finalized-p class) + (finalize-inheritance class)) + (setf (ctor-class ctor) class) + (pushnew ctor (plist-value class 'ctors)) + (setf (sb-kernel:funcallable-instance-fun ctor) + ;; KLUDGE: Gerd here has the equivalent of (COMPILE NIL + ;; (CONSTRUCTOR-FUNCTION-FORM)), but SBCL's COMPILE doesn't + ;; deal with INSTANCE-LAMBDA expressions, only with LAMBDA + ;; expressions. The below should be equivalent, since we + ;; have a compiler-only implementation. + (eval `(function ,(constructor-function-form ctor)))))) + +(defun constructor-function-form (ctor) + (let* ((class (ctor-class ctor)) + (proto (class-prototype class)) + (make-instance-methods + (compute-applicable-methods #'make-instance (list class))) + (allocate-instance-methods + (compute-applicable-methods #'allocate-instance (list class))) + (ii-methods + (compute-applicable-methods #'initialize-instance (list proto))) + (si-methods + (compute-applicable-methods #'shared-initialize (list proto t)))) + ;; Cannot initialize these variables earlier because the generic + ;; functions don't exist when PCL is built. + (when (null *the-system-si-method*) + (setq *the-system-si-method* + (find-method #'shared-initialize + () (list *the-class-slot-object* *the-class-t*))) + (setq *the-system-ii-method* + (find-method #'initialize-instance + () (list *the-class-slot-object*)))) + ;; Note that when there are user-defined applicable methods on + ;; MAKE-INSTANCE and/or ALLOCATE-INSTANCE, these will show up + ;; together with the system-defined ones in what + ;; COMPUTE-APPLICABLE-METHODS returns. + (or (and (not (structure-class-p class)) + (null (cdr make-instance-methods)) + (null (cdr allocate-instance-methods)) + (check-initargs-1 class (plist-keys (ctor-initargs ctor)) + (append ii-methods si-methods) nil nil) + (not (around-or-nonstandard-primary-method-p + ii-methods *the-system-ii-method*)) + (not (around-or-nonstandard-primary-method-p + si-methods *the-system-si-method*)) + (optimizing-generator ctor ii-methods si-methods)) + (fallback-generator ctor ii-methods si-methods)))) + +(defun around-or-nonstandard-primary-method-p + (methods &optional standard-method) + (loop with primary-checked-p = nil + for method in methods + as qualifiers = (method-qualifiers method) + when (or (eq :around (car qualifiers)) + (and (null qualifiers) + (not primary-checked-p) + (not (null standard-method)) + (not (eq standard-method method)))) + return t + when (null qualifiers) do + (setq primary-checked-p t))) + +(defun fallback-generator (ctor ii-methods si-methods) + (declare (ignore ii-methods si-methods)) + `(sb-kernel:instance-lambda ,(make-ctor-parameter-list ctor) + (make-instance ,(ctor-class ctor) ,@(ctor-initargs ctor)))) + +(defun optimizing-generator (ctor ii-methods si-methods) + (multiple-value-bind (body before-method-p) + (fake-initialization-emf ctor ii-methods si-methods) + `(sb-kernel:instance-lambda ,(make-ctor-parameter-list ctor) + (declare #.*optimize-speed*) + ,(wrap-in-allocate-forms ctor body before-method-p)))) + +;;; +;;; Return a form wrapped around BODY that allocates an instance +;;; constructed by CTOR. BEFORE-METHOD-P set means we have to run +;;; before-methods, in which case we initialize instance slots to +;;; +SLOT-UNBOUND+. The resulting form binds the local variables +;;; .INSTANCE. to the instance, and .SLOTS. to the instance's slot +;;; vector around BODY. +;;; +(defun wrap-in-allocate-forms (ctor body before-method-p) + (let* ((class (ctor-class ctor)) + (wrapper (class-wrapper class)) + (allocation-function (raw-instance-allocator class)) + (slots-fetcher (slots-fetcher class))) + (if (eq allocation-function 'allocate-standard-instance) + `(let ((.instance. (%make-standard-instance nil + (get-instance-hash-code))) + (.slots. (make-array + ,(sb-kernel:layout-length wrapper) + ,@(when before-method-p + '(:initial-element +slot-unbound+))))) + (setf (std-instance-wrapper .instance.) ,wrapper) + (setf (std-instance-slots .instance.) .slots.) + ,body + .instance.) + `(let* ((.instance. (,allocation-function ,wrapper)) + (.slots. (,slots-fetcher .instance.))) + ,body + .instance.)))) + +;;; +;;; Return a form for invoking METHOD with arguments from ARGS. As +;;; can be seen in METHOD-FUNCTION-FROM-FAST-FUNCTION, method +;;; functions look like (LAMBDA (ARGS NEXT-METHODS) ...). We could +;;; call fast method functions directly here, but benchmarks show that +;;; there's no speed to gain, so lets avoid the hair here. +;;; +(defmacro invoke-method (method args) + `(funcall ,(method-function method) ,args ())) + +;;; +;;; Return a form that is sort of an effective method comprising all +;;; calls to INITIALIZE-INSTANCE and SHARED-INITIALIZE that would +;;; normally have taken place when calling MAKE-INSTANCE. +;;; +(defun fake-initialization-emf (ctor ii-methods si-methods) + (multiple-value-bind (ii-around ii-before ii-primary ii-after) + (standard-sort-methods ii-methods) + (declare (ignore ii-primary)) + (multiple-value-bind (si-around si-before si-primary si-after) + (standard-sort-methods si-methods) + (declare (ignore si-primary)) + (assert (and (null ii-around) (null si-around))) + (let ((initargs (ctor-initargs ctor)) + (slot-inits (slot-init-forms ctor (or ii-before si-before)))) + (values + `(let (,@(when (or ii-before ii-after) + `((.ii-args. (list .instance. ,@initargs)))) + ,@(when (or si-before si-after) + `((.si-args. (list .instance. t ,@initargs))))) + ,@(loop for method in ii-before + collect `(invoke-method ,method .ii-args.)) + ,@(loop for method in si-before + collect `(invoke-method ,method .si-args.)) + ,slot-inits + ,@(loop for method in si-after + collect `(invoke-method ,method .si-args.)) + ,@(loop for method in ii-after + collect `(invoke-method ,method .ii-args.))) + (or ii-before si-before)))))) + +;;; +;;; Return four values from APPLICABLE-METHODS: around methods, before +;;; methods, the applicable primary method, and applicable after +;;; methods. Before and after methods are sorted in the order they +;;; must be called. +;;; +(defun standard-sort-methods (applicable-methods) + (loop for method in applicable-methods + as qualifiers = (method-qualifiers method) + if (null qualifiers) + collect method into primary + else if (eq :around (car qualifiers)) + collect method into around + else if (eq :after (car qualifiers)) + collect method into after + else if (eq :before (car qualifiers)) + collect method into before + finally + (return (values around before (first primary) (reverse after))))) + +;;; +;;; Return a form initializing instance and class slots of an object +;;; costructed by CTOR. The variable .SLOTS. is assumed to bound to +;;; the instance's slot vector. BEFORE-METHOD-P T means +;;; before-methods will be called, which means that 1) other code will +;;; initialize instance slots to +SLOT-UNBOUND+ before the +;;; before-methods are run, and that we have to check if these +;;; before-methods have set slots. +;;; +(defun slot-init-forms (ctor before-method-p) + (let* ((class (ctor-class ctor)) + (initargs (ctor-initargs ctor)) + (initkeys (plist-keys initargs)) + (slot-vector + (make-array (sb-kernel:layout-length (class-wrapper class)) + :initial-element nil)) + (class-inits ()) + (default-initargs (class-default-initargs class)) + (initarg-locations + (compute-initarg-locations + class (append initkeys (mapcar #'car default-initargs))))) + (labels ((initarg-locations (initarg) + (cdr (assoc initarg initarg-locations :test #'eq))) + + (class-init (location type val) + (assert (consp location)) + (unless (assoc location class-inits :test #'eq) + (push (list location type val) class-inits))) + + (instance-init (location type val) + (assert (integerp location)) + (assert (not (instance-slot-initialized-p location))) + (setf (aref slot-vector location) (list type val))) + + (instance-slot-initialized-p (location) + (not (null (aref slot-vector location))))) + ;; + ;; Loop over supplied initargs and values and record which + ;; instance and class slots they initialize. + (loop for (key value) on initargs by #'cddr + as locations = (initarg-locations key) do + (if (constantp value) + (dolist (location locations) + (if (consp location) + (class-init location 'constant value) + (instance-init location 'constant value))) + (dolist (location locations) + (if (consp location) + (class-init location 'param value) + (instance-init location 'param value))))) + ;; + ;; Loop over default initargs of the class, recording + ;; initializations of slots that have not been initialized + ;; above. + (loop for (key initfn initform) in default-initargs do + (unless (member key initkeys :test #'eq) + (if (constantp initform) + (dolist (location (initarg-locations key)) + (if (consp location) + (class-init location 'constant initform) + (instance-init location 'constant initform))) + (dolist (location (initarg-locations key)) + (if (consp location) + (class-init location 'initfn initfn) + (instance-init location 'initfn initfn)))))) + ;; + ;; Loop over all slots of the class, filling in the rest from + ;; slot initforms. + (loop for slotd in (class-slots class) + as location = (slot-definition-location slotd) + as allocation = (slot-definition-allocation slotd) + as initfn = (slot-definition-initfunction slotd) + as initform = (slot-definition-initform slotd) do + (unless (or (eq allocation :class) + (null initfn) + (instance-slot-initialized-p location)) + (if (constantp initform) + (instance-init location 'initform initform) + (instance-init location 'initform/initfn initfn)))) + ;; + ;; Generate the forms for initializing instance and class slots. + (let ((instance-init-forms + (loop for slot-entry across slot-vector and i from 0 + as (type value) = slot-entry collect + (ecase type + ((nil) + (unless before-method-p + `(setf (clos-slots-ref .slots. ,i) +slot-unbound+))) + (param + `(setf (clos-slots-ref .slots. ,i) ,value)) + (initfn + `(setf (clos-slots-ref .slots. ,i) (funcall ,value))) + (initform/initfn + (if before-method-p + `(when (eq (clos-slots-ref .slots. ,i) + +slot-unbound+) + (setf (clos-slots-ref .slots. ,i) + (funcall ,value))) + `(setf (clos-slots-ref .slots. ,i) + (funcall ,value)))) + (initform + (if before-method-p + `(when (eq (clos-slots-ref .slots. ,i) + +slot-unbound+) + (setf (clos-slots-ref .slots. ,i) + ',(eval value))) + `(setf (clos-slots-ref .slots. ,i) + ',(eval value)))) + (constant + `(setf (clos-slots-ref .slots. ,i) ',(eval value)))))) + (class-init-forms + (loop for (location type value) in class-inits collect + `(setf (cdr ',location) + ,(ecase type + (constant `',(eval value)) + (param `,value) + (initfn `(funcall ,value))))))) + `(progn + ,@(delete nil instance-init-forms) + ,@class-init-forms))))) + +;;; +;;; Return an alist of lists (KEY LOCATION ...) telling, for each +;;; key in INITKEYS, which locations the initarg initializes. +;;; CLASS is the class of the instance being initialized. +;;; +(defun compute-initarg-locations (class initkeys) + (loop with slots = (class-slots class) + for key in initkeys collect + (loop for slot in slots + if (memq key (slot-definition-initargs slot)) + collect (slot-definition-location slot) into locations + else + collect slot into remaining-slots + finally + (setq slots remaining-slots) + (return (cons key locations))))) + + +;;; ******************************* +;;; External Entry Points ******** +;;; ******************************* + +(defun update-ctors (reason &key class name generic-function method) + (flet ((reset-class-ctors (class) + (loop for ctor in (plist-value class 'ctors) do + (install-initial-constructor ctor)))) + (ecase reason + ;; + ;; CLASS must have been specified. + (finalize-inheritance + (reset-class-ctors class)) + ;; + ;; NAME must have been specified. + (setf-find-class + (loop for ctor in *all-ctors* + when (eq (ctor-class-name ctor) name) do + (when (ctor-class ctor) + (reset-class-ctors (ctor-class ctor))) + (loop-finish))) + ;; + ;; GENERIC-FUNCTION and METHOD must have been specified. + ((add-method remove-method) + (case (generic-function-name generic-function) + ((make-instance allocate-instance initialize-instance + shared-initialize) + (let ((type (first (method-specializers method)))) + (reset-class-ctors (type-class type))))))))) + +(defun precompile-ctors () + (dolist (ctor *all-ctors*) + (when (null (ctor-class ctor)) + (let ((class (find-class (ctor-class-name ctor) nil))) + (when (and class (class-finalized-p class)) + (install-optimized-constructor ctor)))))) + +;;; end of ctor.lisp diff --git a/src/pcl/generic-functions.lisp b/src/pcl/generic-functions.lisp index f91adbf..8734818 100644 --- a/src/pcl/generic-functions.lisp +++ b/src/pcl/generic-functions.lisp @@ -332,8 +332,6 @@ (defgeneric compute-effective-slot-definition-initargs (class direct-slotds)) -(defgeneric default-initargs (class supplied-initargs)) - (defgeneric describe-object (object stream)) (defgeneric direct-slot-definition-class (class initargs)) @@ -419,6 +417,8 @@ (defgeneric compute-slot-accessor-info (slotd type gf)) +(defgeneric default-initargs (class initargs defaults)) + (defgeneric find-method-combination (generic-function type options)) (defgeneric (setf slot-accessor-function) (function slotd type)) diff --git a/src/pcl/init.lisp b/src/pcl/init.lisp index 47b8988..1a31762 100644 --- a/src/pcl/init.lisp +++ b/src/pcl/init.lisp @@ -30,47 +30,38 @@ (defmethod make-instance ((class class) &rest initargs) (unless (class-finalized-p class) (finalize-inheritance class)) - (setq initargs (default-initargs class initargs)) - #|| - (check-initargs-1 - class initargs - (list (list* 'allocate-instance class initargs) - (list* 'initialize-instance (class-prototype class) initargs) - (list* 'shared-initialize (class-prototype class) t initargs))) - ||# - (let* ((info (initialize-info class initargs)) - (valid-p (initialize-info-valid-p info))) - (when (and (consp valid-p) (eq (car valid-p) :invalid)) - (error 'simple-program-error - :format-control "Invalid initialization argument ~S for class ~S" - :format-arguments (list (cdr valid-p) (class-name class))))) - (let ((instance (apply #'allocate-instance class initargs))) - (apply #'initialize-instance instance initargs) - instance)) + (let ((class-default-initargs (class-default-initargs class))) + (when class-default-initargs + (setf initargs (default-initargs class initargs class-default-initargs))) + (when initargs + (when (and (eq *boot-state* 'complete) + (not (getf initargs :allow-other-keys))) + (let ((class-proto (class-prototype class))) + (check-initargs-1 + class initargs + (append (compute-applicable-methods + #'allocate-instance (list class)) + (compute-applicable-methods + #'initialize-instance (list class-proto)) + (compute-applicable-methods + #'shared-initialize (list class-proto t))))))) + (let ((instance (apply #'allocate-instance class initargs))) + (apply #'initialize-instance instance initargs) + instance))) -(defmethod default-initargs ((class slot-class) supplied-initargs) - (call-initialize-function - (initialize-info-default-initargs-function - (initialize-info class supplied-initargs)) - nil supplied-initargs)) +(defmethod default-initargs ((class slot-class) + supplied-initargs + class-default-initargs) + (loop for (key fn) in class-default-initargs + when (eq (getf supplied-initargs key '.not-there.) '.not-there.) + append (list key (funcall fn)) into default-initargs + finally + (return (append supplied-initargs default-initargs)))) (defmethod initialize-instance ((instance slot-object) &rest initargs) (apply #'shared-initialize instance t initargs)) (defmethod reinitialize-instance ((instance slot-object) &rest initargs) - #|| - (check-initargs-1 - (class-of instance) initargs - (list (list* 'reinitialize-instance instance initargs) - (list* 'shared-initialize instance nil initargs))) - ||# - (let* ((class (class-of instance)) - (info (initialize-info class initargs)) - (valid-p (initialize-info-ri-valid-p info))) - (when (and (consp valid-p) (eq (car valid-p) :invalid)) - (error 'simple-program-error - :format-control "Invalid initialization argument ~S for class ~S" - :format-arguments (list (cdr valid-p) (class-name class))))) (apply #'shared-initialize instance nil initargs) instance) @@ -106,57 +97,44 @@ (list* 'shared-initialize instance added-slots initargs))) (apply #'shared-initialize instance added-slots initargs)) -(defmethod shared-initialize - ((instance slot-object) slot-names &rest initargs) - (cond - ((eq slot-names t) - (call-initialize-function - (initialize-info-shared-initialize-t-fun - (initialize-info (class-of instance) initargs)) - instance initargs)) - ((eq slot-names nil) - (call-initialize-function - (initialize-info-shared-initialize-nil-fun - (initialize-info (class-of instance) initargs)) - instance initargs)) - (t - ;; Initialize the instance's slots in a two step process: - ;; (1) A slot for which one of the initargs in initargs can set - ;; the slot, should be set by that initarg. If more than - ;; one initarg in initargs can set the slot, the leftmost - ;; one should set it. - ;; (2) Any slot not set by step 1, may be set from its initform - ;; by step 2. Only those slots specified by the slot-names - ;; argument are set. If slot-names is: - ;; T - ;; then any slot not set in step 1 is set from its - ;; initform. - ;; - ;; then any slot in the list, and not set in step 1 - ;; is set from its initform. - ;; () - ;; then no slots are set from initforms. - (flet ((initialize-slot-from-initarg (class instance slotd) - (let ((slot-initargs (slot-definition-initargs slotd))) - (doplist (initarg value) initargs - (when (memq initarg slot-initargs) - (setf (slot-value-using-class class instance slotd) - value) - (return t))))) - (initialize-slot-from-initfunction (class instance slotd) - (unless (or (slot-boundp-using-class class instance slotd) - (null (slot-definition-initfunction slotd))) - (setf (slot-value-using-class class instance slotd) - (funcall (slot-definition-initfunction slotd))))) - (class-slot-p (slotd) - (eq :class (slot-definition-allocation slotd)))) - (loop with class = (class-of instance) - for slotd in (class-slots class) - unless (or (class-slot-p slotd) - (initialize-slot-from-initarg class instance slotd)) - when (memq (slot-definition-name slotd) slot-names) do - (initialize-slot-from-initfunction class instance slotd)) - instance)))) +(defmethod shared-initialize ((instance slot-object) slot-names &rest initargs) + (flet ((initialize-slot-from-initarg (class instance slotd) + (let ((slot-initargs (slot-definition-initargs slotd))) + (doplist (initarg value) initargs + (when (memq initarg slot-initargs) + (setf (slot-value-using-class class instance slotd) + value) + (return t))))) + (initialize-slot-from-initfunction (class instance slotd) + ;; CLHS: If a before method stores something in a slot, + ;; that slot won't be initialized from its :INITFORM, if any. + (if (typep instance 'structure-object) + (when (eq (funcall + ;; not SLOT-VALUE-USING-CLASS, as that + ;; throws an error if the value is the + ;; unbound marker. + (slot-definition-internal-reader-function slotd) + instance) + +slot-unbound+) + (setf (slot-value-using-class class instance slotd) + (let ((initfn (slot-definition-initfunction slotd))) + (when initfn + (funcall initfn))))) + (unless (or (slot-boundp-using-class class instance slotd) + (null (slot-definition-initfunction slotd))) + (setf (slot-value-using-class class instance slotd) + (funcall (slot-definition-initfunction slotd))))))) + (let* ((class (class-of instance)) + (initfn-slotds + (loop for slotd in (class-slots class) + unless (initialize-slot-from-initarg class instance slotd) + collect slotd))) + (loop for slotd in initfn-slotds + when (and (not (eq :class (slot-definition-allocation slotd))) + (or (eq t slot-names) + (memq (slot-definition-name slotd) slot-names))) do + (initialize-slot-from-initfunction class instance slotd))) + instance)) ;;; If initargs are valid return nil, otherwise signal an error. (defun check-initargs-1 (class initargs call-list diff --git a/src/pcl/low.lisp b/src/pcl/low.lisp index d4a4af5..e9e0276 100644 --- a/src/pcl/low.lisp +++ b/src/pcl/low.lisp @@ -230,13 +230,10 @@ (defmacro precompile-random-code-segments (&optional system) `(progn (eval-when (:compile-toplevel) - (update-dispatch-dfuns) - (compile-iis-functions nil)) + (update-dispatch-dfuns)) (precompile-function-generators ,system) (precompile-dfun-constructors ,system) - (precompile-iis-functions ,system) - (eval-when (:load-toplevel) - (compile-iis-functions t)))) + (precompile-ctors))) ;;; This definition is for interpreted code. (defun pcl-instance-p (x) diff --git a/src/pcl/macros.lisp b/src/pcl/macros.lisp index baec938..2add735 100644 --- a/src/pcl/macros.lisp +++ b/src/pcl/macros.lisp @@ -180,13 +180,7 @@ (when (and new-value (class-wrapper new-value)) (setf (find-class-cell-predicate cell) (fdefinition (class-predicate-name new-value)))) - (when (and new-value (not (forward-referenced-class-p new-value))) - - (dolist (keys+aok (find-class-cell-make-instance-function-keys - cell)) - (update-initialize-info-internal - (initialize-info new-value (car keys+aok) nil (cdr keys+aok)) - 'make-instance-function)))) + (update-ctors 'setf-find-class :class new-value :name symbol)) new-value) (error "~S is not a legal class name." symbol))) diff --git a/src/pcl/methods.lisp b/src/pcl/methods.lisp index c836f80..8d5b2f0 100644 --- a/src/pcl/methods.lisp +++ b/src/pcl/methods.lisp @@ -508,12 +508,9 @@ (when remove-again-p (remove-method generic-function method)))) (unless skip-dfun-update-p - (when (member name - '(make-instance default-initargs - allocate-instance shared-initialize - initialize-instance)) - (update-make-instance-function-table (type-class - (car specializers)))) + (update-ctors 'add-method + :generic-function generic-function + :method method) (update-dfun generic-function)) method))) @@ -529,11 +526,9 @@ (dolist (specializer (method-specializers method)) (remove-direct-method specializer method)) (set-arg-info generic-function) - (when (member name - '(make-instance - default-initargs - allocate-instance shared-initialize initialize-instance)) - (update-make-instance-function-table (type-class (car specializers)))) + (update-ctors 'remove-method + :generic-function generic-function + :method method) (update-dfun generic-function) generic-function))) diff --git a/src/pcl/std-class.lisp b/src/pcl/std-class.lisp index adb1282..c089b05 100644 --- a/src/pcl/std-class.lisp +++ b/src/pcl/std-class.lisp @@ -740,7 +740,7 @@ (update-slots class (compute-slots class)) (update-gfs-of-class class) (update-inits class (compute-default-initargs class)) - (update-make-instance-function-table class)) + (update-ctors 'finalize-inheritance :class class)) (unless finalizep (dolist (sub (class-direct-subclasses class)) (update-class sub nil)))) diff --git a/src/pcl/vector.lisp b/src/pcl/vector.lisp index c4d7eba..292e763 100644 --- a/src/pcl/vector.lisp +++ b/src/pcl/vector.lisp @@ -388,8 +388,7 @@ slots calls) (declare (ignore required-parameters env slots calls)) - (or (and (eq (car form) 'make-instance) - (expand-make-instance-form form)) + (or ; (optimize-reader ...)? form)) (defun can-optimize-access (form required-parameters env) diff --git a/tests/clos.impure-cload.lisp b/tests/clos.impure-cload.lisp index 40b53e1..b5c96f0 100644 --- a/tests/clos.impure-cload.lisp +++ b/tests/clos.impure-cload.lisp @@ -28,5 +28,31 @@ (mio-test) +;;; Some tests of bits of optimized MAKE-INSTANCE that were hopelessly +;;; wrong until Gerd's ctor MAKE-INSTANCE optimization was ported. +(defvar *d-i-s-e-count* 0) +(defclass default-initargs-side-effect () + ((x :initarg :x)) + (:default-initargs :x (incf *d-i-s-e-count*))) +(defun default-initargs-side-effect () + (make-instance 'default-initargs-side-effect)) +(assert (= *d-i-s-e-count* 0)) +(default-initargs-side-effect) +(assert (= *d-i-s-e-count* 1)) +(make-instance 'default-initargs-side-effect) +(assert (= *d-i-s-e-count* 2)) +(make-instance 'default-initargs-side-effect :x 3) +(assert (= *d-i-s-e-count* 2)) + +(defclass class-allocation () + ((x :allocation :class :initarg :x :initform 3))) +(defun class-allocation-reader () + (slot-value (make-instance 'class-allocation) 'x)) +(defun class-allocation-writer (value) + (setf (slot-value (make-instance 'class-allocation) 'x) value)) +(assert (= (class-allocation-reader) 3)) +(class-allocation-writer 4) +(assert (= (class-allocation-reader) 4)) + ;;; success (sb-ext:quit :unix-status 104) \ No newline at end of file diff --git a/version.lisp-expr b/version.lisp-expr index c8ff92b..5d2b938 100644 --- a/version.lisp-expr +++ b/version.lisp-expr @@ -18,4 +18,4 @@ ;;; versions, especially for internal versions off the main CVS ;;; branch, it gets hairier, e.g. "0.pre7.14.flaky4.13".) -"0.7.10.30" +"0.7.10.31" -- 1.7.10.4