1.0.23.37: more CLOS and classoid thread safety
authorNikodemus Siivola <nikodemus@random-state.net>
Fri, 12 Dec 2008 12:27:00 +0000 (12:27 +0000)
committerNikodemus Siivola <nikodemus@random-state.net>
Fri, 12 Dec 2008 12:27:00 +0000 (12:27 +0000)
 * Rename *BIG-COMPILER-LOCK* as *WORLD-LOCK*.

 * Use it to protect classoids, layouts/wrappers, obsolete instance
   updating, etc.

 * Rename sevaral functions which assume their callers are holding the
   lock to have % prefix. Perhaps we should have a separate prefix
   convention for "requires called to lock"? Or a nifty macro layer?
   (Actually there are probably places where read/write locks (or
   STM!)  would be a win...)

 * ENSURE-CLASS-USING-CLASS needs to set up type translations only
   while PCL is being build.

 * DEFCLASS and ENSURE-CLASS-USING-CLASS are now expected to be thread
   safe.

 * Test-case for parallel defclass and make-instance.

22 files changed:
NEWS
doc/internals-notes/threading-specials
package-data-list.lisp-expr
src/code/class.lisp
src/code/cold-init.lisp
src/code/load.lisp
src/code/typep.lisp
src/compiler/early-c.lisp
src/compiler/main.lisp
src/pcl/braid.lisp
src/pcl/ctor.lisp
src/pcl/dfun.lisp
src/pcl/generic-functions.lisp
src/pcl/low.lisp
src/pcl/macros.lisp
src/pcl/methods.lisp
src/pcl/slots.lisp
src/pcl/std-class.lisp
src/pcl/vector.lisp
src/pcl/wrapper.lisp
tests/threads.impure.lisp
version.lisp-expr

diff --git a/NEWS b/NEWS
index f120abb..d1f18ab 100644 (file)
--- a/NEWS
+++ b/NEWS
@@ -4,6 +4,8 @@
   * new feature: the system now signals a continuable error if standard
     readtable modification is attempted.
   * optimization: faster generic arithmetic dispatch on x86 and x86-64.
