1.0.40.6: call an appropriate existing ctor from MAKE-INSTANCE (CLASS)

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.

diff --git a/NEWS b/NEWS
index 401be82..b17d87e 100644 (file)
--- a/NEWS
+++ b/NEWS
@@ -3,6 +3,9 @@ changes relative to sbcl-1.0.40:
   * 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:

diff --git a/src/pcl/ctor.lisp b/src/pcl/ctor.lisp
index 5c48952..06b69dd 100644 (file)
--- a/src/pcl/ctor.lisp
+++ b/src/pcl/ctor.lisp
@@ -124,7 +124,7 @@
 ;;; 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
@@ -142,7 +142,8 @@
 ;;; 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)
@@ -163,7 +164,7 @@
 ;;; 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)
@@ -465,14 +466,15 @@
         (%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))))
-               locations))))))
+               locations)
+              (ctor-state ctor) (if optimizedp 'optimized 'fallback))))))
 
 (defun constructor-function-form (ctor)
   (let* ((class (ctor-class ctor))
@@ -617,7 +619,8 @@
              (return (funcall ,ctor ,@(make-ctor-parameter-list ctor))))
            ,(wrap-in-allocate-forms ctor body before-method-p)))
        locations
-       names))))
+       names
+       t))))
 
 ;;; Return a form wrapped around BODY that allocates an instance
 ;;; constructed by CTOR.  BEFORE-METHOD-P set means we have to run
@@ -965,6 +968,28 @@
         (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))

diff --git a/src/pcl/init.lisp b/src/pcl/init.lisp
index 27342bd..a73f353 100644 (file)
--- a/src/pcl/init.lisp
+++ b/src/pcl/init.lisp
@@ -29,6 +29,9 @@
   (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

diff --git a/version.lisp-expr b/version.lisp-expr
index d54095e..70d10a2 100644 (file)
--- a/version.lisp-expr
+++ b/version.lisp-expr
@@ -17,4 +17,4 @@
 ;;; 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".)
-"1.0.40.5"
+"1.0.40.6"