* :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.)
;;;; -*- 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
"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"
(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))))
(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)))
(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))))
;;; 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)))
`(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
(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))
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)
"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)
"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)))
(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)
(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))
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
"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
;;; 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)))
;;; 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))))))
(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)))
;;; 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)))
(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))))
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))
(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)))))
\f
;;;; hash cache utility
;; 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))
;; the generational garbage collector needs to know it.
(defconstant +magic-hash-vector-value+ (ash 1 (1- sb!vm:n-word-bits)))
-\f
(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-")))
#',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))
`(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))))
\f
(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.~@
(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.
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
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)
: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)))
(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))
(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)
(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
;; 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)
(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))
(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))
(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
(!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)
(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))
(!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)
;;; 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"
projects / sbcl.git / commitdiff