1.0.40.3: better non-ctor make-instance

Actually, the really expensive bit is the initarg validity checking.
Use the ctor machinery to cache the results of testing for initarg
validity for make-instance as well as reinitialize-instance.  (Why
wasn't this done before?)

With this change, asdf.fasl loads about 10% faster.

diff --git a/NEWS b/NEWS
index 5877845..401be82 100644 (file)
--- a/NEWS
+++ b/NEWS
@@ -1,6 +1,9 @@
 ;;;; -*- coding: utf-8; fill-column: 78 -*-
-changes in sbcl-1.0.41 relative to sbcl-1.0.40:
-  * bug fix: WRITE always returns the correct value
+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.
+  * bug fix: WRITE always returns the correct value.
 
 changes in sbcl-1.0.40 relative to sbcl-1.0.39:
   * bug fix: readdir now works on :inode64 darwin builds (lp#592897)

diff --git a/src/pcl/ctor.lisp b/src/pcl/ctor.lisp
index 9bcfbd8..6f703ad 100644 (file)
--- a/src/pcl/ctor.lisp
+++ b/src/pcl/ctor.lisp
@@ -908,14 +908,15 @@
 ;;; *******************************
 
 (defun update-ctors (reason &key class name generic-function method)
-  (labels ((reset (class &optional ri-cache-p (ctorsp t))
+  (labels ((reset (class &optional initarg-caches-p (ctorsp t))
              (when ctorsp
                (dolist (ctor (plist-value class 'ctors))
                  (install-initial-constructor ctor)))
-             (when ri-cache-p
-               (setf (plist-value class 'ri-initargs) ()))
+             (when initarg-caches-p
+               (dolist (cache '(mi-initargs ri-initargs))
+                 (setf (plist-value class cache) ())))
              (dolist (subclass (class-direct-subclasses class))
-               (reset subclass ri-cache-p ctorsp))))
+               (reset subclass initarg-caches-p ctorsp))))
     (ecase reason
       ;; CLASS must have been specified.
       (finalize-inheritance
@@ -961,6 +962,30 @@
         (when (and class (class-finalized-p class))
           (install-optimized-constructor ctor))))))
 
+;;; FIXME: CHECK-FOO-INITARGS share most of their bodies.
+(defun check-mi-initargs (class initargs)
+  (let* ((class-proto (class-prototype class))
+         (keys (plist-keys initargs))
+         (cache (plist-value class 'mi-initargs))
+         (cached (assoc keys cache :test #'equal))
+         (invalid-keys
+          (if (consp cached)
+              (cdr cached)
+              (let ((invalid
+                     (check-initargs-1
+                      class initargs
+                      (list (list* 'allocate-instance class initargs)
+                            (list* 'initialize-instance class-proto initargs)
+                            (list* 'shared-initialize class-proto t initargs))
+                      t nil)))
+                (setf (plist-value class 'mi-initargs)
+                      (acons keys invalid cache))
+                invalid))))
+    (when invalid-keys
+      ;; FIXME: should have an operation here, and maybe a set of
+      ;; valid keys.
+      (error 'initarg-error :class class :initargs invalid-keys))))
+
 (defun check-ri-initargs (instance initargs)
   (let* ((class (class-of instance))
          (keys (plist-keys initargs))

diff --git a/src/pcl/init.lisp b/src/pcl/init.lisp
index 7e59506..27342bd 100644 (file)
--- a/src/pcl/init.lisp
+++ b/src/pcl/init.lisp
@@ -34,17 +34,8 @@
     (when class-default-initargs
       (setf initargs (default-initargs 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)))))))
+      (when (eq **boot-state** 'complete)
+        (check-mi-initargs class initargs)))
     (let ((instance (apply #'allocate-instance class initargs)))
       (apply #'initialize-instance instance initargs)
       instance)))

diff --git a/tests/clos.impure.lisp b/tests/clos.impure.lisp
index 91eab01..e08f7a7 100644 (file)
--- a/tests/clos.impure.lisp
+++ b/tests/clos.impure.lisp
@@ -1833,5 +1833,33 @@
                                                 "ok!"))
                                        (invoke-restart r))))))
                    (no-primary-method/retry (cons t t))))))
-
+\f
+;;; test that a cacheing strategy for make-instance initargs checking
+;;; can handle class redefinitions
+(defclass cacheing-initargs-redefinitions-check ()
+  ((slot :initarg :slot)))
+(defun cacheing-initargs-redefinitions-check-fun (&optional (initarg :slot))
+  (declare (notinline make-instance))
+  (make-instance 'cacheing-initargs-redefinitions-check)
+  (make-instance 'cacheing-initargs-redefinitions-check initarg 3))
+(with-test (:name :make-instance-initargs)
+  (make-instance 'cacheing-initargs-redefinitions-check)
+  (make-instance 'cacheing-initargs-redefinitions-check :slot 3)
+  (cacheing-initargs-redefinitions-check-fun :slot)
+  (assert (raises-error? (cacheing-initargs-redefinitions-check-fun :slot2))))
+(defclass cacheing-initargs-redefinitions-check ()
+  ((slot :initarg :slot2)))
+(with-test (:name :make-instance-redefined-initargs)
+  (make-instance 'cacheing-initargs-redefinitions-check)
+  (make-instance 'cacheing-initargs-redefinitions-check :slot2 3)
+  (cacheing-initargs-redefinitions-check-fun :slot2)
+  (assert (raises-error? (cacheing-initargs-redefinitions-check-fun :slot))))
+(defmethod initialize-instance :after ((class cacheing-initargs-redefinitions-check) &key slot)
+  nil)
+(with-test (:name :make-instance-new-method-initargs)
+  (make-instance 'cacheing-initargs-redefinitions-check)
+  (make-instance 'cacheing-initargs-redefinitions-check :slot2 3)
+  (cacheing-initargs-redefinitions-check-fun :slot2)
+  (let ((thing (cacheing-initargs-redefinitions-check-fun :slot)))
+    (assert (not (slot-boundp thing 'slot)))))
 ;;;; success

diff --git a/version.lisp-expr b/version.lisp-expr
index ef0661d..d07ced6 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.2"
+"1.0.40.3"