X-Git-Url: http://repo.macrolet.net/gitweb/?a=blobdiff_plain;f=src%2Fpcl%2Fwrapper.lisp;h=7abe62881456be2beaf3c2a0afe21c4a7a20e22a;hb=d25e3478acccec70402ff32554669a982be8e281;hp=f8dc323d9b8865a4dadc8724bd9704dccf9f967f;hpb=8fee0ba99cd1b1038072bd3fc8f5d5338d80d2de;p=sbcl.git

diff --git a/src/pcl/wrapper.lisp b/src/pcl/wrapper.lisp
index f8dc323..7abe628 100644
--- a/src/pcl/wrapper.lisp
+++ b/src/pcl/wrapper.lisp
@@ -99,8 +99,10 @@
 (declaim (inline wrapper-class*))
 (defun wrapper-class* (wrapper)
   (or (wrapper-class wrapper)
-      (ensure-non-standard-class
-       (classoid-name (layout-classoid wrapper)))))
+      (let ((classoid (layout-classoid wrapper)))
+        (ensure-non-standard-class
+         (classoid-name classoid)
+         classoid))))
 
 ;;; The wrapper cache machinery provides general mechanism for
 ;;; trapping on the next access to any instance of a given class. This
@@ -122,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
@@ -152,36 +153,61 @@
     (remhash owrapper *previous-nwrappers*)
     (setf (gethash nwrapper *previous-nwrappers*) new-previous)))
 
+;;; FIXME: This is not a good name: part of the constract here is that
+;;; 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)))
-    (etypecase state
-      (null owrapper)
-      ;; 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.
-      ((member t)
-       (force-cache-flushes (class-of instance))
-       (check-wrapper-validity instance))
-      (cons
-       (ecase (car state)
-         (:flush
-          (flush-cache-trap owrapper (cadr state) instance))
-         (:obsolete
-          (obsolete-instance-trap owrapper (cadr state) instance)))))))
+  (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)
   (when (invalid-wrapper-p (layout-of instance))
     (check-wrapper-validity instance)))
+
+(defun valid-wrapper-of (instance)
+  (let ((wrapper (wrapper-of instance)))
+    (if (invalid-wrapper-p wrapper)
+        (check-wrapper-validity instance)
+        wrapper)))
 
 ;;;  NIL: means nothing so far, no actual arg info has NILs in the
 ;;;  metatype.