X-Git-Url: http://repo.macrolet.net/gitweb/?a=blobdiff_plain;f=src%2Fpcl%2Fctor.lisp;h=aebc88408ffc3e018e0e833a5eaec87a5dfa1afa;hb=d25e3478acccec70402ff32554669a982be8e281;hp=0bd3973b0040e9c6e682ebb3186a705d6e8f3f67;hpb=7727c77c8b05dcbcf9f8878a26f94cc14ccd5218;p=sbcl.git

diff --git a/src/pcl/ctor.lisp b/src/pcl/ctor.lisp
index 0bd3973..aebc884 100644
--- a/src/pcl/ctor.lisp
+++ b/src/pcl/ctor.lisp
@@ -241,15 +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))
-    (setf (ctor-class ctor) class)
-    (pushnew ctor (plist-value class 'ctors))
-    (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))
@@ -335,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)
@@ -359,12 +369,17 @@
 (defun optimizing-generator (ctor ii-methods si-methods)
   (multiple-value-bind (locations names body before-method-p)
       (fake-initialization-emf ctor ii-methods si-methods)
-    (values
-     `(lambda ,(make-ctor-parameter-list ctor)
-       (declare #.*optimize-speed*)
-       ,(wrap-in-allocate-forms ctor body before-method-p))
-     locations
-     names)))
+    (let ((wrapper (class-wrapper (ctor-class ctor))))
+      (values
+       `(lambda ,(make-ctor-parameter-list ctor)
+         (declare #.*optimize-speed*)
+         (block nil
+           (when (layout-invalid ,wrapper)
+             (install-initial-constructor ,ctor)
+             (return (funcall ,ctor ,@(make-ctor-parameter-list ctor))))
+           ,(wrap-in-allocate-forms ctor body before-method-p)))
+       locations
+       names))))
 
 ;;; Return a form wrapped around BODY that allocates an instance
 ;;; constructed by CTOR.  BEFORE-METHOD-P set means we have to run
@@ -444,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))