1.0.29.54.rc2: two more CTOR optimization issues

* Invalid calls of the form (MAKE-INSTANCE ''QUUX) or similar reported
  hard to understand errors instead of using the NO-APPLICABLE-METHOD
  machinery. (reported by Gabor Melis)

* Runtime generation of new CTORs for the inline cache was not thread
  safe: grab *WORLD-LOCK* to ansure that (1) all CTORs end up in
  *ALL-CTORS* (2) we don't construct a CTOR with the same name twice.
  Also initialize the new CTOR with the initial constructor before
  setting its FDEFINITION: this is strictly speaking not needed given
  the lock, but more clearly correct. No test-case, as I was unable to
  actually provoke problem in real code.

NEWS

@@ -63,7 +63,7 @@ changes in sbcl-1.0.29.54.rc1 relative to sbcl-1.0.29:
   * bug fix: bogus undefined variable warnings from fopcompiled references to
     global variables. (thanks to Lars Rune Nøstdal)
   * bug fix: foreign function names should now appear in backtraces on
-    FC6 as well. (reported by Tomasz Skutnik and obias Rautenkranz)
+    FC6 as well. (reported by Tomasz Skutnik and Tobias Rautenkranz)
   * bug fix: SETF compiler macro documentation strings are not discarded
     anymore.
   * bug fix: GENTEMP is now unaffected by pretty printer dispatch table.

src/pcl/ctor.lisp

@@ -155,17 +155,19 @@
 
 ;;; Keep this a separate function for testing.
 (defun ensure-ctor (function-name class-name initargs safe-code-p)
-  (unless (fboundp function-name)
-    (make-ctor function-name class-name initargs safe-code-p)))
+  (with-world-lock ()
+    (if (fboundp function-name)
+        (the ctor (fdefinition function-name))
+        (make-ctor function-name class-name initargs safe-code-p))))
 
 ;;; 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)))
-     (push ctor *all-ctors*)
-     (setf (fdefinition function-name) ctor)
-     (install-initial-constructor ctor :force-p t)
-     ctor)))
+    (let ((ctor (%make-ctor function-name class-name nil initargs safe-p)))
+      (install-initial-constructor ctor :force-p t)
+      (push ctor *all-ctors*)
+      (setf (fdefinition function-name) ctor)
+      ctor)))
 
 ;;; *****************
 ;;; Inline CTOR cache
@@ -308,25 +310,35 @@
       (setf table (nth-value 1 (put-ctor ctor table))))
     table))
 
-(defun ctor-for-caching (class-name initargs safe-code-p)
-  (let ((name (make-ctor-function-name class-name initargs safe-code-p)))
-    (or (ensure-ctor name class-name initargs safe-code-p)
-        (fdefinition name))))
-
 (defun ensure-cached-ctor (class-name store initargs safe-code-p)
-  (if (listp store)
-      (multiple-value-bind (ctor list) (find-ctor class-name store)
-        (if ctor
-            (values ctor list)
-            (let ((ctor (ctor-for-caching class-name initargs safe-code-p)))
-              (if (< (length list) +ctor-list-max-size+)
-                  (values ctor (cons ctor list))
-                  (values ctor (ctor-list-to-table list))))))
-      (let ((ctor (get-ctor class-name store)))
-        (if ctor
-            (values ctor store)
-            (put-ctor (ctor-for-caching class-name initargs safe-code-p)
-                      store)))))
+  (flet ((maybe-ctor-for-caching ()
+           (if (typep class-name '(or symbol class))
+               (let ((name (make-ctor-function-name class-name initargs safe-code-p)))
+                 (ensure-ctor name class-name initargs safe-code-p))
+               ;; Invalid first argument: let MAKE-INSTANCE worry about it.
+               (return-from ensure-cached-ctor
+                 (values (lambda (&rest ctor-parameters)
+                           (let (mi-initargs)
+                             (doplist (key value) initargs
+                               (push key mi-initargs)
+                               (push (if (constantp value)
+                                         value
+                                         (pop ctor-parameters))
+                                     mi-initargs))
+                             (apply #'make-instance class-name (nreverse mi-initargs))))
+                         store)))))
+    (if (listp store)
+        (multiple-value-bind (ctor list) (find-ctor class-name store)
+          (if ctor
+              (values ctor list)
+              (let ((ctor (maybe-ctor-for-caching)))
+                (if (< (length list) +ctor-list-max-size+)
+                    (values ctor (cons ctor list))
+                    (values ctor (ctor-list-to-table list))))))
+       (let ((ctor (get-ctor class-name store)))
+         (if ctor
+             (values ctor store)
+             (put-ctor (maybe-ctor-for-caching) store))))))
 
 ;;; ***********************************************
 ;;; Compile-Time Expansion of MAKE-INSTANCE *******
@@ -407,7 +419,7 @@
                                (function (&rest t) t))
                            ,function-name))
                    (funcall (function ,function-name) ,@value-forms))))
-            (when class-arg
+            (when (and class-arg (not (constantp class-arg)))
               ;; Build an inline cache: a CONS, with the actual cache in the CDR.
               `(locally (declare (disable-package-locks .cache. .class-arg. .store. .fun.
                                                         make-instance))

tests/ctor.impure.lisp

@@ -217,5 +217,25 @@
     (handler-bind ((sb-ext:compiler-note #'error))
       (funcall fun 41)
       (funcall fun 13))))
+
+;;; NO-APPLICABLE-METHOD called
+(defmethod no-applicable-method ((gf (eql #'make-instance)) &rest args)
+  (cons :no-applicable-method args))
+(with-test (:name :constant-invalid-class-arg)
+  (assert (equal
+           '(:no-applicable-method "FOO" :quux 14)
+           (funcall (compile nil `(lambda (x) (make-instance "FOO" :quux x))) 14)))
+  (assert (equal
+           '(:no-applicable-method 'abc zot 1 bar 2)
+           (funcall (compile nil `(lambda (x y) (make-instance ''abc 'zot x 'bar y)))
+                    1 2))))
+(with-test (:name :variable-invalid-class-arg)
+  (assert (equal
+           '(:no-applicable-method "FOO" :quux 14)
+           (funcall (compile nil `(lambda (c x) (make-instance c :quux x))) "FOO" 14)))
+  (assert (equal
+           '(:no-applicable-method 'abc zot 1 bar 2)
+           (funcall (compile nil `(lambda (c x y) (make-instance c 'zot x 'bar y)))
+                    ''abc 1 2))))
 
 ;;;; success

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.54.rc1"
+"1.0.29.54.rc2"