1.0.29.48: compute default initargs for SB-PCL::FAST-MAKE-INSTANCE

* Reported by Lars Rune Nøstdal.

* SB-PCL::DEFAULT-INITARGS doesn't have to be a generic function.

* Test-case.

diff --git a/NEWS b/NEWS
index d6ec6ff..c1d2e37 100644 (file)
--- a/NEWS
+++ b/NEWS
@@ -15,10 +15,10 @@
     with a specialised code sequence.
   * 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: MAKE-INSTANCE with constant keyword arguments is x2-4 faster
+    in the presence of :AROUND or non-standard primary INITIALIZE-INSTANCE
+    methods, and similarly for non-standard metaclass classes as long as there
+    are no methods additional on MAKE-INSTANCE.
   * 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 d330833..6a81d8c 100644 (file)
--- a/src/pcl/ctor.lisp
+++ b/src/pcl/ctor.lisp
@@ -562,9 +562,12 @@
            ;; *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)))))
+        (let ((defaults (class-default-initargs class)))
+          (when defaults
+            (setf initargs (default-initargs initargs defaults)))
+          `(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.

diff --git a/src/pcl/generic-functions.lisp b/src/pcl/generic-functions.lisp
index 7428801..4439b02 100644 (file)
--- a/src/pcl/generic-functions.lisp
+++ b/src/pcl/generic-functions.lisp
@@ -391,8 +391,6 @@
 
 (defgeneric compute-slot-accessor-info (slotd type gf))
 
-(defgeneric default-initargs (class initargs defaults))
-
 (defgeneric find-method-combination (generic-function type options))
 
 (defgeneric invalid-qualifiers (generic-function combin method))

diff --git a/src/pcl/init.lisp b/src/pcl/init.lisp
index 62a342f..a4c3dad 100644 (file)
--- a/src/pcl/init.lisp
+++ b/src/pcl/init.lisp
@@ -32,7 +32,7 @@
   (unless (class-finalized-p class) (finalize-inheritance class))
   (let ((class-default-initargs (class-default-initargs class)))
     (when class-default-initargs
-      (setf initargs (default-initargs class initargs 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)))
@@ -49,9 +49,7 @@
       (apply #'initialize-instance instance initargs)
       instance)))
 
-(defmethod default-initargs ((class slot-class)
-                             supplied-initargs
-                             class-default-initargs)
+(defun default-initargs (supplied-initargs class-default-initargs)
   (loop for (key nil fun) in class-default-initargs
         when (eq (getf supplied-initargs key '.not-there.) '.not-there.)
           append (list key (funcall fun)) into default-initargs

diff --git a/src/pcl/time.lisp b/src/pcl/time.lisp
index b7a4e95..6f21f7c 100644 (file)
--- a/src/pcl/time.lisp
+++ b/src/pcl/time.lisp
@@ -75,8 +75,8 @@
 (push (cons "Time default-initargs."
             '(time-default-initargs (find-class 'plist-mixin) 1000))
       *tests*)
-(defun time-default-initargs (class n)
-  (time (dotimes-fixnum (i n) (default-initargs class nil))))
+(defun time-default-initargs (n)
+  (time (dotimes-fixnum (i n) (default-initargs nil nil))))
 
 (push (cons "Time make-instance."
             '(time-make-instance (find-class 'plist-mixin) 1000))

diff --git a/tests/ctor.impure.lisp b/tests/ctor.impure.lisp
index f7a6530..0fda4eb 100644 (file)
--- a/tests/ctor.impure.lisp
+++ b/tests/ctor.impure.lisp
@@ -96,6 +96,19 @@
                  (when (and (consp c) (eq 'sb-pcl::ctor-cache (car c)))
                    (return c)))))))
 
+;;; FIXME: Move this to test-utils -- compiler tests have / need stuff like this
+;;; as well.
+(defun find-callee (f &key (type t) (name nil namep))
+  (let ((code (sb-kernel:fun-code-header (sb-kernel:%fun-fun f))))
+    (loop for i from sb-vm::code-constants-offset below (sb-kernel:get-header-data code)
+          for c = (sb-kernel:code-header-ref code i)
+          do (when (typep c 'sb-impl::fdefn)
+               (let ((fun (sb-impl::fdefn-fun c)))
+                 (when (and (typep fun type)
+                            (or (not namep)
+                                (equal name (sb-impl::fdefn-name c))))
+                   (return fun)))))))
+
 (let* ((cmacro (compiler-macro-function 'make-instance))
         (opt 0)
         (wrapper (lambda (form env)
@@ -155,5 +168,23 @@
     (dolist (class classes)
       (assert (typep (funcall f (if (oddp count) class (find-class class))) class))
       (incf count))))
+
+;;; Make sure we get default initargs right with on the FAST-MAKE-INSTANCE path CTORs
+(defclass some-class ()
+  ((aroundp :initform nil :reader aroundp))
+  (:default-initargs :x :success?))
+(defmethod initialize-instance :around ((some-class some-class) &key (x :fail?))
+  (unless (eq x :success?)
+    (error "Default initarg lossage"))
+  (setf (slot-value some-class 'aroundp) t)
+  (when (next-method-p)
+    (call-next-method)))
+(with-test (:name (make-instance :ctor-default-initargs))
+  (assert (aroundp (eval `(make-instance 'some-class))))
+  (let ((fun (compile nil `(lambda () (make-instance 'some-class)))))
+    (assert (aroundp (funcall fun)))
+    ;; make sure we tested what we think we tested...
+    (let ((ctor (find-callee fun :type 'sb-pcl::ctor)))
+      (assert (find-callee ctor :name 'sb-pcl::fast-make-instance)))))
 \f
 ;;;; success

diff --git a/version.lisp-expr b/version.lisp-expr
index 1246f7b..2d13684 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.47"
+"1.0.29.48"