1.0.23.37: more CLOS and classoid thread safety

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

diff --git a/src/pcl/wrapper.lisp b/src/pcl/wrapper.lisp
index d67e1c4..7abe628 100644 (file)
--- a/src/pcl/wrapper.lisp
+++ b/src/pcl/wrapper.lisp
@@ -124,8 +124,7 @@
 ;;; We only use this inside INVALIDATE-WRAPPER.
 (defvar *previous-nwrappers* (make-hash-table))
 
-;;; We always call this inside WITH-PCL-LOCK.
-(defun invalidate-wrapper (owrapper state nwrapper)
+(defun %invalidate-wrapper (owrapper state nwrapper)
   (aver (member state '(:flush :obsolete) :test #'eq))
   (let ((new-previous ()))
     ;; First off, a previous call to INVALIDATE-WRAPPER may have
@@ -158,39 +157,46 @@
 ;;; we return the valid wrapper, which is not obvious from the name
 ;;; (or the names of our callees.)
 (defun check-wrapper-validity (instance)
-  (let* ((owrapper (wrapper-of instance))
-         (state (layout-invalid owrapper)))
-    (aver (not (eq state :uninitialized)))
-    (cond ((not state)
-           owrapper)
-          ((not (layout-for-std-class-p owrapper))
-           ;; Obsolete structure trap.
-           (obsolete-instance-trap owrapper nil instance))
-          ((eq t state)
-           ;; FIXME: I can't help thinking that, while this does cure
-           ;; the symptoms observed from some class redefinitions,
-           ;; this isn't the place to be doing this flushing.
-           ;; Nevertheless... -- CSR, 2003-05-31
-           ;;
-           ;; CMUCL comment:
-           ;;    We assume in this case, that the :INVALID is from a
-           ;;    previous call to REGISTER-LAYOUT for a superclass of
-           ;;    INSTANCE's class.  See also the comment above
-           ;;    FORCE-CACHE-FLUSHES.  Paul Dietz has test cases for this.
-           (force-cache-flushes (class-of instance))
-           ;; KLUDGE avoid an infinite recursion, it's still better to
-           ;; bail out with an AVER for server softwares. see FIXME above.
-           ;; details: http://thread.gmane.org/gmane.lisp.steel-bank.devel/10175
-           (aver (not (eq (layout-invalid (wrapper-of instance)) t)))
-           (check-wrapper-validity instance))
-          ((consp state)
-           (ecase (car state)
-             (:flush
-              (flush-cache-trap owrapper (cadr state) instance))
-             (:obsolete
-              (obsolete-instance-trap owrapper (cadr state) instance))))
-          (t
-           (bug "Invalid LAYOUT-INVALID: ~S" state)))))
+  (with-world-lock ()
+    (let* ((owrapper (wrapper-of instance))
+           (state (layout-invalid owrapper)))
+      (aver (not (eq state :uninitialized)))
+      (cond ((not state)
+             owrapper)
+            ((not (layout-for-std-class-p owrapper))
+             ;; Obsolete structure trap.
+             (%obsolete-instance-trap owrapper nil instance))
+            ((eq t state)
+             ;; FIXME: I can't help thinking that, while this does cure
+             ;; the symptoms observed from some class redefinitions,
+             ;; this isn't the place to be doing this flushing.
+             ;; Nevertheless... -- CSR, 2003-05-31
+             ;;
+             ;; CMUCL comment:
+             ;;    We assume in this case, that the :INVALID is from a
+             ;;    previous call to REGISTER-LAYOUT for a superclass of
+             ;;    INSTANCE's class.  See also the comment above
+             ;;    FORCE-CACHE-FLUSHES.  Paul Dietz has test cases for this.
+             (%force-cache-flushes (class-of instance))
+             ;; KLUDGE avoid an infinite recursion, it's still better to
+             ;; bail out with an AVER for server softwares. see FIXME above.
+             ;; details: http://thread.gmane.org/gmane.lisp.steel-bank.devel/10175
+             (aver (not (eq (layout-invalid (wrapper-of instance)) t)))
+             (check-wrapper-validity instance))
+            ((consp state)
+             (ecase (car state)
+               (:flush
+                (let ((new (cadr state)))
+                  (cond ((std-instance-p instance)
+                         (setf (std-instance-wrapper instance) new))
+                        ((fsc-instance-p instance)
+                         (setf (fsc-instance-wrapper instance) new))
+                        (t
+                         (bug "unrecognized instance type")))))
+               (:obsolete
+                (%obsolete-instance-trap owrapper (cadr state) instance))))
+            (t
+             (bug "Invalid LAYOUT-INVALID: ~S" state))))))
 
 (declaim (inline check-obsolete-instance))
 (defun check-obsolete-instance (instance)