The intuition here is that searching for a ctor is much cheaper than
the whole of the unoptimized make-instance machinery. If a class has
many, many ctors, this may not be true, but that should be the rare
case.
Only call optimized ctors so that we don't risk endless recursion
through the fallback case.
* optimization: validity of observed keyword initargs to MAKE-INSTANCE is
cached, leading to many fewer expensive calls to
COMPUTE-APPLICABLE-METHODS.
* optimization: validity of observed keyword initargs to MAKE-INSTANCE is
cached, leading to many fewer expensive calls to
COMPUTE-APPLICABLE-METHODS.
+ * optimization: in the (unoptimized) general method for MAKE-INSTANCE on a
+ CLASS argument, search for and call an appropriate optimized ctor function
+ if it exists.
* bug fix: WRITE always returns the correct value.
changes in sbcl-1.0.40 relative to sbcl-1.0.39:
* bug fix: WRITE always returns the correct value.
changes in sbcl-1.0.40 relative to sbcl-1.0.39:
;;; funcallable instance is set to it.
;;;
(!defstruct-with-alternate-metaclass ctor
;;; funcallable instance is set to it.
;;;
(!defstruct-with-alternate-metaclass ctor
- :slot-names (function-name class-or-name class initargs safe-p)
+ :slot-names (function-name class-or-name class initargs state safe-p)
:boa-constructor %make-ctor
:superclass-name function
:metaclass-name static-classoid
:boa-constructor %make-ctor
:superclass-name function
:metaclass-name static-classoid
;;; optimized constructor function when called.
(defun install-initial-constructor (ctor &key force-p)
(when (or force-p (ctor-class ctor))
;;; 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 (ctor-class ctor) nil
+ (ctor-state ctor) 'initial)
(setf (funcallable-instance-fun ctor)
#'(lambda (&rest args)
(install-optimized-constructor ctor)
(setf (funcallable-instance-fun ctor)
#'(lambda (&rest args)
(install-optimized-constructor ctor)
;;; Keep this a separate function for testing.
(defun make-ctor (function-name class-name initargs safe-p)
(without-package-locks ; for (setf symbol-function)
;;; Keep this a separate function for testing.
(defun make-ctor (function-name class-name initargs safe-p)
(without-package-locks ; for (setf symbol-function)
- (let ((ctor (%make-ctor function-name class-name nil initargs safe-p)))
+ (let ((ctor (%make-ctor function-name class-name nil initargs nil safe-p)))
(install-initial-constructor ctor :force-p t)
(push ctor *all-ctors*)
(setf (fdefinition function-name) ctor)
(install-initial-constructor ctor :force-p t)
(push ctor *all-ctors*)
(setf (fdefinition function-name) ctor)
(%force-cache-flushes class))
(setf (ctor-class ctor) class)
(pushnew ctor (plist-value class 'ctors) :test #'eq)
(%force-cache-flushes class))
(setf (ctor-class ctor) class)
(pushnew ctor (plist-value class 'ctors) :test #'eq)
- (setf (funcallable-instance-fun ctor)
- (multiple-value-bind (form locations names)
- (constructor-function-form ctor)
+ (multiple-value-bind (form locations names optimizedp)
+ (constructor-function-form ctor)
+ (setf (funcallable-instance-fun ctor)
(apply
(let ((*compiling-optimized-constructor* t))
(handler-bind ((compiler-note #'muffle-warning))
(compile nil `(lambda ,names ,form))))
(apply
(let ((*compiling-optimized-constructor* t))
(handler-bind ((compiler-note #'muffle-warning))
(compile nil `(lambda ,names ,form))))
+ locations)
+ (ctor-state ctor) (if optimizedp 'optimized 'fallback))))))
(defun constructor-function-form (ctor)
(let* ((class (ctor-class ctor))
(defun constructor-function-form (ctor)
(let* ((class (ctor-class ctor))
(return (funcall ,ctor ,@(make-ctor-parameter-list ctor))))
,(wrap-in-allocate-forms ctor body before-method-p)))
locations
(return (funcall ,ctor ,@(make-ctor-parameter-list ctor))))
,(wrap-in-allocate-forms ctor body before-method-p)))
locations
;;; Return a form wrapped around BODY that allocates an instance
;;; constructed by CTOR. BEFORE-METHOD-P set means we have to run
;;; Return a form wrapped around BODY that allocates an instance
;;; constructed by CTOR. BEFORE-METHOD-P set means we have to run
(when (and class (class-finalized-p class))
(install-optimized-constructor ctor))))))
(when (and class (class-finalized-p class))
(install-optimized-constructor ctor))))))
+(defun maybe-call-ctor (class initargs)
+ (flet ((frob-initargs (ctor)
+ (do ((ctail (ctor-initargs ctor))
+ (itail initargs)
+ (args nil))
+ ((or (null ctail) (null itail))
+ (values (nreverse args) (and (null ctail) (null itail))))
+ (unless (eq (pop ctail) (pop itail))
+ (return nil))
+ (let ((cval (pop ctail))
+ (ival (pop itail)))
+ (if (constantp cval)
+ (unless (eql cval ival)
+ (return nil))
+ (push ival args))))))
+ (dolist (ctor (plist-value class 'ctors))
+ (when (eq (ctor-state ctor) 'optimized)
+ (multiple-value-bind (ctor-args matchp)
+ (frob-initargs ctor)
+ (when matchp
+ (return (apply ctor ctor-args))))))))
+
;;; FIXME: CHECK-FOO-INITARGS share most of their bodies.
(defun check-mi-initargs (class initargs)
(let* ((class-proto (class-prototype class))
;;; FIXME: CHECK-FOO-INITARGS share most of their bodies.
(defun check-mi-initargs (class initargs)
(let* ((class-proto (class-prototype class))
(apply #'make-instance (find-class class) initargs))
(defmethod make-instance ((class class) &rest initargs)
(apply #'make-instance (find-class class) initargs))
(defmethod make-instance ((class class) &rest initargs)
+ (let ((instance-or-nil (maybe-call-ctor class initargs)))
+ (when instance-or-nil
+ (return-from make-instance instance-or-nil)))
(unless (class-finalized-p class) (finalize-inheritance class))
(let ((class-default-initargs (class-default-initargs class)))
(when class-default-initargs
(unless (class-finalized-p class) (finalize-inheritance class))
(let ((class-default-initargs (class-default-initargs class)))
(when class-default-initargs
;;; checkins which aren't released. (And occasionally for internal
;;; versions, especially for internal versions off the main CVS
;;; branch, it gets hairier, e.g. "0.pre7.14.flaky4.13".)
;;; checkins which aren't released. (And occasionally for internal
;;; versions, especially for internal versions off the main CVS
;;; branch, it gets hairier, e.g. "0.pre7.14.flaky4.13".)