Update of /cvsroot/sbcl/sbcl/src/pcl
In directory sc8-pr-cvs1:/tmp/cvs-serv28205/src/pcl
Modified Files:
boot.lisp generic-functions.lisp init.lisp low.lisp
macros.lisp methods.lisp std-class.lisp vector.lisp
Added Files:
ctor.lisp
Log Message:
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
--- NEW FILE: ctor.lisp ---
;;;; 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 <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
Index: boot.lisp
===================================================================
RCS file: /cvsroot/sbcl/sbcl/src/pcl/boot.lisp,v
retrieving revision 1.61
retrieving revision 1.62
diff -u -d -r1.61 -r1.62
--- boot.lisp 14 Nov 2002 19:03:18 -0000 1.61
+++ boot.lisp 23 Dec 2002 13:53:00 -0000 1.62
@@ -347,10 +347,8 @@
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 @@
;; 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*)))
Index: generic-functions.lisp
===================================================================
RCS file: /cvsroot/sbcl/sbcl/src/pcl/generic-functions.lisp,v
retrieving revision 1.15
retrieving revision 1.16
diff -u -d -r1.15 -r1.16
--- generic-functions.lisp 15 Nov 2002 14:47:06 -0000 1.15
+++ generic-functions.lisp 23 Dec 2002 13:53:00 -0000 1.16
@@ -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))
@@ -418,6 +416,8 @@
applicable-methods))
(defgeneric compute-slot-accessor-info (slotd type gf))
+
+(defgeneric default-initargs (class initargs defaults))
(defgeneric find-method-combination (generic-function type options))
Index: init.lisp
===================================================================
RCS file: /cvsroot/sbcl/sbcl/src/pcl/init.lisp,v
retrieving revision 1.9
retrieving revision 1.10
diff -u -d -r1.9 -r1.10
--- init.lisp 9 Oct 2002 17:03:33 -0000 1.9
+++ init.lisp 23 Dec 2002 13:53:00 -0000 1.10
@@ -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.
- ;; <list of slot names>
- ;; 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
Index: low.lisp
===================================================================
RCS file: /cvsroot/sbcl/sbcl/src/pcl/low.lisp,v
retrieving revision 1.25
retrieving revision 1.26
diff -u -d -r1.25 -r1.26
--- low.lisp 14 Nov 2002 19:03:19 -0000 1.25
+++ low.lisp 23 Dec 2002 13:53:00 -0000 1.26
@@ -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)
Index: macros.lisp
===================================================================
RCS file: /cvsroot/sbcl/sbcl/src/pcl/macros.lisp,v
retrieving revision 1.18
retrieving revision 1.19
diff -u -d -r1.18 -r1.19
--- macros.lisp 2 Sep 2002 03:18:08 -0000 1.18
+++ macros.lisp 23 Dec 2002 13:53:00 -0000 1.19
@@ -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)))
Index: methods.lisp
===================================================================
RCS file: /cvsroot/sbcl/sbcl/src/pcl/methods.lisp,v
retrieving revision 1.18
retrieving revision 1.19
diff -u -d -r1.18 -r1.19
--- methods.lisp 8 Nov 2002 16:23:02 -0000 1.18
+++ methods.lisp 23 Dec 2002 13:53:00 -0000 1.19
@@ -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)))
Index: std-class.lisp
===================================================================
RCS file: /cvsroot/sbcl/sbcl/src/pcl/std-class.lisp,v
retrieving revision 1.35
retrieving revision 1.36
diff -u -d -r1.35 -r1.36
--- std-class.lisp 19 Nov 2002 19:02:15 -0000 1.35
+++ std-class.lisp 23 Dec 2002 13:53:00 -0000 1.36
@@ -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))))
Index: vector.lisp
===================================================================
RCS file: /cvsroot/sbcl/sbcl/src/pcl/vector.lisp,v
retrieving revision 1.22
retrieving revision 1.23
diff -u -d -r1.22 -r1.23
--- vector.lisp 28 Sep 2002 14:39:43 -0000 1.22
+++ vector.lisp 23 Dec 2002 13:53:00 -0000 1.23
@@ -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)
|