From 95f17ca63742f8c164309716b35bc25545a849a6 Mon Sep 17 00:00:00 2001 From: Nikodemus Siivola Date: Fri, 12 Dec 2008 12:27:00 +0000 Subject: [PATCH] 1.0.23.37: more CLOS and classoid thread safety * 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. --- NEWS | 2 + doc/internals-notes/threading-specials | 14 +- package-data-list.lisp-expr | 4 +- src/code/class.lisp | 233 +++++++++++++------------ src/code/cold-init.lisp | 1 + src/code/load.lisp | 4 +- src/code/typep.lisp | 33 ++-- src/compiler/early-c.lisp | 15 +- src/compiler/main.lisp | 2 +- src/pcl/braid.lisp | 9 +- src/pcl/ctor.lisp | 33 ++-- src/pcl/dfun.lisp | 20 +-- src/pcl/generic-functions.lisp | 2 - src/pcl/low.lisp | 24 --- src/pcl/macros.lisp | 27 +-- src/pcl/methods.lisp | 10 -- src/pcl/slots.lisp | 41 ++--- src/pcl/std-class.lisp | 296 +++++++++++++++++--------------- src/pcl/vector.lisp | 2 +- src/pcl/wrapper.lisp | 76 ++++---- tests/threads.impure.lisp | 53 +++++- version.lisp-expr | 2 +- 22 files changed, 469 insertions(+), 434 deletions(-) diff --git a/NEWS b/NEWS index f120abb..d1f18ab 100644 --- 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 diff --git a/doc/internals-notes/threading-specials b/doc/internals-notes/threading-specials index 73f5f06..56895e7 100644 --- a/doc/internals-notes/threading-specials +++ b/doc/internals-notes/threading-specials @@ -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* diff --git a/package-data-list.lisp-expr b/package-data-list.lisp-expr index b74ab1f..c8e837c 100644 --- a/package-data-list.lisp-expr +++ b/package-data-list.lisp-expr @@ -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" diff --git a/src/code/class.lisp b/src/code/class.lisp index 901713e..de34a74 100644 --- a/src/code/class.lisp +++ b/src/code/class.lisp @@ -101,6 +101,7 @@ ;;; 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*") @@ -254,7 +255,7 @@ ;; 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) @@ -273,8 +274,8 @@ (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 @@ -329,12 +330,12 @@ `(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. @@ -435,14 +436,15 @@ 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 @@ -456,58 +458,59 @@ (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 @@ -693,6 +696,7 @@ ;; 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))) @@ -720,13 +724,11 @@ (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)) @@ -791,7 +793,7 @@ (classoid-layout new-value)))))) new-value) - (defun clear-classoid (name cell) + (defun %clear-classoid (name cell) (ecase (info :type :kind name) ((nil)) (:defined) @@ -850,29 +852,30 @@ ;;; 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) @@ -888,11 +891,12 @@ (!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 @@ -912,33 +916,34 @@ (!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 @@ -1481,7 +1486,7 @@ ;;;; 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. @@ -1496,14 +1501,14 @@ ;;; 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 diff --git a/src/code/cold-init.lisp b/src/code/cold-init.lisp index 63362b7..57c5c12 100644 --- a/src/code/cold-init.lisp +++ b/src/code/cold-init.lisp @@ -141,6 +141,7 @@ ;; 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) diff --git a/src/code/load.lisp b/src/code/load.lisp index 33ae08d..9ca88ae 100644 --- a/src/code/load.lisp +++ b/src/code/load.lisp @@ -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 @@ -398,7 +398,7 @@ (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))) diff --git a/src/code/typep.lisp b/src/code/typep.lisp index bcc2934..2e65f03 100644 --- a/src/code/typep.lisp +++ b/src/code/typep.lisp @@ -178,19 +178,20 @@ ;;; 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)))))))) diff --git a/src/compiler/early-c.lisp b/src/compiler/early-c.lisp index 54fffe9..877d2c8 100644 --- a/src/compiler/early-c.lisp +++ b/src/compiler/early-c.lisp @@ -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) diff --git a/src/compiler/main.lisp b/src/compiler/main.lisp index 234264f..a7e5d1c 100644 --- a/src/compiler/main.lisp +++ b/src/compiler/main.lisp @@ -176,7 +176,7 @@ (*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 diff --git a/src/pcl/braid.lisp b/src/pcl/braid.lisp index 518abf7..68daf7f 100644 --- a/src/pcl/braid.lisp +++ b/src/pcl/braid.lisp @@ -629,7 +629,8 @@ ;;; 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) @@ -649,7 +650,7 @@ (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 @@ -686,14 +687,14 @@ (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) diff --git a/src/pcl/ctor.lisp b/src/pcl/ctor.lisp index 0aae966..aebc884 100644 --- a/src/pcl/ctor.lisp +++ b/src/pcl/ctor.lisp @@ -241,22 +241,23 @@ (defvar *the-system-si-method* nil) (defun install-optimized-constructor (ctor) - (let ((class (find-class (ctor-class-name ctor)))) - (unless (class-finalized-p class) - (finalize-inheritance class)) - ;; 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)) diff --git a/src/pcl/dfun.lisp b/src/pcl/dfun.lisp index 96a0ffc..c9bdfc3 100644 --- a/src/pcl/dfun.lisp +++ b/src/pcl/dfun.lisp @@ -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))) diff --git a/src/pcl/generic-functions.lisp b/src/pcl/generic-functions.lisp index 7d92d9a..ccbcb4d 100644 --- a/src/pcl/generic-functions.lisp +++ b/src/pcl/generic-functions.lisp @@ -363,8 +363,6 @@ (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) diff --git a/src/pcl/low.lisp b/src/pcl/low.lisp index db395cd..cc8f029 100644 --- a/src/pcl/low.lisp +++ b/src/pcl/low.lisp @@ -365,28 +365,4 @@ :metaclass-name static-classoid :metaclass-constructor make-static-classoid :dd-type funcallable-structure) - -;;; 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)) diff --git a/src/pcl/macros.lisp b/src/pcl/macros.lisp index a9a657f..4a41a28 100644 --- a/src/pcl/macros.lisp +++ b/src/pcl/macros.lisp @@ -144,19 +144,20 @@ (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)))) diff --git a/src/pcl/methods.lisp b/src/pcl/methods.lisp index 8ad72f6..c316260 100644 --- a/src/pcl/methods.lisp +++ b/src/pcl/methods.lisp @@ -1650,16 +1650,6 @@ (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)))))) (defmethod (setf class-name) (new-value class) (let ((classoid (wrapper-classoid (class-wrapper class)))) diff --git a/src/pcl/slots.lisp b/src/pcl/slots.lisp index b6282b9..4ca5415 100644 --- a/src/pcl/slots.lisp +++ b/src/pcl/slots.lisp @@ -41,39 +41,30 @@ (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"))))) ;;;; STANDARD-INSTANCE-ACCESS diff --git a/src/pcl/std-class.lisp b/src/pcl/std-class.lisp index c95cf63..84fcda4 100644 --- a/src/pcl/std-class.lisp +++ b/src/pcl/std-class.lisp @@ -336,33 +336,40 @@ (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) @@ -472,24 +479,25 @@ (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) @@ -808,16 +816,17 @@ ;;; 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) @@ -835,7 +844,7 @@ (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))) @@ -849,11 +858,11 @@ :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))) @@ -869,7 +878,7 @@ (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) @@ -908,7 +917,7 @@ (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 @@ -935,7 +944,7 @@ :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) @@ -946,6 +955,15 @@ (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))) @@ -962,9 +980,6 @@ (declare (ignore ignore)) (update-gf-dfun class gf)) gf-table))))) - -(defun update-initargs (class inits) - (setf (plist-value class 'default-initargs) inits)) (defmethod compute-default-initargs ((class slot-class)) (let ((initargs (loop for c in (class-precedence-list class) @@ -1280,7 +1295,7 @@ ;;; :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 @@ -1301,43 +1316,38 @@ (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)))))) ;;; 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)) @@ -1385,12 +1395,12 @@ "~@" (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)) @@ -1438,7 +1448,7 @@ (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 @@ -1446,7 +1456,7 @@ plist) nwrapper))) -(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)) @@ -1477,63 +1487,67 @@ ;; 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 "~@" - :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 "~@" + :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 - "~@" - :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 + "~@" + :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 "~@" - :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 "~@" + :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) diff --git a/src/pcl/vector.lisp b/src/pcl/vector.lisp index df531b1..02700ec 100644 --- a/src/pcl/vector.lisp +++ b/src/pcl/vector.lisp @@ -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")) diff --git a/src/pcl/wrapper.lisp b/src/pcl/wrapper.lisp index d67e1c4..7abe628 100644 --- a/src/pcl/wrapper.lisp +++ b/src/pcl/wrapper.lisp @@ -124,8 +124,7 @@ ;;; We only use this inside INVALIDATE-WRAPPER. (defvar *previous-nwrappers* (make-hash-table)) -;;; We always call this inside WITH-PCL-LOCK. -(defun invalidate-wrapper (owrapper state nwrapper) +(defun %invalidate-wrapper (owrapper state nwrapper) (aver (member state '(:flush :obsolete) :test #'eq)) (let ((new-previous ())) ;; First off, a previous call to INVALIDATE-WRAPPER may have @@ -158,39 +157,46 @@ ;;; we return the valid wrapper, which is not obvious from the name ;;; (or the names of our callees.) (defun check-wrapper-validity (instance) - (let* ((owrapper (wrapper-of instance)) - (state (layout-invalid owrapper))) - (aver (not (eq state :uninitialized))) - (cond ((not state) - owrapper) - ((not (layout-for-std-class-p owrapper)) - ;; Obsolete structure trap. - (obsolete-instance-trap owrapper nil instance)) - ((eq t state) - ;; FIXME: I can't help thinking that, while this does cure - ;; the symptoms observed from some class redefinitions, - ;; this isn't the place to be doing this flushing. - ;; Nevertheless... -- CSR, 2003-05-31 - ;; - ;; CMUCL comment: - ;; We assume in this case, that the :INVALID is from a - ;; previous call to REGISTER-LAYOUT for a superclass of - ;; INSTANCE's class. See also the comment above - ;; FORCE-CACHE-FLUSHES. Paul Dietz has test cases for this. - (force-cache-flushes (class-of instance)) - ;; KLUDGE avoid an infinite recursion, it's still better to - ;; bail out with an AVER for server softwares. see FIXME above. - ;; details: http://thread.gmane.org/gmane.lisp.steel-bank.devel/10175 - (aver (not (eq (layout-invalid (wrapper-of instance)) t))) - (check-wrapper-validity instance)) - ((consp state) - (ecase (car state) - (:flush - (flush-cache-trap owrapper (cadr state) instance)) - (:obsolete - (obsolete-instance-trap owrapper (cadr state) instance)))) - (t - (bug "Invalid LAYOUT-INVALID: ~S" state))))) + (with-world-lock () + (let* ((owrapper (wrapper-of instance)) + (state (layout-invalid owrapper))) + (aver (not (eq state :uninitialized))) + (cond ((not state) + owrapper) + ((not (layout-for-std-class-p owrapper)) + ;; Obsolete structure trap. + (%obsolete-instance-trap owrapper nil instance)) + ((eq t state) + ;; FIXME: I can't help thinking that, while this does cure + ;; the symptoms observed from some class redefinitions, + ;; this isn't the place to be doing this flushing. + ;; Nevertheless... -- CSR, 2003-05-31 + ;; + ;; CMUCL comment: + ;; We assume in this case, that the :INVALID is from a + ;; previous call to REGISTER-LAYOUT for a superclass of + ;; INSTANCE's class. See also the comment above + ;; FORCE-CACHE-FLUSHES. Paul Dietz has test cases for this. + (%force-cache-flushes (class-of instance)) + ;; KLUDGE avoid an infinite recursion, it's still better to + ;; bail out with an AVER for server softwares. see FIXME above. + ;; details: http://thread.gmane.org/gmane.lisp.steel-bank.devel/10175 + (aver (not (eq (layout-invalid (wrapper-of instance)) t))) + (check-wrapper-validity instance)) + ((consp state) + (ecase (car state) + (:flush + (let ((new (cadr state))) + (cond ((std-instance-p instance) + (setf (std-instance-wrapper instance) new)) + ((fsc-instance-p instance) + (setf (fsc-instance-wrapper instance) new)) + (t + (bug "unrecognized instance type"))))) + (:obsolete + (%obsolete-instance-trap owrapper (cadr state) instance)))) + (t + (bug "Invalid LAYOUT-INVALID: ~S" state)))))) (declaim (inline check-obsolete-instance)) (defun check-obsolete-instance (instance) diff --git a/tests/threads.impure.lisp b/tests/threads.impure.lisp index 793161b..bbe9934 100644 --- a/tests/threads.impure.lisp +++ b/tests/threads.impure.lisp @@ -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") @@ -997,5 +998,53 @@ (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~%") diff --git a/version.lisp-expr b/version.lisp-expr index 5b90791..037992f 100644 --- a/version.lisp-expr +++ b/version.lisp-expr @@ -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" -- 1.7.10.4