+  * bug fix: DEFCLASS and ENSURE-CLASS-USING-CLASS are now expected to
+    be thread safe.
   * bug fix: lexical type declarations are now correctly reported by
     SB-CLTL2. (reported by Larry D'Anna)
   * bug fix: STRING-TO-OCTETS did not handle :START properly when
index 73f5f06..56895e7 100644 (file)
@@ -97,19 +97,11 @@ SB-LOOP::*LOOP-BIND-STACK*
 
 = PCL
 
-The PCL authors thought a bit about thread safety, adding
-(without-interrupts ...) in some places to protect critical forms.
-We've implemented their without-interrupts macro as an acquitision of
-*pcl-lock*, so we hope they've done it properly.
-
-Largish parts of PCL should also be protected by the compiler lock,
-but sometimes it can be hard to tell...
-
-The most suspicious parts should probably be tested by asserting
-at various sites that the *PCL-LOCK* is held.
+Critical parts of PCL are protected by *world-lock* (particularly
+those dealing with class graph changes), and some with finer-grained locks.
 
 accesses locked with a nice granularity
-   SB-PCL::*FIND-CLASS*
+   SB-PCL::*CLASSOID-CELLS*
 
 read-only & safe:
    SB-PCL::*BUILT-IN-TYPEP-COST* 
index b74ab1f..c8e837c 100644 (file)
@@ -1644,6 +1644,7 @@ is a good idea, but see SB-SYS re. blurring of boundaries."
                "VECTOR-TO-VECTOR*"
                "VECTOR-OF-CHECKED-LENGTH-GIVEN-LENGTH" "WITH-ARRAY-DATA"
                "WITH-CIRCULARITY-DETECTION" "WRONG-NUMBER-OF-INDICES-ERROR"
+               "WITH-WORLD-LOCK"
 
                ;; bit bash fillers (FIXME: 32/64-bit issues)
                "UB1-BASH-FILL" "SYSTEM-AREA-UB1-FILL"
@@ -1710,7 +1711,7 @@ is a good idea, but see SB-SYS re. blurring of boundaries."
                "CLASSOID-CELL-NAME"
                "CLASSOID-CELL-PCL-CLASS"
                "CLASSOID-CELL-TYPEP"
-               "CLEAR-CLASSOID"
+               "%CLEAR-CLASSOID"
                "FIND-CLASSOID-CELL" "EXTRACT-FUN-TYPE"
                "%RANDOM-DOUBLE-FLOAT"
                #!+long-float "%RANDOM-LONG-FLOAT"
@@ -1795,6 +1796,7 @@ is a good idea, but see SB-SYS re. blurring of boundaries."
                "!SHARPM-COLD-INIT" "!EARLY-PROCLAIM-COLD-INIT"
                "!LATE-PROCLAIM-COLD-INIT" "!CLASS-FINALIZE"
                "!CONSTANTP-COLD-INIT"
+               "!WORLD-LOCK-COLD-INIT"
 
                "FLOAT-COLD-INIT-OR-REINIT"
                "GC-REINIT"
index 901713e..de34a74 100644 (file)
 ;;; cold-load time.
 (defvar *forward-referenced-layouts*)
 (!cold-init-forms
+  ;; Protected by *WORLD-LOCK*
   (setq *forward-referenced-layouts* (make-hash-table :test 'equal))
   #-sb-xc-host (progn
                  (/show0 "processing *!INITIAL-LAYOUTS*")
   ;; it thread-safe all the same. We need to lock *F-R-L* before doing
   ;; FIND-CLASSOID in case (SETF FIND-CLASSOID) happens in parallel.
   (let ((table *forward-referenced-layouts*))
-    (with-locked-hash-table (table)
+    (with-world-lock ()
       (let ((classoid (find-classoid name nil)))
         (or (and classoid (classoid-layout classoid))
             (gethash name table)
 (declaim (ftype (function (layout classoid index simple-vector layout-depthoid
                                   index)
                           layout)
-                init-or-check-layout))
-(defun init-or-check-layout
+                %init-or-check-layout))
+(defun %init-or-check-layout
     (layout classoid length inherits depthoid nuntagged)
   (cond ((eq (layout-invalid layout) :uninitialized)
          ;; There was no layout before, we just created one which
      `(find-layout ',name)
      ;; "initialization" form (which actually doesn't initialize
      ;; preexisting LAYOUTs, just checks that they're consistent).
-     `(init-or-check-layout ',layout
-                            ',(layout-classoid layout)
-                            ',(layout-length layout)
-                            ',(layout-inherits layout)
-                            ',(layout-depthoid layout)
-                            ',(layout-n-untagged-slots layout)))))
+     `(%init-or-check-layout ',layout
+                             ',(layout-classoid layout)
+                             ',(layout-length layout)
+                             ',(layout-inherits layout)
+                             ',(layout-depthoid layout)
+                             ',(layout-n-untagged-slots layout)))))
 
 ;;; If LAYOUT's slot values differ from the specified slot values in
 ;;; any interesting way, then give a warning and return T.
                           layout)
                 find-and-init-or-check-layout))
 (defun find-and-init-or-check-layout (name length inherits depthoid nuntagged)
-  (let ((layout (find-layout name)))
-    (init-or-check-layout layout
-                          (or (find-classoid name nil)
-                              (layout-classoid layout))
-                          length
-                          inherits
-                          depthoid
-                          nuntagged)))
+  (with-world-lock ()
+    (let ((layout (find-layout name)))
+      (%init-or-check-layout layout
+                             (or (find-classoid name nil)
+                                 (layout-classoid layout))
+                             length
+                             inherits
+                             depthoid
+                             nuntagged))))
 
 ;;; Record LAYOUT as the layout for its class, adding it as a subtype
 ;;; of all superclasses. This is the operation that "installs" a
 (eval-when (#-sb-xc :compile-toplevel :load-toplevel :execute)
 (defun register-layout (layout &key (invalidate t) destruct-layout)
   (declare (type layout layout) (type (or layout null) destruct-layout))
-  (let* ((classoid (layout-classoid layout))
-         (classoid-layout (classoid-layout classoid))
-         (subclasses (classoid-subclasses classoid)))
-
-    ;; Attempting to register ourselves with a temporary undefined
-    ;; class placeholder is almost certainly a programmer error. (I
-    ;; should know, I did it.) -- WHN 19990927
-    (aver (not (undefined-classoid-p classoid)))
-
-    ;; This assertion dates from classic CMU CL. The rationale is
-    ;; probably that calling REGISTER-LAYOUT more than once for the
-    ;; same LAYOUT is almost certainly a programmer error.
-    (aver (not (eq classoid-layout layout)))
-
-    ;; Figure out what classes are affected by the change, and issue
-    ;; appropriate warnings and invalidations.
-    (when classoid-layout
-      (modify-classoid classoid)
-      (when subclasses
-        (dohash ((subclass subclass-layout) subclasses :locked t)
-          (modify-classoid subclass)
-          (when invalidate
-            (invalidate-layout subclass-layout))))
-      (when invalidate
-        (invalidate-layout classoid-layout)
-        (setf (classoid-subclasses classoid) nil)))
-
-    (if destruct-layout
-        (setf (layout-invalid destruct-layout) nil
-              (layout-inherits destruct-layout) (layout-inherits layout)
-              (layout-depthoid destruct-layout)(layout-depthoid layout)
-              (layout-length destruct-layout) (layout-length layout)
-              (layout-n-untagged-slots destruct-layout) (layout-n-untagged-slots layout)
-              (layout-info destruct-layout) (layout-info layout)
-              (classoid-layout classoid) destruct-layout)
-        (setf (layout-invalid layout) nil
-              (classoid-layout classoid) layout))
-
-    (dovector (super-layout (layout-inherits layout))
-      (let* ((super (layout-classoid super-layout))
-             (subclasses (or (classoid-subclasses super)
-                             (setf (classoid-subclasses super)
-                                   (make-hash-table :test 'eq
-                                                    #-sb-xc-host #-sb-xc-host
-                                                    :synchronized t)))))
-        (when (and (eq (classoid-state super) :sealed)
-                   (not (gethash classoid subclasses)))
-          (warn "unsealing sealed class ~S in order to subclass it"
-                (classoid-name super))
-          (setf (classoid-state super) :read-only))
-        (setf (gethash classoid subclasses)
-              (or destruct-layout layout)))))
+  (with-world-lock ()
+    (let* ((classoid (layout-classoid layout))
+           (classoid-layout (classoid-layout classoid))
+           (subclasses (classoid-subclasses classoid)))
+
+      ;; Attempting to register ourselves with a temporary undefined
+      ;; class placeholder is almost certainly a programmer error. (I
+      ;; should know, I did it.) -- WHN 19990927
+      (aver (not (undefined-classoid-p classoid)))
+
+      ;; This assertion dates from classic CMU CL. The rationale is
+      ;; probably that calling REGISTER-LAYOUT more than once for the
+      ;; same LAYOUT is almost certainly a programmer error.
+      (aver (not (eq classoid-layout layout)))
+
+      ;; Figure out what classes are affected by the change, and issue
+      ;; appropriate warnings and invalidations.
+      (when classoid-layout
+        (%modify-classoid classoid)
+        (when subclasses
+          (dohash ((subclass subclass-layout) subclasses :locked t)
+            (%modify-classoid subclass)
+            (when invalidate
+              (%invalidate-layout subclass-layout))))
+        (when invalidate
+          (%invalidate-layout classoid-layout)
+          (setf (classoid-subclasses classoid) nil)))
+
+      (if destruct-layout
+          (setf (layout-invalid destruct-layout) nil
+                (layout-inherits destruct-layout) (layout-inherits layout)
+                (layout-depthoid destruct-layout)(layout-depthoid layout)
+                (layout-length destruct-layout) (layout-length layout)
+                (layout-n-untagged-slots destruct-layout) (layout-n-untagged-slots layout)
+                (layout-info destruct-layout) (layout-info layout)
+                (classoid-layout classoid) destruct-layout)
+          (setf (layout-invalid layout) nil
+                (classoid-layout classoid) layout))
+
+      (dovector (super-layout (layout-inherits layout))
+        (let* ((super (layout-classoid super-layout))
+               (subclasses (or (classoid-subclasses super)
+                               (setf (classoid-subclasses super)
+                                     (make-hash-table :test 'eq
+                                                      #-sb-xc-host #-sb-xc-host
+                                                      :synchronized t)))))
+          (when (and (eq (classoid-state super) :sealed)
+                     (not (gethash classoid subclasses)))
+            (warn "unsealing sealed class ~S in order to subclass it"
+                  (classoid-name super))
+            (setf (classoid-state super) :read-only))
+          (setf (gethash classoid subclasses)
+                (or destruct-layout layout))))))
 
   (values))
 ); EVAL-WHEN
   ;; PCL class, if any
   (pcl-class nil))
 
+;;; Protected by the hash-table lock, used only in FIND-CLASSOID-CELL.
 (defvar *classoid-cells*)
 (!cold-init-forms
   (setq *classoid-cells* (make-hash-table :test 'eq)))
     (let ((cell (find-classoid-cell name :errorp errorp)))
       (when cell (classoid-cell-classoid cell))))
 
-  ;; This is definitely not thread safe with itself -- but should be
-  ;; OK with parallel FIND-CLASSOID & FIND-LAYOUT.
   (defun (setf find-classoid) (new-value name)
     #-sb-xc (declare (type (or null classoid) new-value))
     (aver new-value)
     (let ((table *forward-referenced-layouts*))
-      (with-locked-hash-table (table)
+      (with-world-lock ()
         (let ((cell (find-classoid-cell name :create t)))
           (ecase (info :type :kind name)
             ((nil))
                   (classoid-layout new-value))))))
     new-value)
 
-  (defun clear-classoid (name cell)
+  (defun %clear-classoid (name cell)
     (ecase (info :type :kind name)
       ((nil))
       (:defined)
 ;;; We might be passed classoids with invalid layouts; in any pairwise
 ;;; class comparison, we must ensure that both are valid before
 ;;; proceeding.
-(defun ensure-classoid-valid (classoid layout)
+(defun %ensure-classoid-valid (classoid layout)
   (aver (eq classoid (layout-classoid layout)))
   (when (layout-invalid layout)
     (if (typep classoid 'standard-classoid)
         (let ((class (classoid-pcl-class classoid)))
           (cond
             ((sb!pcl:class-finalized-p class)
-             (sb!pcl::force-cache-flushes class))
+             (sb!pcl::%force-cache-flushes class))
             ((sb!pcl::class-has-a-forward-referenced-superclass-p class)
              (error "Invalid, unfinalizeable class ~S (classoid ~S)."
                     class classoid))
-            (t (sb!pcl:finalize-inheritance class))))
+            (t
+             (sb!pcl:finalize-inheritance class))))
         (error "Don't know how to ensure validity of ~S (not ~
                 a STANDARD-CLASSOID)." classoid))))
 
-(defun ensure-both-classoids-valid (class1 class2)
+(defun %ensure-both-classoids-valid (class1 class2)
   (do ((layout1 (classoid-layout class1) (classoid-layout class1))
        (layout2 (classoid-layout class2) (classoid-layout class2))
        (i 0 (+ i 1)))
       ((and (not (layout-invalid layout1)) (not (layout-invalid layout2))))
     (aver (< i 2))
-    (ensure-classoid-valid class1 layout1)
-    (ensure-classoid-valid class2 layout2)))
+    (%ensure-classoid-valid class1 layout1)
+    (%ensure-classoid-valid class2 layout2)))
 
 (defun update-object-layout-or-invalid (object layout)
   (if (typep (classoid-of object) 'standard-classoid)
 
 (!define-type-method (classoid :simple-subtypep) (class1 class2)
   (aver (not (eq class1 class2)))
-  (ensure-both-classoids-valid class1 class2)
-  (let ((subclasses (classoid-subclasses class2)))
-    (if (and subclasses (gethash class1 subclasses))
-        (values t t)
-        (values nil t))))
+  (with-world-lock ()
+    (%ensure-both-classoids-valid class1 class2)
+    (let ((subclasses (classoid-subclasses class2)))
+      (if (and subclasses (gethash class1 subclasses))
+          (values t t)
+          (values nil t)))))
 
 ;;; When finding the intersection of a sealed class and some other
 ;;; class (not hierarchically related) the intersection is the union
 
 (!define-type-method (classoid :simple-intersection2) (class1 class2)
   (declare (type classoid class1 class2))
-  (ensure-both-classoids-valid class1 class2)
-  (cond ((eq class1 class2)
-         class1)
-        ;; If one is a subclass of the other, then that is the
-        ;; intersection.
-        ((let ((subclasses (classoid-subclasses class2)))
-           (and subclasses (gethash class1 subclasses)))
-         class1)
-        ((let ((subclasses (classoid-subclasses class1)))
-           (and subclasses (gethash class2 subclasses)))
-         class2)
-        ;; Otherwise, we can't in general be sure that the
-        ;; intersection is empty, since a subclass of both might be
-        ;; defined. But we can eliminate it for some special cases.
-        ((or (structure-classoid-p class1)
-             (structure-classoid-p class2))
-         ;; No subclass of both can be defined.
-         *empty-type*)
-        ((eq (classoid-state class1) :sealed)
-         ;; checking whether a subclass of both can be defined:
-         (sealed-class-intersection2 class1 class2))
-        ((eq (classoid-state class2) :sealed)
-         ;; checking whether a subclass of both can be defined:
-         (sealed-class-intersection2 class2 class1))
-        (t
-         ;; uncertain, since a subclass of both might be defined
-         nil)))
+  (with-world-lock ()
+    (%ensure-both-classoids-valid class1 class2)
+    (cond ((eq class1 class2)
+           class1)
+          ;; If one is a subclass of the other, then that is the
+          ;; intersection.
+          ((let ((subclasses (classoid-subclasses class2)))
+             (and subclasses (gethash class1 subclasses)))
+           class1)
+          ((let ((subclasses (classoid-subclasses class1)))
+             (and subclasses (gethash class2 subclasses)))
+           class2)
+          ;; Otherwise, we can't in general be sure that the
+          ;; intersection is empty, since a subclass of both might be
+          ;; defined. But we can eliminate it for some special cases.
+          ((or (structure-classoid-p class1)
+               (structure-classoid-p class2))
+           ;; No subclass of both can be defined.
+           *empty-type*)
+          ((eq (classoid-state class1) :sealed)
+           ;; checking whether a subclass of both can be defined:
+           (sealed-class-intersection2 class1 class2))
+          ((eq (classoid-state class2) :sealed)
+           ;; checking whether a subclass of both can be defined:
+           (sealed-class-intersection2 class2 class1))
+          (t
+           ;; uncertain, since a subclass of both might be defined
+           nil))))
 
 ;;; KLUDGE: we need this to deal with the special-case INSTANCE and
 ;;; FUNCALLABLE-INSTANCE types (which used to be CLASSOIDs until CSR
 ;;;; class definition/redefinition
 
 ;;; This is to be called whenever we are altering a class.
-(defun modify-classoid (classoid)
+(defun %modify-classoid (classoid)
   (clear-type-caches)
   (when (member (classoid-state classoid) '(:read-only :frozen))
     ;; FIXME: This should probably be CERROR.
 ;;; nominal superclasses.)  We set the layout-clos-hash slots to 0 to
 ;;; invalidate the wrappers for specialized dispatch functions, which
 ;;; use those slots as indexes into tables.
-(defun invalidate-layout (layout)
+(defun %invalidate-layout (layout)
   (declare (type layout layout))
   (setf (layout-invalid layout) t
         (layout-depthoid layout) -1)
   (setf (layout-clos-hash layout) 0)
   (let ((inherits (layout-inherits layout))
         (classoid (layout-classoid layout)))
-    (modify-classoid classoid)
+    (%modify-classoid classoid)
     (dovector (super inherits)
       (let ((subs (classoid-subclasses (layout-classoid super))))
         (when subs
index 63362b7..57c5c12 100644 (file)
   ;; forms run.
   (show-and-call !type-class-cold-init)
   (show-and-call !typedefs-cold-init)
+  (show-and-call !world-lock-cold-init)
   (show-and-call !classes-cold-init)
   (show-and-call !early-type-cold-init)
   (show-and-call !late-type-cold-init)
index 33ae08d..9ca88ae 100644 (file)
@@ -20,7 +20,7 @@
 ;;;; here: certainly enough that I (dan, 2003.1.22) don't want to mess
 ;;;; around deciding how to thread-safetify it.  So we use a Big Lock.
 ;;;; Because this code is mutually recursive with the compiler, we use
-;;;; the *big-compiler-lock*
+;;;; the *world-lock*.
 
 ;;;; miscellaneous load utilities
 
   (when (zerop (file-length stream))
     (error "attempt to load an empty FASL file:~%  ~S" (namestring stream)))
   (maybe-announce-load stream verbose)
-  (sb!thread:with-recursive-lock (sb!c::*big-compiler-lock*)
+  (with-world-lock ()
     (let* ((*fasl-input-stream* stream)
            (*fasl-symbol-buffer* (make-string 100))
            (*current-fop-table* (or (pop *free-fop-tables*) (make-array 1000)))
index bcc2934..2e65f03 100644 (file)
 ;;; Test whether OBJ-LAYOUT is from an instance of CLASSOID.
 (defun classoid-typep (obj-layout classoid object)
   (declare (optimize speed))
-  (multiple-value-bind (obj-layout layout)
-      (do ((layout (classoid-layout classoid) (classoid-layout classoid))
-           (i 0 (+ i 1))
-           (obj-layout obj-layout))
-          ((and (not (layout-invalid obj-layout))
-                (not (layout-invalid layout)))
-           (values obj-layout layout))
-        (aver (< i 2))
-        (when (layout-invalid obj-layout)
-          (setq obj-layout (update-object-layout-or-invalid object layout)))
-        (ensure-classoid-valid classoid layout))
-    (let ((obj-inherits (layout-inherits obj-layout)))
-      (or (eq obj-layout layout)
-          (dotimes (i (length obj-inherits) nil)
-            (when (eq (svref obj-inherits i) layout)
-              (return t)))))))
+  (with-world-lock ()
+    (multiple-value-bind (obj-layout layout)
+        (do ((layout (classoid-layout classoid) (classoid-layout classoid))
+             (i 0 (+ i 1))
+             (obj-layout obj-layout))
+            ((and (not (layout-invalid obj-layout))
+                  (not (layout-invalid layout)))
+             (values obj-layout layout))
+          (aver (< i 2))
+          (when (layout-invalid obj-layout)
+            (setq obj-layout (update-object-layout-or-invalid object layout)))
+          (%ensure-classoid-valid classoid layout))
+      (let ((obj-inherits (layout-inherits obj-layout)))
+        (or (eq obj-layout layout)
+            (dotimes (i (length obj-inherits) nil)
+              (when (eq (svref obj-inherits i) layout)
+                (return t))))))))
index 54fffe9..877d2c8 100644 (file)
@@ -118,10 +118,17 @@ possible. Potentially long (over one page in size) vectors are, however, not
 stack allocated except in zero SAFETY code, as such a vector could overflow
 the stack without triggering overflow protection.")
 
-;;; This lock is seized in the compiler, and related areas: the
-;;; compiler is not presently thread-safe
-(defvar *big-compiler-lock*
-  (sb!thread:make-mutex :name "big compiler lock"))
+(!begin-collecting-cold-init-forms)
+;;; This lock is seized in the compiler, and related areas -- like the
+;;; classoid/layout/class system.
+(defvar *world-lock*)
+(!cold-init-forms
+ (setf *world-lock* (sb!thread:make-mutex :name "World Lock")))
+(!defun-from-collected-cold-init-forms !world-lock-cold-init)
+
+(defmacro with-world-lock (() &body body)
+  `(sb!thread:with-recursive-lock (*world-lock*)
+     ,@body))
 
 (declaim (type fixnum *compiler-sset-counter*))
 (defvar *compiler-sset-counter* 0)
index 234264f..a7e5d1c 100644 (file)
               (*compiler-note-count* 0)
               (*undefined-warnings* nil)
               (*in-compilation-unit* t))
-          (sb!thread:with-recursive-lock (*big-compiler-lock*)
+          (with-world-lock ()
             (handler-bind ((parse-unknown-type
                             (lambda (c)
                               (note-undefined-reference
index 518abf7..68daf7f 100644 (file)
 
 ;;; Set the inherits from CPL, and register the layout. This actually
 ;;; installs the class in the Lisp type system.
-(defun update-lisp-class-layout (class layout)
+(defun %update-lisp-class-layout (class layout)
+  ;; Protected by *world-lock* in callers.
   (let ((classoid (layout-classoid layout))
         (olayout (class-wrapper class)))
     (unless (eq (classoid-layout classoid) layout)
         (when (and name (symbolp name) (eq name (classoid-name classoid)))
           (setf (find-classoid name) classoid))))))
 
-(defun set-class-type-translation (class classoid)
+(defun %set-class-type-translation (class classoid)
   (when (not (typep classoid 'classoid))
     (setq classoid (find-classoid classoid nil)))
   (etypecase classoid
           (aver (eq class lclass-pcl-class))
           (setf (classoid-pcl-class lclass) class))
 
-      (update-lisp-class-layout class layout)
+      (%update-lisp-class-layout class layout)
 
       (cond (olclass
              (aver (eq lclass olclass)))
             (t
              (setf (find-classoid name) lclass)))
 
-      (set-class-type-translation class name))))
+      (%set-class-type-translation class name))))
 
 (setq *boot-state* 'braid)
 
index 0aae966..aebc884 100644 (file)
 (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))
index 96a0ffc..c9bdfc3 100644 (file)
@@ -187,17 +187,15 @@ Except see also BREAK-VICIOUS-METACIRCLE.  -- CSR, 2003-05-28
 (defvar *standard-slot-locations* (make-hash-table :test 'equal))
 
 (defun compute-standard-slot-locations ()
-  (clrhash *standard-slot-locations*)
-  (dolist (class-name *standard-classes*)
-    (let ((class (find-class class-name)))
-      (dolist (slot (class-slots class))
-        (setf (gethash (cons class (slot-definition-name slot))
-                       *standard-slot-locations*)
-              (slot-definition-location slot))))))
-
-;;; FIXME: harmonize the names between COMPUTE-STANDARD-SLOT-LOCATIONS
-;;; and MAYBE-UPDATE-STANDARD-CLASS-LOCATIONS.
-(defun maybe-update-standard-class-locations (class)
+  (let ((new (make-hash-table :test 'equal)))
+    (dolist (class-name *standard-classes*)
+      (let ((class (find-class class-name)))
+        (dolist (slot (class-slots class))
+          (setf (gethash (cons class (slot-definition-name slot)) new)
+                (slot-definition-location slot)))))
+    (setf *standard-slot-locations* new)))
+
+(defun maybe-update-standard-slot-locations (class)
   (when (and (eq *boot-state* 'complete)
              (memq (class-name class) *standard-classes*))
     (compute-standard-slot-locations)))
index 7d92d9a..ccbcb4d 100644 (file)
 
 (defgeneric unparse-specializer-using-class (generic-function specializer))
 
-(defgeneric update-gf-dfun (class gf))
-
 (defgeneric validate-superclass (class superclass))
 
 (defgeneric (setf documentation) (new-value slotd doc-type)
index db395cd..cc8f029 100644 (file)
   :metaclass-name static-classoid
   :metaclass-constructor make-static-classoid
   :dd-type funcallable-structure)
-\f
-;;; WITH-PCL-LOCK is used around some forms that were previously
-;;; protected by WITHOUT-INTERRUPTS, but in a threaded SBCL we don't
-;;; have a useful WITHOUT-INTERRUPTS.  In an unthreaded SBCL I'm not
-;;; sure what the desired effect is anyway: should we be protecting
-;;; against the possibility of recursive calls into these functions
-;;; or are we using WITHOUT-INTERRUPTS as WITHOUT-SCHEDULING?
-;;;
-;;; Users: FORCE-CACHE-FLUSHES, MAKE-INSTANCES-OBSOLETE.  Note that
-;;; it's not all certain this is sufficent for threadsafety: do we
-;;; just have to protect against simultaneous calls to these mutators,
-;;; or actually to stop normal slot access etc at the same time as one
-;;; of them runs
-
-#+sb-thread
-(progn
-  (defvar *pcl-lock* (sb-thread::make-spinlock :name "PCL lock"))
-
-  (defmacro with-pcl-lock (&body body)
-    `(sb-thread::with-spinlock (*pcl-lock*)
-      ,@body)))
 
-#-sb-thread
-(defmacro with-pcl-lock (&body body)
-  `(progn ,@body))
index a9a657f..4a41a28 100644 (file)
          (with-single-package-locked-error
              (:symbol name "Using ~A as the class-name argument in ~
                            (SETF FIND-CLASS)"))
-         (let ((cell (find-classoid-cell name :create new-value)))
-           (cond (new-value
-                  (setf (classoid-cell-pcl-class cell) new-value)
-                  (when (eq *boot-state* 'complete)
-                    (let ((classoid (class-classoid new-value)))
-                      (setf (find-classoid name) classoid)
-                      (set-class-type-translation new-value classoid))))
-                 (cell
-                  (clear-classoid name cell)))
-           (when (or (eq *boot-state* 'complete)
-                     (eq *boot-state* 'braid))
-             (update-ctors 'setf-find-class :class new-value :name name))
-           new-value))
+         (with-world-lock ()
+           (let ((cell (find-classoid-cell name :create new-value)))
+             (cond (new-value
+                    (setf (classoid-cell-pcl-class cell) new-value)
+                    (when (eq *boot-state* 'complete)
+                      (let ((classoid (class-classoid new-value)))
+                        (setf (find-classoid name) classoid)
+                        (%set-class-type-translation new-value classoid))))
+                   (cell
+                    (%clear-classoid name cell)))
+             (when (or (eq *boot-state* 'complete)
+                       (eq *boot-state* 'braid))
+               (update-ctors 'setf-find-class :class new-value :name name))
+             new-value)))
         (t
          (error "~S is not a legal class name." name))))
 
index 8ad72f6..c316260 100644 (file)
             (make-initial-dfun gf))))
         (function dfun-state)
         (cons (car dfun-state))))))
-
-(defmethod update-gf-dfun ((class std-class) gf)
-  (let ((*new-class* class)
-        (arg-info (gf-arg-info gf)))
-    (cond
-      ((special-case-for-compute-discriminating-function-p gf))
-      ((gf-precompute-dfun-and-emf-p arg-info)
-       (multiple-value-bind (dfun cache info)
-           (make-final-dfun-internal gf)
-         (update-dfun gf dfun cache info))))))
 \f
 (defmethod (setf class-name) (new-value class)
   (let ((classoid (wrapper-classoid (class-wrapper class))))
index b6282b9..4ca5415 100644 (file)
 (defmethod raw-instance-allocator ((class standard-class))
   'allocate-standard-instance)
 
-;;; These four functions work on std-instances and fsc-instances. These are
+;;; These three functions work on std-instances and fsc-instances. These are
 ;;; instances for which it is possible to change the wrapper and the slots.
 ;;;
 ;;; For these kinds of instances, most specified methods from the instance
 ;;; structure protocol are promoted to the implementation-specific class
 ;;; std-class. Many of these methods call these four functions.
 
-(defun set-wrapper (inst new)
-  (cond ((std-instance-p inst)
-         (setf (std-instance-wrapper inst) new))
-        ((fsc-instance-p inst)
-         (setf (fsc-instance-wrapper inst) new))
+(defun %swap-wrappers-and-slots (i1 i2)
+  (cond ((std-instance-p i1)
+         (let ((w1 (std-instance-wrapper i1))
+               (s1 (std-instance-slots i1)))
+           (setf (std-instance-wrapper i1) (std-instance-wrapper i2))
+           (setf (std-instance-slots i1) (std-instance-slots i2))
+           (setf (std-instance-wrapper i2) w1)
+           (setf (std-instance-slots i2) s1)))
+        ((fsc-instance-p i1)
+         (let ((w1 (fsc-instance-wrapper i1))
+               (s1 (fsc-instance-slots i1)))
+           (setf (fsc-instance-wrapper i1) (fsc-instance-wrapper i2))
+           (setf (fsc-instance-slots i1) (fsc-instance-slots i2))
+           (setf (fsc-instance-wrapper i2) w1)
+           (setf (fsc-instance-slots i2) s1)))
         (t
          (error "unrecognized instance type"))))
-
-(defun swap-wrappers-and-slots (i1 i2)
-  (with-pcl-lock                        ;FIXME is this sufficient?
-   (cond ((std-instance-p i1)
-          (let ((w1 (std-instance-wrapper i1))
-                (s1 (std-instance-slots i1)))
-            (setf (std-instance-wrapper i1) (std-instance-wrapper i2))
-            (setf (std-instance-slots i1) (std-instance-slots i2))
-            (setf (std-instance-wrapper i2) w1)
-            (setf (std-instance-slots i2) s1)))
-         ((fsc-instance-p i1)
-          (let ((w1 (fsc-instance-wrapper i1))
-                (s1 (fsc-instance-slots i1)))
-            (setf (fsc-instance-wrapper i1) (fsc-instance-wrapper i2))
-            (setf (fsc-instance-slots i1) (fsc-instance-slots i2))
-            (setf (fsc-instance-wrapper i2) w1)
-            (setf (fsc-instance-slots i2) s1)))
-         (t
-          (error "unrecognized instance type")))))
 \f
 ;;;; STANDARD-INSTANCE-ACCESS
 
index c95cf63..84fcda4 100644 (file)
 (setf (gdefinition 'load-defclass) #'real-load-defclass)
 
 (defun ensure-class (name &rest args)
-  (apply #'ensure-class-using-class
-         (let ((class (find-class name nil)))
-           (when (and class (eq name (class-name class)))
-             ;; NAME is the proper name of CLASS, so redefine it
-             class))
-         name
-         args))
+  (with-world-lock ()
+    (apply #'ensure-class-using-class
+           (let ((class (find-class name nil)))
+             (when (and class (eq name (class-name class)))
+               ;; NAME is the proper name of CLASS, so redefine it
+               class))
+           name
+           args)))
 
 (defmethod ensure-class-using-class ((class null) name &rest args &key)
-  (multiple-value-bind (meta initargs)
-      (frob-ensure-class-args args)
-    (setf class (apply #'make-instance meta :name name initargs))
-    (without-package-locks
-      (setf (find-class name) class))
-    (set-class-type-translation class name)
-    class))
+  (with-world-lock ()
+    (multiple-value-bind (meta initargs)
+        (frob-ensure-class-args args)
+      (setf class (apply #'make-instance meta :name name initargs))
+      (without-package-locks
+        (setf (find-class name) class))))
+  ;; After boot (SETF FIND-CLASS) does this.
+  (unless (eq *boot-state* 'complete)
+    (%set-class-type-translation class name))
+  class)
 
 (defmethod ensure-class-using-class ((class pcl-class) name &rest args &key)
-  (multiple-value-bind (meta initargs)
-      (frob-ensure-class-args args)
-    (unless (eq (class-of class) meta)
-      (apply #'change-class class meta initargs))
-    (apply #'reinitialize-instance class initargs)
-    (without-package-locks
-      (setf (find-class name) class))
-    (set-class-type-translation class name)
-    class))
+  (with-world-lock ()
+    (multiple-value-bind (meta initargs)
+        (frob-ensure-class-args args)
+      (unless (eq (class-of class) meta)
+        (apply #'change-class class meta initargs))
+      (apply #'reinitialize-instance class initargs)
+      (without-package-locks
+        (setf (find-class name) class))))
+  ;; After boot (SETF FIND-CLASS) does this.
+  (unless (eq *boot-state* 'complete)
+    (%set-class-type-translation class name))
+  class)
 
 (defun frob-ensure-class-args (args)
   (let (metaclass metaclassp reversed-plist)
   (flet ((compute-preliminary-cpl (root)
            (let ((*allow-forward-referenced-classes-in-cpl-p* t))
              (compute-class-precedence-list root))))
-    (without-package-locks
-     (unless (class-finalized-p class)
-       (let ((name (class-name class)))
-         ;; KLUDGE: This is fairly horrible.  We need to make a
-         ;; full-fledged CLASSOID here, not just tell the compiler that
-         ;; some class is forthcoming, because there are legitimate
-         ;; questions one can ask of the type system, implemented in
-         ;; terms of CLASSOIDs, involving forward-referenced classes. So.
-         (let ((layout (make-wrapper 0 class)))
-           (setf (slot-value class 'wrapper) layout)
-           (let ((cpl (compute-preliminary-cpl class)))
-             (setf (layout-inherits layout)
-                   (order-layout-inherits
-                    (map 'simple-vector #'class-wrapper
-                         (reverse (rest cpl))))))
-           (register-layout layout :invalidate t)
-           (set-class-type-translation class (layout-classoid layout)))))
-     (mapc #'make-preliminary-layout (class-direct-subclasses class)))))
+    (with-world-lock ()
+      (without-package-locks
+        (unless (class-finalized-p class)
+          (let ((name (class-name class)))
+            ;; KLUDGE: This is fairly horrible.  We need to make a
+            ;; full-fledged CLASSOID here, not just tell the compiler that
+            ;; some class is forthcoming, because there are legitimate
+            ;; questions one can ask of the type system, implemented in
+            ;; terms of CLASSOIDs, involving forward-referenced classes. So.
+            (let ((layout (make-wrapper 0 class)))
+              (setf (slot-value class 'wrapper) layout)
+              (let ((cpl (compute-preliminary-cpl class)))
+                (setf (layout-inherits layout)
+                      (order-layout-inherits
+                       (map 'simple-vector #'class-wrapper
+                            (reverse (rest cpl))))))
+              (register-layout layout :invalidate t)
+              (%set-class-type-translation class (layout-classoid layout)))))
+        (mapc #'make-preliminary-layout (class-direct-subclasses class))))))
 
 
 (defmethod shared-initialize :before ((class class) slot-names &key name)
 ;;; or reinitialized. The class may or may not be finalized.
 (defun update-class (class finalizep)
   (without-package-locks
-    (when (or finalizep (class-finalized-p class))
-      (update-cpl class (compute-class-precedence-list class))
-      ;; This invocation of UPDATE-SLOTS, in practice, finalizes the
-      ;; class.
-      (update-slots class (compute-slots class))
-      (update-gfs-of-class class)
-      (update-initargs class (compute-default-initargs class))
-      (update-ctors 'finalize-inheritance :class class))
-    (dolist (sub (class-direct-subclasses class))
-      (update-class sub nil))))
+    (with-world-lock ()
+      (when (or finalizep (class-finalized-p class))
+        (%update-cpl class (compute-class-precedence-list class))
+        ;; This invocation of UPDATE-SLOTS, in practice, finalizes the
+        ;; class.
+        (%update-slots class (compute-slots class))
+        (update-gfs-of-class class)
+        (setf (plist-value class 'default-initargs) (compute-default-initargs class))
+        (update-ctors 'finalize-inheritance :class class))
+      (dolist (sub (class-direct-subclasses class))
+        (update-class sub nil)))))
 
 (define-condition cpl-protocol-violation (reference-condition error)
   ((class :initarg :class :reader cpl-protocol-violation-class)
              (find-class 'function)
              (cpl-protocol-violation-cpl c)))))
 
-(defun update-cpl (class cpl)
+(defun %update-cpl (class cpl)
   (when (eq (class-of class) *the-class-standard-class*)
     (when (find (find-class 'function) cpl)
       (error 'cpl-protocol-violation :class class :cpl cpl)))
                                      :key #'slot-definition-allocation)
                        (return nil))))
         ;; comment from the old CMU CL sources:
-        ;;   Need to have the cpl setup before update-lisp-class-layout
+        ;;   Need to have the cpl setup before %update-lisp-class-layout
         ;;   is called on CMU CL.
         (setf (slot-value class '%class-precedence-list) cpl)
         (setf (slot-value class 'cpl-available-p) t)
-        (force-cache-flushes class))
+        (%force-cache-flushes class))
       (progn
         (setf (slot-value class '%class-precedence-list) cpl)
         (setf (slot-value class 'cpl-available-p) t)))
 (defun class-can-precede-p (class1 class2)
   (member class2 (class-can-precede-list class1) :test #'eq))
 
-(defun update-slots (class eslotds)
+(defun %update-slots (class eslotds)
   (let ((instance-slots ())
         (class-slots    ()))
     (dolist (eslotd eslotds)
                    (make-instances-obsolete class)
                    (class-wrapper class)))))
 
-      (update-lisp-class-layout class nwrapper)
+      (%update-lisp-class-layout class nwrapper)
       (setf (slot-value class 'slots) eslotds
             (wrapper-slot-table nwrapper) (make-slot-table class eslotds)
             (wrapper-instance-slots-layout nwrapper) nlayout
                      :test #'string= :key #'car))))
       (setf (slot-value class 'finalized-p) t)
       (unless (eq owrapper nwrapper)
-        (maybe-update-standard-class-locations class)))))
+        (maybe-update-standard-slot-locations class)))))
 
 (defun compute-class-slots (eslotds)
   (let (collect)
         (aver cell)
         (push cell collect)))))
 
+(defun update-gf-dfun (class gf)
+  (let ((*new-class* class)
+        (arg-info (gf-arg-info gf)))
+    (cond
+      ((special-case-for-compute-discriminating-function-p gf))
+      ((gf-precompute-dfun-and-emf-p arg-info)
+       (multiple-value-bind (dfun cache info) (make-final-dfun-internal gf)
+         (update-dfun gf dfun cache info))))))
+
 (defun update-gfs-of-class (class)
   (when (and (class-finalized-p class)
              (let ((cpl (class-precedence-list class)))
                    (declare (ignore ignore))
                    (update-gf-dfun class gf))
                  gf-table)))))
-
-(defun update-initargs (class inits)
-  (setf (plist-value class 'default-initargs) inits))
 \f
 (defmethod compute-default-initargs ((class slot-class))
   (let ((initargs (loop for c in (class-precedence-list class)
 ;;;                    :UNINITIALIZED)))
 ;;;
 ;;; Thanks to Gerd Moellmann for the explanation.  -- CSR, 2002-10-29
-(defun force-cache-flushes (class)
+(defun %force-cache-flushes (class)
   (let* ((owrapper (class-wrapper class)))
     ;; We only need to do something if the wrapper is still valid. If
     ;; the wrapper isn't valid, state will be FLUSH or OBSOLETE, and
               (wrapper-class-slots owrapper))
         (setf (wrapper-slot-table nwrapper)
               (wrapper-slot-table owrapper))
-        (with-pcl-lock
-          (update-lisp-class-layout class nwrapper)
-          (setf (slot-value class 'wrapper) nwrapper)
-          ;; Use :OBSOLETE instead of :FLUSH if any superclass has
-          ;; been obsoleted.
-          (if (find-if (lambda (x)
-                         (and (consp x) (eq :obsolete (car x))))
-                       (layout-inherits owrapper)
-                       :key #'layout-invalid)
-              (invalidate-wrapper owrapper :obsolete nwrapper)
-              (invalidate-wrapper owrapper :flush nwrapper)))))))
-
-(defun flush-cache-trap (owrapper nwrapper instance)
-  (declare (ignore owrapper))
-  (set-wrapper instance nwrapper))
+        (%update-lisp-class-layout class nwrapper)
+        (setf (slot-value class 'wrapper) nwrapper)
+        ;; Use :OBSOLETE instead of :FLUSH if any superclass has
+        ;; been obsoleted.
+        (if (find-if (lambda (x)
+                       (and (consp x) (eq :obsolete (car x))))
+                     (layout-inherits owrapper)
+                     :key #'layout-invalid)
+            (%invalidate-wrapper owrapper :obsolete nwrapper)
+            (%invalidate-wrapper owrapper :flush nwrapper))))))
 \f
 ;;; MAKE-INSTANCES-OBSOLETE can be called by user code. It will cause
 ;;; the next access to the instance (as defined in 88-002R) to trap
 ;;; through the UPDATE-INSTANCE-FOR-REDEFINED-CLASS mechanism.
 (defmethod make-instances-obsolete ((class std-class))
-  (let* ((owrapper (class-wrapper class))
-         (nwrapper (make-wrapper (layout-length owrapper)
-                                 class)))
-    (unless (class-finalized-p class)
-      (if (class-has-a-forward-referenced-superclass-p class)
-          (return-from make-instances-obsolete class)
-          (update-cpl class (compute-class-precedence-list class))))
-    (setf (wrapper-instance-slots-layout nwrapper)
-          (wrapper-instance-slots-layout owrapper))
-    (setf (wrapper-class-slots nwrapper)
-          (wrapper-class-slots owrapper))
-    (setf (wrapper-slot-table nwrapper)
-          (wrapper-slot-table owrapper))
-    (with-pcl-lock
-        (update-lisp-class-layout class nwrapper)
+  (with-world-lock ()
+    (let* ((owrapper (class-wrapper class))
+           (nwrapper (make-wrapper (layout-length owrapper)
+                                   class)))
+      (unless (class-finalized-p class)
+        (if (class-has-a-forward-referenced-superclass-p class)
+            (return-from make-instances-obsolete class)
+            (%update-cpl class (compute-class-precedence-list class))))
+      (setf (wrapper-instance-slots-layout nwrapper)
+            (wrapper-instance-slots-layout owrapper))
+      (setf (wrapper-class-slots nwrapper)
+            (wrapper-class-slots owrapper))
+      (setf (wrapper-slot-table nwrapper)
+            (wrapper-slot-table owrapper))
+      (%update-lisp-class-layout class nwrapper)
       (setf (slot-value class 'wrapper) nwrapper)
-      (invalidate-wrapper owrapper :obsolete nwrapper)
+      (%invalidate-wrapper owrapper :obsolete nwrapper)
       class)))
 
 (defmethod make-instances-obsolete ((class symbol))
              "~@<obsolete structure error for a structure of type ~2I~_~S~:>"
              (type-of (obsolete-structure-datum condition))))))
 
-(defun obsolete-instance-trap (owrapper nwrapper instance)
+(defun %obsolete-instance-trap (owrapper nwrapper instance)
   (if (not (layout-for-std-class-p owrapper))
       (if *in-obsolete-instance-trap*
           *the-wrapper-of-structure-object*
-           (let ((*in-obsolete-instance-trap* t))
-             (error 'obsolete-structure :datum instance)))
+          (let ((*in-obsolete-instance-trap* t))
+            (error 'obsolete-structure :datum instance)))
       (let* ((class (wrapper-class* nwrapper))
              (copy (allocate-instance class)) ;??? allocate-instance ???
              (olayout (wrapper-instance-slots-layout owrapper))
                       (assq nlocal oclass-slots))
             (push nlocal added)))
 
-        (swap-wrappers-and-slots instance copy)
+        (%swap-wrappers-and-slots instance copy)
 
         (update-instance-for-redefined-class instance
                                              added
                                              plist)
         nwrapper)))
 \f
-(defun change-class-internal (instance new-class initargs)
+(defun %change-class (instance new-class initargs)
   (let* ((old-class (class-of instance))
          (copy (allocate-instance new-class))
          (new-wrapper (get-wrapper copy))
 
     ;; Make the copy point to the old instance's storage, and make the
     ;; old instance point to the new storage.
-    (swap-wrappers-and-slots instance copy)
+    (%swap-wrappers-and-slots instance copy)
 
     (apply #'update-instance-for-different-class copy instance initargs)
+
     instance))
 
 (defmethod change-class ((instance standard-object) (new-class standard-class)
                          &rest initargs)
-  (unless (class-finalized-p new-class)
-    (finalize-inheritance new-class))
-  (let ((cpl (class-precedence-list new-class)))
-    (dolist (class cpl)
-      (macrolet
-          ((frob (class-name)
-             `(when (eq class (find-class ',class-name))
-               (error 'metaobject-initialization-violation
-                :format-control "~@<Cannot ~S objects into ~S metaobjects.~@:>"
-                :format-arguments (list 'change-class ',class-name)
-                :references (list '(:amop :initialization ,class-name))))))
-        (frob class)
-        (frob generic-function)
-        (frob method)
-        (frob slot-definition))))
-  (change-class-internal instance new-class initargs))
+  (with-world-lock ()
+    (unless (class-finalized-p new-class)
+      (finalize-inheritance new-class))
+    (let ((cpl (class-precedence-list new-class)))
+      (dolist (class cpl)
+        (macrolet
+            ((frob (class-name)
+               `(when (eq class (find-class ',class-name))
+                  (error 'metaobject-initialization-violation
+                         :format-control "~@<Cannot ~S objects into ~S metaobjects.~@:>"
+                         :format-arguments (list 'change-class ',class-name)
+                         :references (list '(:amop :initialization ,class-name))))))
+          (frob class)
+          (frob generic-function)
+          (frob method)
+          (frob slot-definition))))
+    (%change-class instance new-class initargs)))
 
 (defmethod change-class ((instance forward-referenced-class)
                          (new-class standard-class) &rest initargs)
-  (let ((cpl (class-precedence-list new-class)))
-    (dolist (class cpl
-             (error 'metaobject-initialization-violation
-                    :format-control
-                    "~@<Cannot ~S ~S objects into non-~S objects.~@:>"
-                    :format-arguments
-                    (list 'change-class 'forward-referenced-class 'class)
-                    :references
-                    (list '(:amop :generic-function ensure-class-using-class)
-                          '(:amop :initialization class))))
-      (when (eq class (find-class 'class))
-        (return nil))))
-  (change-class-internal instance new-class initargs))
+  (with-world-lock ()
+    (let ((cpl (class-precedence-list new-class)))
+      (dolist (class cpl
+               (error 'metaobject-initialization-violation
+                      :format-control
+                      "~@<Cannot ~S ~S objects into non-~S objects.~@:>"
+                      :format-arguments
+                      (list 'change-class 'forward-referenced-class 'class)
+                      :references
+                      (list '(:amop :generic-function ensure-class-using-class)
+                            '(:amop :initialization class))))
+        (when (eq class (find-class 'class))
+          (return nil))))
+    (%change-class instance new-class initargs)))
 
 (defmethod change-class ((instance funcallable-standard-object)
                          (new-class funcallable-standard-class)
                          &rest initargs)
-  (let ((cpl (class-precedence-list new-class)))
-    (dolist (class cpl)
-      (macrolet
-          ((frob (class-name)
-             `(when (eq class (find-class ',class-name))
-               (error 'metaobject-initialization-violation
-                :format-control "~@<Cannot ~S objects into ~S metaobjects.~@:>"
-                :format-arguments (list 'change-class ',class-name)
-                :references (list '(:amop :initialization ,class-name))))))
-        (frob class)
-        (frob generic-function)
-        (frob method)
-        (frob slot-definition))))
-  (change-class-internal instance new-class initargs))
+  (with-world-lock ()
+    (let ((cpl (class-precedence-list new-class)))
+      (dolist (class cpl)
+        (macrolet
+            ((frob (class-name)
+               `(when (eq class (find-class ',class-name))
+                  (error 'metaobject-initialization-violation
+                         :format-control "~@<Cannot ~S objects into ~S metaobjects.~@:>"
+                         :format-arguments (list 'change-class ',class-name)
+                         :references (list '(:amop :initialization ,class-name))))))
+          (frob class)
+          (frob generic-function)
+          (frob method)
+          (frob slot-definition))))
+    (%change-class instance new-class initargs)))
 
 (defmethod change-class ((instance standard-object)
                          (new-class funcallable-standard-class)
index df531b1..02700ec 100644 (file)
@@ -57,7 +57,7 @@
 
 ;;; ...and one lock to rule them. Spinlock because for certain (rare)
 ;;; cases this lock might be grabbed in the course of method dispatch
-;;; -- and mostly this is already under the *big-compiler-lock*.
+;;; -- and mostly this is already under the *world-lock*
 (defvar *pv-lock*
   (sb-thread::make-spinlock :name "pv table index lock"))
 
index d67e1c4..7abe628 100644 (file)
 ;;; 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
 ;;; 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)
index 793161b..bbe9934 100644 (file)
@@ -11,8 +11,9 @@
 ;;;; absoluely no warranty. See the COPYING and CREDITS files for
 ;;;; more information.
 
-(in-package "SB-THREAD") ; this is white-box testing, really
+; WHITE-BOX TESTS
 
+(in-package "SB-THREAD")
 (use-package :test-util)
 (use-package "ASSERTOID")
 
 (with-test (:name '(:hash-cache :subtypep))
   (dotimes (i 10)
     (sb-thread:make-thread #'subtypep-hash-cache-test)))
-
 (format t "hash-cache tests done~%")
+
+;;;; BLACK BOX TESTS
+
+(in-package :cl-user)
+(use-package :test-util)
+(use-package "ASSERTOID")
+
+(format t "parallel defclass test -- WARNING, WILL HANG ON FAILURE!~%")
+(with-test (:name :parallel-defclass)
+  (defclass test-1 () ((a :initform :orig-a)))
+  (defclass test-2 () ((b :initform :orig-b)))
+  (defclass test-3 (test-1 test-2) ((c :initform :orig-c)))
+  (let* ((run t)
+         (d1 (sb-thread:make-thread (lambda ()
+                                      (loop while run
+                                            do (defclass test-1 () ((a :initform :new-a)))
+                                            (write-char #\1)
+                                            (force-output)))
+                                    :name "d1"))
+         (d2 (sb-thread:make-thread (lambda ()
+                                      (loop while run
+                                            do (defclass test-2 () ((b :initform :new-b)))
+                                               (write-char #\2)
+                                               (force-output)))
+                                    :name "d2"))
+         (d3 (sb-thread:make-thread (lambda ()
+                                      (loop while run
+                                            do (defclass test-3 (test-1 test-2) ((c :initform :new-c)))
+                                               (write-char #\3)
+                                               (force-output)))
+                                    :name "d3"))
+         (i (sb-thread:make-thread (lambda ()
+                                     (loop while run
+                                           do (let ((i (make-instance 'test-3)))
+                                                (assert (member (slot-value i 'a) '(:orig-a :new-a)))
+                                                (assert (member (slot-value i 'b) '(:orig-b :new-b)))
+                                                (assert (member (slot-value i 'c) '(:orig-c :new-c))))
+                                              (write-char #\i)
+                                              (force-output)))
+                                   :name "i")))
+    (format t "~%sleeping!~%")
+    (sleep 2.0)
+    (format t "~%stopping!~%")
+    (setf run nil)
+    (mapc (lambda (th)
+            (sb-thread:join-thread th)
+            (format t "~%joined ~S~%" (sb-thread:thread-name th)))
+          (list d1 d2 d3 i))))
+(format t "parallel defclass test done~%")
index 5b90791..037992f 100644 (file)
@@ -17,4 +17,4 @@
 ;;; checkins which aren't released. (And occasionally for internal
 ;;; versions, especially for internal versions off the main CVS
 ;;; branch, it gets hairier, e.g. "0.pre7.14.flaky4.13".)
-"1.0.23.36"
+"1.0.23.37"