common-lisp/sbcl.sbcl
1
0
Fork 0
mirror of git://git.code.sf.net/p/sbcl/sbcl synced 2026-09-10 07:26:40 -04:00
Code Issues Actions 8 Packages Projects Releases Wiki Activity

0.7.10.31:

Browse source 
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
This commit is contained in:
Christophe Rhodes 2002-12-23 13:52:59 +00:00
parent caf8bb05a8
commit 1e08b23e73
15 changed files with 714 additions and 131 deletions
Show stats Download patch file Download diff file Expand all files Collapse all files

9
COPYING
View file

@ -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.

5
CREDITS
View file

@ -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

12
NEWS
View file

@ -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

2
src/cold/warm.lisp
View file

@ -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"

7
src/pcl/boot.lisp
View file

@ -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*)))

591
src/pcl/ctor.lisp Normal file
View file

@ -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 <gerd.moellmann@t-online.de>
;;; 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

4
src/pcl/generic-functions.lisp
View file

@ -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))

150
src/pcl/init.lisp
View file

@ -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

7
src/pcl/low.lisp
View file

@ -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)

8
src/pcl/macros.lisp
View file

@ -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)))

17
src/pcl/methods.lisp
View file

@ -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)))

2
src/pcl/std-class.lisp
View file

@ -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))))

3
src/pcl/vector.lisp
View file

@ -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)

26
tests/clos.impure-cload.lisp
View file

@ -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)

2
version.lisp-expr
View file

@ -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"