Menu
▾
▴
[Sbcl-commits] CVS: sbcl/src/code class.lisp, 1.80, 1.81 cross-misc.lisp, 1.27, 1.28 defstruct.lisp, 1.88, 1.89 describe.lisp, 1.45, 1.46 dyncount.lisp, 1.13, 1.14 early-extensions.lisp, 1.90, 1.91 hash-table.lisp, 1.16, 1.17 profile.lisp, 1.35, 1.36 target-hash-table.lisp, 1.42, 1.43
|
From: Nikodemus S. <de...@us...> - 2007-11-12 17:14:56
|
Update of /cvsroot/sbcl/sbcl/src/code In directory sc8-pr-cvs8.sourceforge.net:/tmp/cvs-serv20403/src/code Modified Files: class.lisp cross-misc.lisp defstruct.lisp describe.lisp dyncount.lisp early-extensions.lisp hash-table.lisp profile.lisp target-hash-table.lisp Log Message: 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.) Index: class.lisp =================================================================== RCS file: /cvsroot/sbcl/sbcl/src/code/class.lisp,v retrieving revision 1.80 retrieving revision 1.81 diff -u -d -r1.80 -r1.81 --- class.lisp 29 Aug 2007 17:14:45 -0000 1.80 +++ class.lisp 12 Nov 2007 17:14:50 -0000 1.81 @@ -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 @@ (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 @@ ;;; 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))) Index: cross-misc.lisp =================================================================== RCS file: /cvsroot/sbcl/sbcl/src/code/cross-misc.lisp,v retrieving revision 1.27 retrieving revision 1.28 diff -u -d -r1.27 -r1.28 --- cross-misc.lisp 28 Jun 2007 13:04:58 -0000 1.27 +++ cross-misc.lisp 12 Nov 2007 17:14:50 -0000 1.28 @@ -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 Index: defstruct.lisp =================================================================== RCS file: /cvsroot/sbcl/sbcl/src/code/defstruct.lisp,v retrieving revision 1.88 retrieving revision 1.89 diff -u -d -r1.88 -r1.89 --- defstruct.lisp 15 Jul 2007 22:28:13 -0000 1.88 +++ defstruct.lisp 12 Nov 2007 17:14:50 -0000 1.89 @@ -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)) Index: describe.lisp =================================================================== RCS file: /cvsroot/sbcl/sbcl/src/code/describe.lisp,v retrieving revision 1.45 retrieving revision 1.46 diff -u -d -r1.45 -r1.46 --- describe.lisp 13 Sep 2006 15:59:32 -0000 1.45 +++ describe.lisp 12 Nov 2007 17:14:50 -0000 1.46 @@ -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) Index: dyncount.lisp =================================================================== RCS file: /cvsroot/sbcl/sbcl/src/code/dyncount.lisp,v retrieving revision 1.13 retrieving revision 1.14 diff -u -d -r1.13 -r1.14 --- dyncount.lisp 14 Jul 2005 16:30:32 -0000 1.13 +++ dyncount.lisp 12 Nov 2007 17:14:51 -0000 1.14 @@ -37,9 +37,10 @@ "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 @@ "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 @@ (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 @@ (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 @@ 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 @@ "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 @@ ;;; 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 @@ ;;; 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 @@ (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 @@ ;;; 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 @@ (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 @@ 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)) Index: early-extensions.lisp =================================================================== RCS file: /cvsroot/sbcl/sbcl/src/code/early-extensions.lisp,v retrieving revision 1.90 retrieving revision 1.91 diff -u -d -r1.90 -r1.91 --- early-extensions.lisp 8 Nov 2007 21:08:40 -0000 1.90 +++ early-extensions.lisp 12 Nov 2007 17:14:51 -0000 1.91 @@ -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 Index: hash-table.lisp =================================================================== RCS file: /cvsroot/sbcl/sbcl/src/code/hash-table.lisp,v retrieving revision 1.16 retrieving revision 1.17 diff -u -d -r1.16 -r1.17 --- hash-table.lisp 6 Nov 2007 14:21:50 -0000 1.16 +++ hash-table.lisp 12 Nov 2007 17:14:51 -0000 1.17 @@ -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 @@ #',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)) Index: profile.lisp =================================================================== RCS file: /cvsroot/sbcl/sbcl/src/code/profile.lisp,v retrieving revision 1.35 retrieving revision 1.36 diff -u -d -r1.35 -r1.36 --- profile.lisp 10 Sep 2007 13:31:45 -0000 1.35 +++ profile.lisp 12 Nov 2007 17:14:51 -0000 1.36 @@ -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 @@ (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.~@ Index: target-hash-table.lisp =================================================================== RCS file: /cvsroot/sbcl/sbcl/src/code/target-hash-table.lisp,v retrieving revision 1.42 retrieving revision 1.43 diff -u -d -r1.42 -r1.43 --- target-hash-table.lisp 6 Nov 2007 14:21:51 -0000 1.42 +++ target-hash-table.lisp 12 Nov 2007 17:14:51 -0000 1.43 @@ -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 @@ (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 @@ (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 @@ (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 @@ ;; 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 @@ (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 @@ (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)) |