1.0.28.65: fix compiling with *PROFILE-HASH-CACHE* set to T

[sbcl.git] / src / pcl / ctor.lisp

diff --git a/src/pcl/ctor.lisp b/src/pcl/ctor.lisp
index 9b565be..aebc884 100644 (file)
--- a/src/pcl/ctor.lisp
+++ b/src/pcl/ctor.lisp
@@ -241,22 +241,23 @@
 (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 (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))))))
 
 (defun constructor-function-form (ctor)
   (let* ((class (ctor-class ctor))
@@ -342,7 +343,9 @@
     (methods &optional standard-method)
   (loop with primary-checked-p = nil
         for method in methods
-        as qualifiers = (method-qualifiers method)
+        as qualifiers = (if (consp method)
+                            (early-method-qualifiers method)
+                            (safe-method-qualifiers method))
         when (or (eq :around (car qualifiers))
                  (and (null qualifiers)
                       (not primary-checked-p)
@@ -456,7 +459,9 @@
 ;;; must be called.
 (defun standard-sort-methods (applicable-methods)
   (loop for method in applicable-methods
-        as qualifiers = (method-qualifiers method)
+        as qualifiers = (if (consp method)
+                            (early-method-qualifiers method)
+                            (safe-method-qualifiers method))
         if (null qualifiers)
           collect method into primary
         else if (eq :around (car qualifiers))