* 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.
* 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
= 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*
"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"
"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"
"!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"
;;; 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
;; 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)
;;;; 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)))
;;; 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))))))))
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)
(*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
;;; 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)
(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))
(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)))
(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)
: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))
(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))))
(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))))
(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
(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)
;;; ...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"))
;;; 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)
;;;; 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~%")
;;; 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"
projects / sbcl.git / commitdiff