X-Git-Url: http://repo.macrolet.net/gitweb/?a=blobdiff_plain;f=src%2Fpcl%2Fctor.lisp;h=9bcfbd86363f6b440028a8f6d4a871d5f65c74ec;hb=57eae6573811f44abe167a9015116d95371543bb;hp=0aae966df2eadadaef4d633ca249c1313277b890;hpb=e66288cd5588b336b79a7e19f1c884e4e3263d53;p=sbcl.git

diff --git a/src/pcl/ctor.lisp b/src/pcl/ctor.lisp
index 0aae966..9bcfbd8 100644
--- a/src/pcl/ctor.lisp
+++ b/src/pcl/ctor.lisp
@@ -84,18 +84,35 @@
         else if (or (null test) (funcall test (car more)))
           collect (car more)))
 
+(defun constant-class-arg-p (form)
+  (and (constantp form)
+       (let ((constant (constant-form-value form)))
+         (or (and (symbolp constant)
+                  (not (null (symbol-package constant))))
+             (classp form)))))
+
 (defun constant-symbol-p (form)
   (and (constantp form)
        (let ((constant (constant-form-value form)))
          (and (symbolp constant)
               (not (null (symbol-package constant)))))))
 
-;;; somewhat akin to DEFAULT-INITARGS (SLOT-CLASS T T), but just
-;;; collecting the defaulted initargs for the call.
+;;; Somewhat akin to DEFAULT-INITARGS, but just collecting the defaulted
+;;; initargs for the call.
 (defun ctor-default-initkeys (supplied-initargs class-default-initargs)
   (loop for (key) in class-default-initargs
         when (eq (getf supplied-initargs key '.not-there.) '.not-there.)
         collect key))
+
+;;; Like DEFAULT-INITARGS, but return a list that can be spliced into source,
+;;; instead of a list with values already evaluated.
+(defun ctor-default-initargs (supplied-initargs class-default-initargs)
+  (loop for (key form fun) in class-default-initargs
+        when (eq (getf supplied-initargs key '.not-there.) '.not-there.)
+        append (list key (if (constantp form) form `(funcall ,fun)))
+          into default-initargs
+        finally
+          (return (append supplied-initargs default-initargs))))
 
 ;;; *****************
 ;;; CTORS   *********
@@ -107,7 +124,7 @@
 ;;; funcallable instance is set to it.
 ;;;
 (!defstruct-with-alternate-metaclass ctor
-  :slot-names (function-name class-name class initargs safe-p)
+  :slot-names (function-name class-or-name class initargs safe-p)
   :boa-constructor %make-ctor
   :superclass-name function
   :metaclass-name static-classoid
@@ -116,7 +133,6 @@
   :runtime-type-checks-p nil)
 
 ;;; List of all defined ctors.
-
 (defvar *all-ctors* ())
 
 (defun make-ctor-parameter-list (ctor)
@@ -139,31 +155,208 @@
 
 ;;; 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
+;;; *****************
+;;;
+;;; The cache starts out as a list of CTORs, sorted with the most recently
+;;; used CTORs near the head. If it expands too much, we switch to a vector
+;;; with a simple hashing scheme.
+
+;;; Find CTOR for KEY (which is a class or class name) in a list. If the CTOR
+;;; is in the list but not one of the 4 first ones, return a new list with the
+;;; found CTOR at the head. Thread-safe: the new list shares structure with
+;;; the old, but is not desctructively modified. Returning the old list for
+;;; hits close to the head reduces ping-ponging with multiple threads seeking
+;;; the same list.
+(defun find-ctor (key list)
+  (labels ((walk (tail from-head depth)
+             (declare (fixnum depth))
+             (if tail
+                 (let ((ctor (car tail)))
+                   (if (eq (ctor-class-or-name ctor) key)
+                       (if (> depth 3)
+                           (values ctor
+                                   (nconc (list ctor) (nreverse from-head) (cdr tail)))
+                           (values ctor
+                                   list))
+                       (walk (cdr tail)
+                             (cons ctor from-head)
+                             (logand #xf (1+ depth)))))
+                 (values nil list))))
+    (walk list nil 0)))
+
+(declaim (inline sxhash-symbol-or-class))
+(defun sxhash-symbol-or-class (x)
+  (cond ((symbolp x) (sxhash x))
+        ((std-instance-p x) (std-instance-hash x))
+        ((fsc-instance-p x) (fsc-instance-hash x))
+        (t
+         (bug "Something strange where symbol or class expected."))))
+
+;;; Max number of CTORs kept in an inline list cache. Once this is
+;;; exceeded we switch to a table.
+(defconstant +ctor-list-max-size+ 12)
+;;; Max table size for CTOR cache. If the table fills up at this size
+;;; we keep the same size and drop 50% of the old entries.
+(defconstant +ctor-table-max-size+ (expt 2 8))
+;;; Even if there is space in the cache, if we cannot fit a new entry
+;;; with max this number of collisions we expand the table (if possible)
+;;; and rehash.
+(defconstant +ctor-table-max-probe-depth+ 5)
+
+(defun make-ctor-table (size)
+  (declare (index size))
+  (let ((real-size (power-of-two-ceiling size)))
+    (if (< real-size +ctor-table-max-size+)
+        (values (make-array real-size :initial-element nil) nil)
+        (values (make-array +ctor-table-max-size+ :initial-element nil) t))))
+
+(declaim (inline mix-ctor-hash))
+(defun mix-ctor-hash (hash base)
+  (logand most-positive-fixnum (+ hash base 1)))
+
+(defun put-ctor (ctor table)
+  (cond ((try-put-ctor ctor table)
+         (values ctor table))
+        (t
+         (expand-ctor-table ctor table))))
+
+;;; Thread-safe: if two threads write to the same index in parallel, the other
+;;; result is just lost. This is not an issue as the CTORs are used as their
+;;; own keys. If both were EQ, we're good. If non-EQ, the next time the other
+;;; one is needed we just cache it again -- hopefully not getting stomped on
+;;; that time.
+(defun try-put-ctor (ctor table)
+  (declare (simple-vector table) (optimize speed))
+  (let* ((class (ctor-class-or-name ctor))
+         (base (sxhash-symbol-or-class class))
+         (hash base)
+         (mask (1- (length table))))
+    (declare (fixnum base hash mask))
+    (loop repeat +ctor-table-max-probe-depth+
+          do (let* ((index (logand mask hash))
+                    (old (aref table index)))
+               (cond ((and old (neq class (ctor-class-or-name old)))
+                      (setf hash (mix-ctor-hash hash base)))
+                     (t
+                      (setf (aref table index) ctor)
+                      (return-from try-put-ctor t)))))
+    ;; Didn't fit, must expand
+    nil))
+
+(defun get-ctor (class table)
+  (declare (simple-vector table) (optimize speed))
+  (let* ((base (sxhash-symbol-or-class class))
+         (hash base)
+         (mask (1- (length table))))
+    (declare (fixnum base hash mask))
+    (loop repeat +ctor-table-max-probe-depth+
+          do (let* ((index (logand mask hash))
+                    (old (aref table index)))
+               (if (and old (eq class (ctor-class-or-name old)))
+                   (return-from get-ctor old)
+                   (setf hash (mix-ctor-hash hash base)))))
+    ;; Nothing.
+    nil))
+
+;;; Thread safe: the old table is read, but if another thread mutates
+;;; it while we're reading we still get a sane result -- either the old
+;;; or the new entry. The new table is locally allocated, so that's ok
+;;; too.
+(defun expand-ctor-table (ctor old)
+  (declare (simple-vector old))
+  (let* ((old-size (length old))
+         (new-size (* 2 old-size))
+         (drop-random-entries nil))
+    (tagbody
+     :again
+       (multiple-value-bind (new max-size-p) (make-ctor-table new-size)
+         (let ((action (if drop-random-entries
+                           ;; Same logic as in method caches -- see comment
+                           ;; there.
+                           (randomly-punting-lambda (old-ctor)
+                             (try-put-ctor old-ctor new))
+                           (lambda (old-ctor)
+                             (unless (try-put-ctor old-ctor new)
+                               (if max-size-p
+                                   (setf drop-random-entries t)
+                                   (setf new-size (* 2 new-size)))
+                               (go :again))))))
+           (aver (try-put-ctor ctor new))
+           (dotimes (i old-size)
+             (let ((old-ctor (aref old i)))
+               (when old-ctor
+                 (funcall action old-ctor))))
+           (return-from expand-ctor-table (values ctor new)))))))
+
+(defun ctor-list-to-table (list)
+  (let ((table (make-ctor-table (length list))))
+    (dolist (ctor list)
+      (setf table (nth-value 1 (put-ctor ctor table))))
+    table))
+
+(defun ensure-cached-ctor (class-name store initargs safe-code-p)
+  (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 *******
 ;;; ***********************************************
 
+(defvar *compiling-optimized-constructor* nil)
+
 (define-compiler-macro make-instance (&whole form &rest args &environment env)
   (declare (ignore args))
-  (or (make-instance->constructor-call form (safe-code-p env))
+  ;; Compiling an optimized constructor for a non-standard class means compiling a
+  ;; lambda with (MAKE-INSTANCE #<SOME-CLASS X> ...) in it -- need
+  ;; to make sure we don't recurse there.
+  (or (unless *compiling-optimized-constructor*
+        (make-instance->constructor-call form (safe-code-p env)))
       form))
 
 (defun make-instance->constructor-call (form safe-code-p)
-  (destructuring-bind (fn class-name &rest args) form
-    (declare (ignore fn))
+  (destructuring-bind (class-arg &rest args) (cdr form)
     (flet (;;
            ;; Return the name of parameter number I of a constructor
            ;; function.
@@ -172,20 +365,18 @@
                (if (array-in-bounds-p ps i)
                    (aref ps i)
                    (format-symbol *pcl-package* ".P~D." i))))
-           ;; Check if CLASS-NAME is a constant symbol.  Give up if
+           ;; Check if CLASS-ARG is a constant symbol.  Give up if
            ;; not.
-           (check-class ()
-             (unless (and class-name (constant-symbol-p class-name))
-               (return-from make-instance->constructor-call nil)))
+           (constant-class-p ()
+             (and class-arg (constant-class-arg-p class-arg)))
            ;; Check if ARGS are suitable for an optimized constructor.
            ;; Return NIL from the outer function if not.
            (check-args ()
              (loop for (key . more) on args by #'cddr do
-                     (when (or (null more)
-                               (not (constant-symbol-p key))
-                               (eq :allow-other-keys (constant-form-value key)))
-                       (return-from make-instance->constructor-call nil)))))
-      (check-class)
+                      (when (or (null more)
+                                (not (constant-symbol-p key))
+                                (eq :allow-other-keys (constant-form-value key)))
+                        (return-from make-instance->constructor-call nil)))))
       (check-args)
       ;; Collect a plist of initargs and constant values/parameter names
       ;; in INITARGS.  Collect non-constant initialization forms in
@@ -194,40 +385,55 @@
           (loop for (key value) on args by #'cddr and i from 0
                 collect (constant-form-value key) into initargs
                 if (constantp value)
-                  collect value into initargs
+                collect value into initargs
                 else
-                  collect (parameter-name i) into initargs
-                  and collect value into value-forms
+                collect (parameter-name i) into initargs
+                and collect value into value-forms
                 finally
-                  (return (values initargs value-forms)))
-        (let* ((class-name (constant-form-value class-name))
-               (function-name (make-ctor-function-name class-name initargs
-                                                       safe-code-p)))
-          ;; Prevent compiler warnings for calling the ctor.
-          (proclaim-as-fun-name function-name)
-          (note-name-defined function-name :function)
-          (when (eq (info :function :where-from function-name) :assumed)
-            (setf (info :function :where-from function-name) :defined)
-            (when (info :function :assumed-type function-name)
-              (setf (info :function :assumed-type function-name) nil)))
-          ;; Return code constructing a ctor at load time, which, when
-          ;; called, will set its funcallable instance function to an
-          ;; optimized constructor function.
-          `(locally
-               (declare (disable-package-locks ,function-name))
-            (let ((.x. (load-time-value
-                        (ensure-ctor ',function-name ',class-name ',initargs
-                                     ',safe-code-p))))
-              (declare (ignore .x.))
-              ;; ??? check if this is worth it.
-              (declare
-               (ftype (or (function ,(make-list (length value-forms)
-                                                :initial-element t)
-                                    t)
-                          (function (&rest t) t))
-                      ,function-name))
-              (funcall (function ,function-name) ,@value-forms))))))))
-
+                (return (values initargs value-forms)))
+        (if (constant-class-p)
+            (let* ((class-or-name (constant-form-value class-arg))
+                   (function-name (make-ctor-function-name class-or-name initargs
+                                                           safe-code-p)))
+              ;; Prevent compiler warnings for calling the ctor.
+              (proclaim-as-fun-name function-name)
+              (note-name-defined function-name :function)
+              (when (eq (info :function :where-from function-name) :assumed)
+                (setf (info :function :where-from function-name) :defined)
+                (when (info :function :assumed-type function-name)
+                  (setf (info :function :assumed-type function-name) nil)))
+              ;; Return code constructing a ctor at load time, which, when
+              ;; called, will set its funcallable instance function to an
+              ;; optimized constructor function.
+              `(locally
+                   (declare (disable-package-locks ,function-name))
+                 (let ((.x. (load-time-value
+                             (ensure-ctor ',function-name ',class-or-name ',initargs
+                                          ',safe-code-p))))
+                   (declare (ignore .x.))
+                   ;; ??? check if this is worth it.
+                   (declare
+                    (ftype (or (function ,(make-list (length value-forms)
+                                                     :initial-element t)
+                                         t)
+                               (function (&rest t) t))
+                           ,function-name))
+                   (funcall (function ,function-name) ,@value-forms))))
+            (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))
+                 (let* ((.cache. (load-time-value (cons 'ctor-cache nil)))
+                        (.store. (cdr .cache.))
+                        (.class-arg. ,class-arg))
+                   (multiple-value-bind (.fun. .new-store.)
+                       (ensure-cached-ctor .class-arg. .store. ',initargs ',safe-code-p)
+                     ;; Thread safe: if multiple threads hit this in paralle, the update
+                     ;; from the other one is just lost -- no harm done, except for the
+                     ;; need to redo the work next time.
+                     (unless (eq .store. .new-store.)
+                       (setf (cdr .cache.) .new-store.))
+                     (funcall (truly-the function .fun.) ,@value-forms))))))))))
 
 ;;; **************************************************
 ;;; Load-Time Constructor Function Generation  *******
@@ -241,22 +447,30 @@
 (defvar *the-system-si-method* nil)
 
 (defun install-optimized-constructor (ctor)
-  (let ((class (find-class (ctor-class-name ctor))))
-    (unless (class-finalized-p class)
-      (finalize-inheritance class))
-    ;; We can have a class with an invalid layout here.  Such a class
-    ;; cannot have a LAYOUT-INVALID of (:FLUSH ...) or (:OBSOLETE
-    ;; ...), because part of the deal is that those only happen from
-    ;; FORCE-CACHE-FLUSHES, which create a new valid wrapper for the
-    ;; class.  An invalid layout of T needs to be flushed, however.
-    (when (eq (layout-invalid (class-wrapper class)) t)
-      (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)
-            (apply (compile nil `(lambda ,names ,form)) locations)))))
+  (with-world-lock ()
+    (let* ((class-or-name (ctor-class-or-name ctor))
+           (class (if (symbolp class-or-name)
+                      (find-class class-or-name)
+                      class-or-name)))
+      (unless (class-finalized-p class)
+        (finalize-inheritance class))
+      ;; We can have a class with an invalid layout here.  Such a class
+      ;; cannot have a LAYOUT-INVALID of (:FLUSH ...) or (:OBSOLETE
+      ;; ...), because part of the deal is that those only happen from
+      ;; FORCE-CACHE-FLUSHES, which create a new valid wrapper for the
+      ;; class.  An invalid layout of T needs to be flushed, however.
+      (when (eq (layout-invalid (class-wrapper class)) t)
+        (%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)
+              (apply
+               (let ((*compiling-optimized-constructor* t))
+                 (handler-bind ((compiler-note #'muffle-warning))
+                   (compile nil `(lambda ,names ,form))))
+               locations))))))
 
 (defun constructor-function-form (ctor)
   (let* ((class (ctor-class ctor))
@@ -309,34 +523,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)
@@ -354,16 +573,33 @@
         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))
+        (let ((defaults (class-default-initargs class)))
+          (when defaults
+            (setf initargs (ctor-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.
+(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)
@@ -687,7 +923,7 @@
       ;; NAME must have been specified.
       (setf-find-class
        (loop for ctor in *all-ctors*
-             when (eq (ctor-class-name ctor) name) do
+             when (eq (ctor-class-or-name ctor) name) do
              (when (ctor-class ctor)
                (reset (ctor-class ctor)))
              (loop-finish)))
@@ -696,8 +932,16 @@
        (flet ((class-of-1st-method-param (method)
                 (type-class (first (method-specializers method)))))
          (case (generic-function-name generic-function)
-           ((make-instance allocate-instance
-             initialize-instance shared-initialize)
+           ((make-instance allocate-instance)
+            ;; FIXME: I can't see a way of working out which classes a
+            ;; given metaclass specializer are applicable to short of
+            ;; iterating and testing with class-of.  It would be good
+            ;; to not invalidate caches of system classes at this
+            ;; point (where it is not legal to define a method
+            ;; applicable to them on system functions).  -- CSR,
+            ;; 2010-07-13
+            (reset (find-class 'standard-object) t t))
+           ((initialize-instance shared-initialize)
             (reset (class-of-1st-method-param method) t t))
            ((reinitialize-instance)
             (reset (class-of-1st-method-param method) t nil))
@@ -713,15 +957,15 @@
 (defun precompile-ctors ()
   (dolist (ctor *all-ctors*)
     (when (null (ctor-class ctor))
-      (let ((class (find-class (ctor-class-name ctor) nil)))
+      (let ((class (find-class (ctor-class-or-name ctor) nil)))
         (when (and class (class-finalized-p class))
           (install-optimized-constructor ctor))))))
 
 (defun check-ri-initargs (instance initargs)
   (let* ((class (class-of instance))
          (keys (plist-keys initargs))
-         (cached (assoc keys (plist-value class 'ri-initargs)
-                        :test #'equal))
+         (cache (plist-value class 'ri-initargs))
+         (cached (assoc keys cache :test #'equal))
          (invalid-keys
           (if (consp cached)
               (cdr cached)
@@ -735,7 +979,7 @@
                             (list* 'shared-initialize instance nil initargs))
                       t nil)))
                 (setf (plist-value class 'ri-initargs)
-                      (acons keys invalid cached))
+                      (acons keys invalid cache))
                 invalid))))
     (when invalid-keys
       (error 'initarg-error :class class :initargs invalid-keys))))