From b9a1b17b079d315c1eec194eb4f93f7d058b24cf Mon Sep 17 00:00:00 2001 From: Nikodemus Siivola Date: Mon, 12 Nov 2007 17:14:50 +0000 Subject: [PATCH] 1.0.11.22: hash-table synchronization support * :SYNCHRONIZED argument to MAKE-HASH-TABLE. * HASH-TABLE-SYNCHRONIZED-P predicate. * WITH-LOCKED-HASH-TABLE for coarser locks. * Additional MAPHASH & WITH-HASH-TABLE-ITERATOR documentation. * :LOCKED argument added to DOHASH, and used where appropriate (some usages might be overly conservative, though, and could be removed.) --- NEWS | 5 ++ package-data-list.lisp-expr | 4 ++ src/code/class.lisp | 8 ++-- src/code/cross-misc.lisp | 4 ++ src/code/defstruct.lisp | 17 +++---- src/code/describe.lisp | 2 +- src/code/dyncount.lisp | 29 +++++------ src/code/early-extensions.lisp | 27 +++++++---- src/code/hash-table.lisp | 38 +++++++++++---- src/code/profile.lisp | 7 +-- src/code/target-hash-table.lisp | 101 +++++++++++++++++++++++---------------- src/compiler/proclaim.lisp | 2 +- src/pcl/braid.lisp | 34 ++++++------- src/pcl/defs.lisp | 2 +- src/pcl/fixup.lisp | 2 +- version.lisp-expr | 2 +- 16 files changed, 173 insertions(+), 111 deletions(-) diff --git a/NEWS b/NEWS index a48543c..da64a4f 100644 --- a/NEWS +++ b/NEWS @@ -1,5 +1,10 @@ ;;;; -*- coding: utf-8; -*- changes in sbcl-1.0.12 relative to sbcl-1.0.11: + * new feature: MAKE-HASH-TABLE now experimentally accepts a + :SYNCHRONIZED argument, which makes the hash-table safe for + concurrent accesses (but not iteration.) See also: + SB-EXT:WITH-LOCKED-HASH-TABLE, and + SB-EXT:HASH-TABLE-SYNCHRONIZED-P. * bug fix: SB-SYS:WITH-PINNED-OBJECTS could cause garbage values to be returned from its body when the values were being returned using unknown-values return convection and the W-P-O was wrapped diff --git a/package-data-list.lisp-expr b/package-data-list.lisp-expr index c93e2c4..3e5507f 100644 --- a/package-data-list.lisp-expr +++ b/package-data-list.lisp-expr @@ -669,6 +669,10 @@ like *STACK-TOP-HINT* and unsupported stuff like *TRACED-FUN-LIST*." "HASH-TABLE-WEAKNESS" "MAKE-WEAK-POINTER" "WEAK-POINTER" "WEAK-POINTER-P" "WEAK-POINTER-VALUE" + ;; Hash table locking + "HASH-TABLE-SYNCHRONIZED-P" + "WITH-LOCKED-HASH-TABLE" + ;; If the user knows we're doing IEEE, he might reasonably ;; want to do this stuff. "FLOAT-DENORMALIZED-P" diff --git a/src/code/class.lisp b/src/code/class.lisp index c1ece12..79dc7ae 100644 --- a/src/code/class.lisp +++ b/src/code/class.lisp @@ -472,7 +472,7 @@ (when classoid-layout (modify-classoid classoid) (when subclasses - (dohash (subclass subclass-layout subclasses) + (dohash ((subclass subclass-layout) subclasses :locked t) (modify-classoid subclass) (when invalidate (invalidate-layout subclass-layout)))) @@ -595,7 +595,7 @@ (when (zerop count) (push successor free-objs)))))) (cond ((endp free-objs) - (dohash (obj info obj-info) + (dohash ((obj info) obj-info) (unless (zerop (first info)) (error "Topological sort failed due to constraint on ~S." obj))) @@ -858,7 +858,7 @@ NIL is returned when no such class exists." (o-sub (classoid-subclasses other))) (if (and s-sub o-sub) (collect ((res *empty-type* type-union)) - (dohash (subclass layout s-sub) + (dohash ((subclass layout) s-sub :locked t) (declare (ignore layout)) (when (gethash subclass o-sub) (res (specifier-type subclass)))) @@ -1474,7 +1474,7 @@ NIL is returned when no such class exists." ;;; late in the build-order.lisp-expr sequence, and be put in ;;; !COLD-INIT-FORMS there? (defun !class-finalize () - (dohash (name layout *forward-referenced-layouts*) + (dohash ((name layout) *forward-referenced-layouts*) (let ((class (find-classoid name nil))) (cond ((not class) (setf (layout-classoid layout) (make-undefined-classoid name))) diff --git a/src/code/cross-misc.lisp b/src/code/cross-misc.lisp index 16b4999..0bc086e 100644 --- a/src/code/cross-misc.lisp +++ b/src/code/cross-misc.lisp @@ -35,6 +35,10 @@ `(progn ,@body))) ,@forms)) +(defmacro with-locked-hash-table ((table) &body body) + (declare (ignore table)) + `(progn ,@body)) + ;;; The GENESIS function works with fasl code which would, in the ;;; target SBCL, work on ANSI-STREAMs (streams which aren't extended ;;; Gray streams). In ANSI Common Lisp, an ANSI-STREAM is just a diff --git a/src/code/defstruct.lisp b/src/code/defstruct.lisp index 338c09a..0fb2b36 100644 --- a/src/code/defstruct.lisp +++ b/src/code/defstruct.lisp @@ -971,14 +971,15 @@ (when (and (classoid-subclasses classoid) (not (eq layout old-layout))) (collect ((subs)) - (dohash (classoid layout (classoid-subclasses classoid)) - (declare (ignore layout)) - (undefine-structure classoid) - (subs (classoid-proper-name classoid))) - (when (subs) - (warn "removing old subclasses of ~S:~% ~S" - (classoid-name classoid) - (subs)))))) + (dohash ((classoid layout) (classoid-subclasses classoid) + :locked t) + (declare (ignore layout)) + (undefine-structure classoid) + (subs (classoid-proper-name classoid))) + (when (subs) + (warn "removing old subclasses of ~S:~% ~S" + (classoid-name classoid) + (subs)))))) (t (unless (eq (classoid-layout classoid) layout) (register-layout layout :invalidate nil)) diff --git a/src/code/describe.lisp b/src/code/describe.lisp index 51a5cfd..fe217a4 100644 --- a/src/code/describe.lisp +++ b/src/code/describe.lisp @@ -95,7 +95,7 @@ count (zerop count)) (let ((n 0)) (declare (type index n)) - (dohash (k v x) + (dohash ((k v) x :locked t) (unless (zerop n) (write-char #\space s)) (incf n) diff --git a/src/code/dyncount.lisp b/src/code/dyncount.lisp index fb723cf..c9270dc 100644 --- a/src/code/dyncount.lisp +++ b/src/code/dyncount.lisp @@ -37,9 +37,10 @@ comments from CMU CL: "Return a hash-table containing only the entries in Table1 whose key is not also a key in Table2." (declare (type hash-table table1 table2)) (let ((res (make-hash-table-like table1))) - (dohash (k v table1) - (unless (nth-value 1 (gethash k table2)) - (setf (gethash k res) v))) + (with-locked-hash-table (table2) + (dohash ((k v) table1 :locked t) + (unless (nth-value 1 (gethash k table2)) + (setf (gethash k res) v)))) res)) (defun hash-list (table) @@ -47,7 +48,7 @@ comments from CMU CL: "Return a list of the values in Table." (declare (type hash-table table)) (collect ((res)) - (dohash (k v table) + (dohash ((k v) table) (declare (ignore k)) (res v)) (res))) @@ -83,7 +84,7 @@ comments from CMU CL: (format-universal-time s (get-universal-time)) (terpri s) (format s "~S ~S ~S~%" test reader writer) - (dohash (k v table) + (dohash ((k v) table :locked t) (prin1 k s) (write-char #\space s) (funcall writer v s) @@ -162,7 +163,7 @@ comments from CMU CL: (defun clear-vop-counts (&optional (spaces '(:dynamic))) #!+sb-doc "Clear all dynamic VOP counts for code objects in the specified spaces." - (dohash (k v *backend-template-names*) + (dohash ((k v) *backend-template-names* :locked t) (declare (ignore v)) (remprop k 'vop-stats)) @@ -202,7 +203,7 @@ comments from CMU CL: space)))) (let ((counts (make-hash-table :test 'equal))) - (dohash (k v *backend-template-names*) + (dohash ((k v) *backend-template-names* :locked t) (declare (ignore v)) (let ((stats (get k 'vop-stats))) (when stats @@ -244,7 +245,7 @@ comments from CMU CL: "Return a hash-table mapping string VOP names to the cost recorded in the generator for all VOPs which are also the names of assembly routines." (let ((res (make-hash-table :test 'equal))) - (dohash (name v *assembler-routines*) + (dohash ((name v) *assembler-routines* :locked t) (declare (ignore v)) (let ((vop (gethash name *backend-template-names*))) (when vop @@ -309,7 +310,7 @@ comments from CMU CL: ;;; the class that NAME would be placed in. (defun find-matches (table pattern) (collect ((res)) - (dohash (key value table) + (dohash ((key value) table :locked t) (declare (ignore value)) (when (matches-pattern key pattern) (res key))) (res))) @@ -325,7 +326,7 @@ comments from CMU CL: ;;; matches no class. (defun classify-costs (table classes) (let ((res (make-hash-table-like table))) - (dohash (key value table) + (dohash ((key value) table :locked t) (let ((class (dolist (class classes nil) (when (matches-pattern key (rest class)) (return (first class)))))) @@ -344,7 +345,7 @@ comments from CMU CL: (defun cost-summary (table) (let ((total-count 0d0) (total-cost 0d0)) - (dohash (k v table) + (dohash ((k v) table :locked t) (declare (ignore k)) (incf total-count (vop-stats-count v)) (incf total-cost (vop-stats-cost v))) @@ -354,7 +355,7 @@ comments from CMU CL: ;;; according to the Costs table. Any VOPs in the list IGNORE are ignored. (defun compensate-costs (table costs &optional ignore) (let ((res (make-hash-table-like table))) - (dohash (key value table) + (dohash ((key value) table :locked t) (unless (or (string= key "COUNT-ME") (member key ignore :test #'string=)) (let ((cost (gethash key costs))) @@ -374,7 +375,7 @@ comments from CMU CL: (defun compare-stats (original compared) (declare (type hash-table original compared)) (let ((res (make-hash-table-like original))) - (dohash (k cv compared) + (dohash ((k cv) compared :locked t) (let ((ov (gethash k original))) (when ov (let ((norm-cnt (/ (vop-stats-count ov) (vop-stats-count cv)))) @@ -392,7 +393,7 @@ comments from CMU CL: combined results." (let ((res (make-hash-table-like (first tables)))) (dolist (table tables) - (dohash (k v table) + (dohash ((k v) table :locked t) (let ((found (or (gethash k res) (setf (gethash k res) (%make-vop-stats k))))) (incf (vop-stats-count found) (vop-stats-count v)) diff --git a/src/code/early-extensions.lisp b/src/code/early-extensions.lisp index bfe8451..9337589 100644 --- a/src/code/early-extensions.lisp +++ b/src/code/early-extensions.lisp @@ -434,17 +434,24 @@ (tagbody ,@forms))))))) -;;; Iterate over the entries in a HASH-TABLE. -(defmacro dohash ((key-var value-var table &optional result) &body body) +;;; Iterate over the entries in a HASH-TABLE, first obtaining the lock +;;; if the table is a synchronized table. +(defmacro dohash (((key-var value-var) table &key result locked) &body body) (multiple-value-bind (forms decls) (parse-body body :doc-string-allowed nil) - (let ((gen (gensym)) - (n-more (gensym))) - `(with-hash-table-iterator (,gen ,table) - (loop - (multiple-value-bind (,n-more ,key-var ,value-var) (,gen) - ,@decls - (unless ,n-more (return ,result)) - ,@forms)))))) + (let* ((gen (gensym)) + (n-more (gensym)) + (n-table (gensym)) + (iter-form `(with-hash-table-iterator (,gen ,n-table) + (loop + (multiple-value-bind (,n-more ,key-var ,value-var) (,gen) + ,@decls + (unless ,n-more (return ,result)) + ,@forms))))) + `(let ((,n-table ,table)) + ,(if locked + `(with-locked-hash-table (,n-table) + ,iter-form) + iter-form))))) ;;;; hash cache utility diff --git a/src/code/hash-table.lisp b/src/code/hash-table.lisp index 23f7b0f..f018119 100644 --- a/src/code/hash-table.lisp +++ b/src/code/hash-table.lisp @@ -69,13 +69,16 @@ ;; respective key. (hash-vector nil :type (or null (simple-array (unsigned-byte #.sb!vm:n-word-bits) (*)))) - ;; Used for locking GETHASH/(SETF GETHASH)/REMHASH for tables with :LOCK-P T - (spinlock (sb!thread::make-spinlock) :type sb!thread::spinlock) + ;; Used for locking GETHASH/(SETF GETHASH)/REMHASH + (spinlock (sb!thread::make-spinlock :name "hash-table lock") + :type sb!thread::spinlock :read-only t) ;; The GC will set this to T if it moves an EQ-based key. This used ;; to be signaled by a bit in the header of the kv vector, but that ;; implementation caused some concurrency issues when we stopped ;; inhibiting GC during hash-table lookup. (needs-rehash-p nil :type (member nil t)) + ;; Has user requested synchronization? + (synchronized-p nil :type (member nil t) :read-only t) ;; For detecting concurrent accesses. #!+sb-hash-table-debug (concurrent-access-error t :type (member nil t)) @@ -90,21 +93,22 @@ ;; the generational garbage collector needs to know it. (defconstant +magic-hash-vector-value+ (ash 1 (1- sb!vm:n-word-bits))) - (defmacro-mundanely with-hash-table-iterator ((function hash-table) &body body) #!+sb-doc "WITH-HASH-TABLE-ITERATOR ((function hash-table) &body body) -Provides a method of manually looping over the elements of a -hash-table. FUNCTION is bound to a generator-macro that, within the -scope of the invocation, returns one or three values. The first value -tells whether any objects remain in the hash table. When the first -value is non-NIL, the second and third values are the key and the -value of the next object. +Provides a method of manually looping over the elements of a hash-table. +FUNCTION is bound to a generator-macro that, within the scope of the +invocation, returns one or three values. The first value tells whether any +objects remain in the hash table. When the first value is non-NIL, the second +and third values are the key and the value of the next object. Consequences are undefined if HASH-TABLE is mutated during execution of BODY, except for changing or removing elements corresponding to the -current key." +current key. The applies to all threads, not just the curren one -- +even for synchronized hash-tables. If the table may be mutated by +another thread during iteration, use eg. SB-EXT:WITH-LOCKED-HASH-TABLE +to protect the WITH-HASH-TABLE-ITERATOR for." ;; This essentially duplicates MAPHASH, so any changes here should ;; be reflected there as well. (let ((n-function (gensym "WITH-HASH-TABLE-ITERATOR-"))) @@ -129,3 +133,17 @@ current key." #',function)))) (macrolet ((,function () '(funcall ,n-function))) ,@body)))) + +(defmacro-mundanely with-locked-hash-table ((hash-table) &body body) + #!+sb-doc + "Limits concurrent accesses to HASH-TABLE for the duration of BODY. +If HASH-TABLE is synchronized, BODY will execute with exclusive +ownership of the table. If HASH-TABLE is not synchronized, BODY will +execute with other WITH-LOCKED-HASH-TABLE bodies excluded -- exclusion +of hash-table accesses not surrounded by WITH-LOCKED-HASH-TABLE is +unspecified." + ;; Needless to say, this also excludes some internal bits, but + ;; getting there is too much detail when "unspecified" says what + ;; is important -- unpredictable, but harmless. + `(sb!thread::with-recursive-spinlock ((hash-table-spinlock ,hash-table)) + ,@body)) diff --git a/src/code/profile.lisp b/src/code/profile.lisp index 1cd2dc2..754fcb0 100644 --- a/src/code/profile.lisp +++ b/src/code/profile.lisp @@ -309,13 +309,14 @@ `(unprofile-all))) (defun unprofile-all () - (dohash (name profile-info *profiled-fun-name->info*) + (dohash ((name profile-info) *profiled-fun-name->info* + :locked t) (declare (ignore profile-info)) (unprofile-1-fun name))) (defun reset () "Reset the counters for all profiled functions." - (dohash (name profile-info *profiled-fun-name->info*) + (dohash ((name profile-info) *profiled-fun-name->info* :locked t) (declare (ignore name)) (funcall (profile-info-clear-stats-fun profile-info)))) @@ -358,7 +359,7 @@ Lisp process." (compute-overhead))) (let ((time-info-list ()) (no-call-name-list ())) - (dohash (name pinfo *profiled-fun-name->info*) + (dohash ((name pinfo) *profiled-fun-name->info* :locked t) (unless (eq (fdefinition name) (profile-info-encapsulation-fun pinfo)) (warn "Function ~S has been redefined, so times may be inaccurate.~@ diff --git a/src/code/target-hash-table.lisp b/src/code/target-hash-table.lisp index 88bb1ca..8d65255 100644 --- a/src/code/target-hash-table.lisp +++ b/src/code/target-hash-table.lisp @@ -146,7 +146,8 @@ (size +min-hash-table-size+) (rehash-size 1.5) (rehash-threshold 1) - (weakness nil)) + (weakness nil) + (synchronized)) #!+sb-doc "Create and return a new hash table. The keywords are as follows: :TEST -- Indicates what kind of test to use. @@ -160,7 +161,7 @@ forcing a rehash. Can be any positive number <=1, with density approaching zero as the threshold approaches 0. Density 1 means an average of one entry per bucket. - :WEAKNESS -- IF NIL (the default) it is a normal non-weak hash table. + :WEAKNESS -- If NIL (the default) it is a normal non-weak hash table. If one of :KEY, :VALUE, :KEY-AND-VALUE, :KEY-OR-VALUE it is a weak hash table. Depending on the type of weakness the lack of references to the @@ -171,7 +172,15 @@ is :KEY-AND-VALUE and either the key or the value would otherwise be garbage the entry can be removed. If WEAKNESS is :KEY-OR-VALUE and both the key and the value would otherwise be garbage the entry can - be removed." + be removed. + :SYNCHRONIZED -- If NIL (the default), the hash-table may have + multiple concurrent readers, but results are undefined if a + thread writes to the hash-table concurrently with another + reader or writer. If T, all concurrent accesses are safe, but + note that CLHS 3.6 (Traversal Rules and Side Effects) remains + in force. See also: SB-EXT:WITH-LOCKED-HASH-TABLE. This keyword + argument is experimental, and may change incompatibly or be + removed in the future." (declare (type (or function symbol) test)) (declare (type unsigned-byte size)) (multiple-value-bind (test test-fun hash-fun) @@ -251,7 +260,7 @@ :element-type '(unsigned-byte #.sb!vm:n-word-bits) :initial-element +magic-hash-vector-value+)) - :spinlock (sb!thread::make-spinlock)))) + :synchronized-p synchronized))) (declare (type index size+1 scaled-size length)) ;; Set up the free list, all free. These lists are 0 terminated. (do ((i 1 (1+ i))) @@ -504,33 +513,33 @@ multiple threads accessing the same hash-table without locking." (unless (hash-table-weakness hash-table) (setf (hash-table-cache hash-table) index))) -(defmacro with-hash-table-locks ((hash-table inline &rest pin-objects) +(defmacro with-hash-table-locks ((hash-table + &key inline pin + (synchronized `(hash-table-synchronized-p ,hash-table))) &body body) - `(with-concurrent-access-check ,hash-table - ;; Inhibit GC for the duration of BODY if the GC might mutate the - ;; HASH-TABLE in some way (currently true only if the table is - ;; weak). We also need to lock the table to ensure that two - ;; concurrent writers can't create a cyclical vector that would - ;; cause scav_weak_hash_table_chain to loop. - ;; - ;; Otherwise we can avoid the 2x-3x overhead, and just pin the key. - (if (hash-table-weakness ,hash-table) - (sb!thread::with-recursive-system-spinlock - ((hash-table-spinlock hash-table) :without-gcing t) - ,@body) - (with-pinned-objects ,pin-objects - (locally - ;; Inline the implementation function on the fast path - ;; only. (On the slow path it'll just bloat the - ;; generated code with no benefit). - (declare (inline ,@inline)) - ,@body))))) + (with-unique-names (body-fun) + `(with-concurrent-access-check ,hash-table + (flet ((,body-fun () + (locally (declare (inline ,@inline)) + ,@body))) + (if (hash-table-weakness ,hash-table) + (sb!thread::with-recursive-system-spinlock + ((hash-table-spinlock ,hash-table) :without-gcing t) + (,body-fun)) + (with-pinned-objects ,pin + (if ,synchronized + ;; We use a "system" spinlock here because it is very + ;; slightly faster, as it doesn't re-enable interrupts. + (sb!thread::with-recursive-system-spinlock + ((hash-table-spinlock ,hash-table)) + (,body-fun)) + (,body-fun)))))))) (defun gethash (key hash-table &optional default) #!+sb-doc - "Finds the entry in HASH-TABLE whose key is KEY and returns the associated - value and T as multiple values, or returns DEFAULT and NIL if there is no - such entry. Entries can be added using SETF." + "Finds the entry in HASH-TABLE whose key is KEY and returns the +associated value and T as multiple values, or returns DEFAULT and NIL +if there is no such entry. Entries can be added using SETF." (declare (type hash-table hash-table) (values t (member t nil))) (gethash3 key hash-table default)) @@ -613,7 +622,7 @@ multiple threads accessing the same hash-table without locking." (defun gethash3 (key hash-table default) "Three argument version of GETHASH" (declare (type hash-table hash-table)) - (with-hash-table-locks (hash-table (%gethash3) key) + (with-hash-table-locks (hash-table :inline (%gethash3) :pin (key)) (%gethash3 key hash-table default))) ;;; so people can call #'(SETF GETHASH) @@ -699,7 +708,8 @@ multiple threads accessing the same hash-table without locking." (defun %puthash (key hash-table value) (declare (type hash-table hash-table)) (aver (hash-table-index-vector hash-table)) - (let ((cache (hash-table-cache hash-table)) + (macrolet ((put-it (lockedp) + `(let ((cache (hash-table-cache hash-table)) (kv-vector (hash-table-table hash-table))) ;; Check the cache (if (and cache @@ -708,8 +718,16 @@ multiple threads accessing the same hash-table without locking." ;; If cached, just store here (setf (aref kv-vector (1+ cache)) value) ;; Otherwise do things the hard way - (with-hash-table-locks (hash-table (%%puthash) key) - (%%puthash key hash-table value))))) + ,(if lockedp + '(%%puthash key hash-table value) + '(with-hash-table-locks + (hash-table :inline (%%puthash) :pin (key) + :synchronized nil) + (%%puthash key hash-table value))))))) + (if (hash-table-synchronized-p hash-table) + (with-hash-table-locks (hash-table :pin (key) :synchronized t) + (put-it t)) + (put-it nil)))) (declaim (maybe-inline %remhash)) (defun %remhash (key hash-table) @@ -788,20 +806,20 @@ multiple threads accessing the same hash-table without locking." (defun remhash (key hash-table) #!+sb-doc - "Remove the entry in HASH-TABLE associated with KEY. Return T if there - was such an entry, or NIL if not." + "Remove the entry in HASH-TABLE associated with KEY. Return T if +there was such an entry, or NIL if not." (declare (type hash-table hash-table) (values (member t nil))) + (with-hash-table-locks (hash-table :inline (%remhash) :pin (key)) ;; For now, just clear the cache (setf (hash-table-cache hash-table) nil) - (with-hash-table-locks (hash-table (%remhash) key) (%remhash key hash-table))) (defun clrhash (hash-table) #!+sb-doc - "This removes all the entries from HASH-TABLE and returns the hash table - itself." - (with-hash-table-locks (hash-table nil) + "This removes all the entries from HASH-TABLE and returns the hash +table itself." + (with-hash-table-locks (hash-table) (let* ((kv-vector (hash-table-table hash-table)) (next-vector (hash-table-next-vector hash-table)) (hash-vector (hash-table-hash-vector hash-table)) @@ -840,12 +858,15 @@ multiple threads accessing the same hash-table without locking." (declaim (inline maphash)) (defun maphash (function-designator hash-table) #!+sb-doc - "For each entry in HASH-TABLE, call the designated two-argument -function on the key and value of the entry. Return NIL. + "For each entry in HASH-TABLE, call the designated two-argument function on +the key and value of the entry. Return NIL. Consequences are undefined if HASH-TABLE is mutated during the call to MAPHASH, except for changing or removing elements corresponding to the -current key." +current key. The applies to all threads, not just the current one -- +even for synchronized hash-tables. If the table may be mutated by +another thread during iteration, use eg. SB-EXT:WITH-LOCKED-HASH-TABLE +to protect the MAPHASH call." ;; This essentially duplicates WITH-HASH-TABLE-ITERATOR, so ;; any changes here should be reflected there as well. (let ((fun (%coerce-callable-to-fun function-designator)) diff --git a/src/compiler/proclaim.lisp b/src/compiler/proclaim.lisp index 8381cd9..57ad824 100644 --- a/src/compiler/proclaim.lisp +++ b/src/compiler/proclaim.lisp @@ -234,7 +234,7 @@ (setf (classoid-state class) :sealed) (let ((subclasses (classoid-subclasses class))) (when subclasses - (dohash (subclass layout subclasses) + (dohash ((subclass layout) subclasses :locked t) (declare (ignore layout)) (setf (classoid-state subclass) :sealed)))))))) (optimize diff --git a/src/pcl/braid.lisp b/src/pcl/braid.lisp index e4bcd4b..ae39f21 100644 --- a/src/pcl/braid.lisp +++ b/src/pcl/braid.lisp @@ -672,24 +672,24 @@ (!bootstrap-class-predicates nil) (!bootstrap-built-in-classes) -(dohash (name x *find-class*) - (let* ((class (find-class-from-cell name x)) - (layout (class-wrapper class)) - (lclass (layout-classoid layout)) - (lclass-pcl-class (classoid-pcl-class lclass)) - (olclass (find-classoid name nil))) - (if lclass-pcl-class - (aver (eq class lclass-pcl-class)) - (setf (classoid-pcl-class lclass) class)) - - (update-lisp-class-layout class layout) - - (cond (olclass - (aver (eq lclass olclass))) - (t - (setf (find-classoid name) lclass))) +(dohash ((name x) *find-class*) + (let* ((class (find-class-from-cell name x)) + (layout (class-wrapper class)) + (lclass (layout-classoid layout)) + (lclass-pcl-class (classoid-pcl-class lclass)) + (olclass (find-classoid name nil))) + (if lclass-pcl-class + (aver (eq class lclass-pcl-class)) + (setf (classoid-pcl-class lclass) class)) + + (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/defs.lisp b/src/pcl/defs.lisp index 068b49f..c781e64 100644 --- a/src/pcl/defs.lisp +++ b/src/pcl/defs.lisp @@ -233,7 +233,7 @@ (let ((subs (classoid-subclasses class))) (/noshow subs) (when subs - (dohash (sub v subs) + (dohash ((sub v) subs) (declare (ignore v)) (/noshow sub) (when (member class (direct-supers sub)) diff --git a/src/pcl/fixup.lisp b/src/pcl/fixup.lisp index e3d7f0a..6244ebb 100644 --- a/src/pcl/fixup.lisp +++ b/src/pcl/fixup.lisp @@ -27,7 +27,7 @@ (!fix-ensure-accessor-specializers) (compute-standard-slot-locations) (dolist (s '(condition structure-object)) - (dohash (k v (classoid-subclasses (find-classoid s))) + (dohash ((k v) (classoid-subclasses (find-classoid s))) (find-class (classoid-name k)))) (setq *boot-state* 'complete) diff --git a/version.lisp-expr b/version.lisp-expr index 7e3b86f..d295a3c 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.11.21" +"1.0.11.22" -- 1.7.10.4