1.0.29.45: another CTOR optimization

* If we're forced to use the fallback generator, but the initargs can be
  verified early on and there are no extra methods on MAKE-INSTANCE
  we don't have to go through full MAKE-INSTANCE: instead use
  FAST-MAKE-INSTANCE. 1 less GF call and no initarg checking at runtime
  yields a ~2-4 fold performance improvement.

diff --git a/NEWS b/NEWS
index b917c8d..f73899a 100644 (file)
--- a/NEWS
+++ b/NEWS
@@ -11,6 +11,10 @@
     about object allocation.
   * optimization: MAKE-INSTANCE with non-constant class-argument but constant
     keywords is an order of magnitude faster.
+  * optimization: MAKE-INSTANCE with constant keyword arguments is somewhat
+    faster for non-standard metaclass classes as long as there are no methods
+    additional on MAKE-INSTANCE and initialization arguments can be validated
+    at compile-time.
   * optimization: more efficient type-checks for FIXNUMs when the value
     is known to be a signed word on x86 and x86-64.
   * optimization: compiler now optimizes (EXPT -1 INTEGER), (EXPT -1.0 INTEGER),

diff --git a/src/pcl/ctor.lisp b/src/pcl/ctor.lisp
index 26b64e2..d330833 100644 (file)
--- a/src/pcl/ctor.lisp
+++ b/src/pcl/ctor.lisp
@@ -132,14 +132,13 @@
 ;;; optimized constructor function when called.
 (defun install-initial-constructor (ctor &key force-p)
   (when (or force-p (ctor-class ctor))
-    (let ((*installing-ctor* t))
-      (setf (ctor-class ctor) nil)
-      (setf (funcallable-instance-fun ctor)
-            #'(lambda (&rest args)
-                (install-optimized-constructor ctor)
-                (apply ctor args)))
-      (setf (%funcallable-instance-info ctor 1)
-            (ctor-function-name ctor)))))
+    (setf (ctor-class ctor) nil)
+    (setf (funcallable-instance-fun ctor)
+          #'(lambda (&rest args)
+              (install-optimized-constructor ctor)
+              (apply ctor args)))
+    (setf (%funcallable-instance-info ctor 1)
+          (ctor-function-name ctor))))
 
 (defun make-ctor-function-name (class-name initargs safe-code-p)
   (list* 'ctor class-name safe-code-p initargs))
@@ -501,34 +500,39 @@
     ;; MAKE-INSTANCE and/or ALLOCATE-INSTANCE, these will show up
     ;; together with the system-defined ones in what
     ;; COMPUTE-APPLICABLE-METHODS returns.
-    (if (and (not (structure-class-p class))
-             (not (condition-class-p class))
-             (null (cdr make-instance-methods))
-             (null (cdr allocate-instance-methods))
-             (every (lambda (x)
-                      (member (slot-definition-allocation x)
-                              '(:instance :class)))
-                    (class-slots class))
-             (null (check-initargs-1
-                    class
-                    (append
-                     (ctor-default-initkeys
-                      (ctor-initargs ctor) (class-default-initargs 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*))
-             ;; the instance structure protocol goes through
-             ;; slot-value(-using-class) and friends (actually just
-             ;; (SETF SLOT-VALUE-USING-CLASS) and
-             ;; SLOT-BOUNDP-USING-CLASS), so if there are non-standard
-             ;; applicable methods we can't shortcircuit them.
-             (every (lambda (x) (= (length x) 1)) setf-svuc-slots-methods)
-             (every (lambda (x) (= (length x) 1)) sbuc-slots-methods))
-        (optimizing-generator ctor ii-methods si-methods)
-        (fallback-generator ctor ii-methods si-methods))))
+    (let ((maybe-invalid-initargs
+           (check-initargs-1
+            class
+            (append
+             (ctor-default-initkeys
+              (ctor-initargs ctor) (class-default-initargs class))
+             (plist-keys (ctor-initargs ctor)))
+            (append ii-methods si-methods) nil nil))
+          (custom-make-instance
+           (not (null (cdr make-instance-methods)))))
+      (if (and (not (structure-class-p class))
+               (not (condition-class-p class))
+               (not custom-make-instance)
+               (null (cdr allocate-instance-methods))
+               (every (lambda (x)
+                        (member (slot-definition-allocation x)
+                                '(:instance :class)))
+                      (class-slots class))
+               (not maybe-invalid-initargs)
+               (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*))
+               ;; the instance structure protocol goes through
+               ;; slot-value(-using-class) and friends (actually just
+               ;; (SETF SLOT-VALUE-USING-CLASS) and
+               ;; SLOT-BOUNDP-USING-CLASS), so if there are non-standard
+               ;; applicable methods we can't shortcircuit them.
+               (every (lambda (x) (= (length x) 1)) setf-svuc-slots-methods)
+               (every (lambda (x) (= (length x) 1)) sbuc-slots-methods))
+          (optimizing-generator ctor ii-methods si-methods)
+          (fallback-generator ctor ii-methods si-methods
+                              (or maybe-invalid-initargs custom-make-instance))))))
 
 (defun around-or-nonstandard-primary-method-p
     (methods &optional standard-method)
@@ -546,16 +550,30 @@
         when (null qualifiers) do
           (setq primary-checked-p t)))
 
-(defun fallback-generator (ctor ii-methods si-methods)
+(defun fallback-generator (ctor ii-methods si-methods use-make-instance)
   (declare (ignore ii-methods si-methods))
-  `(lambda ,(make-ctor-parameter-list ctor)
-     ;; The CTOR MAKE-INSTANCE optimization only kicks in when the
-     ;; first argument to MAKE-INSTANCE is a constant symbol: by
-     ;; calling it with a class, as here, we inhibit the optimization,
-     ;; so removing the possibility of endless recursion.  -- CSR,
-     ;; 2004-07-12
-     (make-instance ,(ctor-class ctor)
-      ,@(quote-plist-keys (ctor-initargs ctor)))))
+  (let ((class (ctor-class ctor))
+        (lambda-list (make-ctor-parameter-list ctor))
+        (initargs (quote-plist-keys (ctor-initargs ctor))))
+    (if use-make-instance
+        `(lambda ,lambda-list
+           (declare #.*optimize-speed*)
+           ;; The CTOR MAKE-INSTANCE optimization checks for
+           ;; *COMPILING-OPTIMIZED-CONSTRUCTOR* which is bound around compilation of
+           ;; the constructor, hence avoiding the possibility of endless recursion.
+           (make-instance ,class ,@initargs))
+        `(lambda ,lambda-list
+           (declare #.*optimize-speed*)
+           (fast-make-instance ,class ,@initargs)))))
+
+;;; Not as good as the real optimizing generator, but faster than going
+;;; via MAKE-INSTANCE: 1 GF call less, and no need to check initargs.
+(defun fast-make-instance (class &rest initargs)
+  (declare #.*optimize-speed*)
+  (declare (dynamic-extent initargs))
+  (let ((.instance. (apply #'allocate-instance class initargs)))
+    (apply #'initialize-instance .instance. initargs)
+    .instance.))
 
 (defun optimizing-generator (ctor ii-methods si-methods)
   (multiple-value-bind (locations names body before-method-p)

diff --git a/version.lisp-expr b/version.lisp-expr
index 2bc95ad..4ad6157 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.29.43"
+"1.0.29.45"