[Openmcl-cvs-notifications] r10814 - in /trunk/source: level-0/l0-hash.lisp lib/hash.lisp lisp-kernel/gc-common.c lisp-kernel/x86-gc.c xdump/hashenv.lisp
gz at clozure.com
gz at clozure.com
Sat Sep 20 19:34:59 EDT 2008
Author: gz
Date: Sat Sep 20 19:34:59 2008
New Revision: 10814
Log:
Propagate r10813 to trunk
Modified:
trunk/source/level-0/l0-hash.lisp
trunk/source/lib/hash.lisp
trunk/source/lisp-kernel/gc-common.c
trunk/source/lisp-kernel/x86-gc.c
trunk/source/xdump/hashenv.lisp
Modified: trunk/source/level-0/l0-hash.lisp
=3D=3D=3D=3D=3D=3D=3D=3D=3D=3D=3D=3D=3D=3D=3D=3D=3D=3D=3D=3D=3D=3D=3D=3D=3D=
=3D=3D=3D=3D=3D=3D=3D=3D=3D=3D=3D=3D=3D=3D=3D=3D=3D=3D=3D=3D=3D=3D=3D=3D=3D=
=3D=3D=3D=3D=3D=3D=3D=3D=3D=3D=3D=3D=3D=3D=3D=3D=3D=3D=3D=3D=3D=3D=3D=3D=3D=
=3D=3D=3D
--- trunk/source/level-0/l0-hash.lisp (original)
+++ trunk/source/level-0/l0-hash.lisp Sat Sep 20 19:34:59 2008
@@ -281,6 +281,32 @@
(pathname (%%equalphash key))
(t (%%eqlhash key)))))))
=
+(defun update-hash-flags (hash vector addressp)
+ (when addressp
+ (flet ((new-flags (flags addressp)
+ (declare (fixnum flags))
+ (if (eq :key addressp)
+ ;; hash code depended on key's address
+ (if (logbitp $nhash_component_address_bit flags)
+ flags
+ (logior $nhash-track-keys-mask
+ (if (logbitp $nhash_track_keys_bit flags)
+ flags
+ (bitclr $nhash_key_moved_bit flags))))
+ ;; hash code depended on component address
+ (bitset $nhash_component_address_bit
+ (logand (lognot $nhash-track-keys-mask) flags)))))
+ (declare (inline new-flags))
+ (if (hash-lock-free-p hash)
+ (loop
+ (let* ((flags (nhash.vector.flags vector))
+ (new-flags (new-flags flags addressp)))
+ (when (or (eq flags new-flags)
+ (store-gvector-conditional nhash.vector.flags vector=
flags new-flags))
+ (return))))
+ (setf (nhash.vector.flags vector)
+ (new-flags (nhash.vector.flags vector) addressp))))))
+
(defun compute-hash-code (hash key update-hash-flags &optional
(vector (nhash.vector hash))) ; vectorp))
(let ((keytransF (nhash.keytransF hash))
@@ -301,30 +327,9 @@
(setq primary (%%eqlhash-internal key))
;; EQ hash table - or something eql doesn't do
(multiple-value-setq (primary addressp) (%%eqhash key))))
- (when addressp
- (when update-hash-flags
- (flet ((new-flags (flags addressp)
- (declare (fixnum flags))
- (if (eq :key addressp)
- ;; hash code depended on key's address
- (if (logbitp $nhash_component_address_bit flags)
- flags
- (logior $nhash-track-keys-mask
- (if (logbitp $nhash_track_keys_bit flags)
- flags
- (bitclr $nhash_key_moved_bit flags))))
- ;; hash code depended on component address
- (bitset $nhash_component_address_bit
- (logand (lognot $nhash-track-keys-mask) flags))=
)))
- (declare (inline new-flags))
- (if (hash-lock-free-p hash)
- (loop
- (let* ((flags (nhash.vector.flags vector))
- (new-flags (new-flags flags addressp)))
- (when (or (eq flags new-flags)
- (store-gvector-conditional nhash.vector.flags =
vector flags new-flags))
- (return))))
- (setf (nhash.vector.flags vector) (new-flags (nhash.vector.fla=
gs vector) addressp))))))
+ (when update-hash-flags
+ (when addressp
+ (update-hash-flags hash vector addressp)))
(let* ((entries (nhash.vector-size vector)))
(declare (fixnum entries))
(values primary
@@ -577,9 +582,9 @@
;; A modification of the lock-free hash table algorithm described by Cliff=
Click Jr. in
;; http://blogs.azulsystems.com/cliff/2007/03/a_nonblocking_h.html.
;;
-;; The modifications have to do with the fact that the goal of the current=
implementation
-;; is to have thread-safe hash tables with minimal performance penalty on =
reads, so I don't
-;; bother with aspects of his algorithm that aren't relevant to that goal.
+;; The modifications have to do with the fact that our goal is just to min=
imize the
+;; performance impact of thread-safety, by eliminating the need for lockin=
g on every
+;; read. I don't bother with aspects of his algorithm that aren't relevan=
t to that goal.
;;
;; The main difference from Click's algorithm is that I don't try to do re=
hashing
;; concurrently. Instead, rehashing grabs a lock, so that only one thread=
can be
@@ -591,21 +596,56 @@
;; of a hash table entry (where "object" means any object other than the s=
pecial markers):
;;
;; State Key Value
-;; DELETED object free-hash-marker
+;; DELETED1 object free-hash-marker
+;; DELETED2 deleted-marker free-hash-marker
;; IN-USE object object
;; FREE free-hash-marker free-hash-marker
;; REHASHING object rehashing-value-marker
;; REHASHING free-hash-marker rehashing-value-marker
+;; REHASHING deleted-marker rehashing-value-marker
;;
;; No other states are allowed - at no point in time can a hash table entr=
y be in any
-;; other state. In addition, the only transition allowed on the Key slot=
is
-;; free-hash-marker -> object. Once a key slot is so claimed, it must nev=
er change
-;; again (even after the hash vector has been discarded after rehashing, b=
ecause
-;; there can be some process still looking at it).
+;; other state. In addition, the only transitions allowed on the key slo=
t are
+;; free-hash-marker -> object/deleted-marker -> deleted-marker. Once a ke=
y slot
+;; is claimed, it must never change to free or another key value (even aft=
er the hash
+;; vector has been discarded after rehashing, because there some process m=
ight still
+;; be looking at it).
;; In particular, rehashing in place is not an option. All rehashing crea=
tes a new
;; vector and copies into it. This means it's kinda risky to use lock-fre=
e hash
;; tables with address-based keys, because they will thrash in low-memory =
situations,
;; but we don't disallow it because a particular use might not have this p=
roblem.
+;;
+;; The following operations may take place:
+;;
+;; * gethash: find matching key - if no match, return not found. Else fet=
ch value,
+;; if value is rehashing-value-marker then maybe-rehash and try again;
+;; if value is free-hash-marker, return not found, else return found val=
ue.
+;;
+;; * puthash: find matching key or FREE slot.
+;; ** If found key, fetch value.
+;; if value is rehashing-value-marker then maybe-rehash and try again;
+;; else store-conditional the value -> new value, if fails try again.
+;; ** Else have FREE slot, store-key-conditional free-hash-marker -> key,
+;; and if that succeeds, store-conditional free-hash-marker -> new va=
lue,
+;; if either fails, maybe-rehash and try again.
+;;
+;; * remhash: find matching key - if no match, done. Else fetch value,
+;; if value is rehashing-value-marker then maybe-rehash and try again;
+;; else store-conditional the value -> free-hash-marker, if fails try ag=
ain.
+;;
+;; * rehash: grab a lock, estimate number of entries, make a new vector. =
loop over
+;; old vector, at each entry fetch the old value with atomic swap of
+;; rehashing-value-marker. This prevents any further state changes involv=
ing the
+;; value. It doesn't prevent state changes involving the key, but the onl=
y ones that
+;; can happen is FREE -> DELETED, and DELETED1 <-> DELETED2, all of which =
are
+;; equivalent from the point of view of rehashing. Anyway, if the old val=
ue was
+;; rehashing-value-marker then bug (because we have a lock). If the old v=
alue is
+;; free-hash-marker then do nothing, else get the entry key and rehash int=
o the new
+;; vector -- if no more room, start over. When done, store the new vector=
in the
+;; hash table and release lock.
+;;
+;; * gc: for weak tables, gc may convert IN-USE states to DELETED2 states.
+;; Even for non-weak tables, gc could convert DELETED1 states to DELETED=
2.
=
=
(defun lock-free-rehash (hash)
@@ -713,6 +753,9 @@
(when (eq old-value free-hash-marker)
(return-from lock-free-remhash nil))
(when (set-hash-value-conditional vector-index vector=
old-value free-hash-marker)
+ ;; We just use this as a flag - tell gc to scan the=
vector for deleted keys.
+ ;; It's just a hint, so don't worry about sync'ing
+ (setf (nhash.vector.deleted-count vector) 1)
(return-from lock-free-remhash t)))))))
;; We're here because the table needs rehashing or it was getting re=
hashed while we
;; were searching. Take care of it and try again.
@@ -726,7 +769,10 @@
(loop
with vector =3D (nhash.vector hash)
for i1 fixnum from (%i+ $nhash.vector_overhead 1) below (uvsize v=
ector) by 2
- do (setf (%svref vector i1) free-hash-marker))
+ do (setf (%svref vector i1) free-hash-marker)
+ ;; We just use this as a flag - tell gc to scan the vector for de=
leted keys.
+ ;; It's just a hint, so don't worry about sync'ing
+ finally (setf (nhash.vector.deleted-count vector) 1))
(%unlock-recursive-lock-object lock))))
hash)
=
@@ -1097,7 +1143,7 @@
(%hash-probe hash key nil))
=
(defun general-hash-find-for-put (hash key)
- (%hash-probe hash key t))
+ (%hash-probe hash key (if (hash-lock-free-p hash) :free :reuse)))
=
;;; returns a single value:
;;; index - the index in the vector for key (where it was or where
@@ -1130,7 +1176,8 @@
vector-index)
-1)))
((eq table-key deleted-hash-key-marker)
- (when (null first-deleted-index)
+ (when (and (eq for-put-p :reuse)
+ (null first-deleted-index))
(setq first-deleted-index vector-index)=
))
((, at predicate key table-key)
(return-it vector-index))))))
@@ -1148,7 +1195,7 @@
(when (eql index initial-index)
(return-it (if for-put-p
(or first-deleted-index
- (error "Bug: no deleted=
entries in table"))
+ (error "Bug: no room in=
table"))
-1)))
(test-it ,predicate))))))
(if (fixnump comparef)
@@ -1217,16 +1264,12 @@
(%hash-symbol key)
(progn
(unless (immediate-p-macro key)
- (let* ((flags (nhash.vector.flags vector)))
- (declare (fixum flags))
- (unless (logbitp $nhash_track_keys_bit flags)
- (setq flags (bitclr $nhash_key_moved_bit flags)))
- (setf (nhash.vector.flags vector)
- (logior $nhash-track-keys-mask flags))))
+ (update-hash-flags hash vector :key))
(mixup-hash-code (strip-tag-to-fixnum key))))))))
(entries (nhash.vector-size vector))
(vector-index (index->vector-index (hash-mod hash-code entries ve=
ctor)))
- (table-key (%svref vector vector-index)))
+ (table-key (%svref vector vector-index))
+ (reuse (not (hash-lock-free-p hash))))
(declare (fixnum hash-code vector-index))
(if (or (eq key table-key)
(eq table-key free-hash-marker))
@@ -1234,8 +1277,9 @@
(let* ((secondary-hash (%svref secondary-keys-*-2
(logand 7 hash-code)))
(initial-index vector-index) =
- (first-deleted-index (if (eq table-key deleted-hash-key-marke=
r)
- vector-index))
+ (first-deleted-index (and reuse
+ (eq table-key deleted-hash-key-mark=
er)
+ vector-index))
(count (+ entries entries))
(length (+ count $nhash.vector_overhead)))
(declare (fixnum secondary-hash initial-index count length))
@@ -1246,12 +1290,13 @@
(setq table-key (%svref vector vector-index))
(when (=3D vector-index initial-index)
(return (or first-deleted-index
- (error "Bug: no deleted entries in table"))))
+ (error "Bug: no room in table"))))
(if (eq table-key key)
(return vector-index)
(if (eq table-key free-hash-marker)
(return (or first-deleted-index vector-index))
- (if (and (null first-deleted-index)
+ (if (and reuse
+ (null first-deleted-index)
(eq table-key deleted-hash-key-marker))
(setq first-deleted-index vector-index)))))))))
=
@@ -1294,7 +1339,8 @@
(hash-code (%%eqlhash-internal key))
(entries (nhash.vector-size vector))
(vector-index (index->vector-index (hash-mod hash-code entries =
vector)))
- (table-key (%svref vector vector-index)))
+ (table-key (%svref vector vector-index))
+ (reuse (not (hash-lock-free-p hash))))
(declare (fixnum hash-code entries vector-index))
(if (or (eql key table-key)
(eq table-key free-hash-marker))
@@ -1302,8 +1348,9 @@
(let* ((secondary-hash (%svref secondary-keys-*-2
(logand 7 hash-code)))
(initial-index vector-index)
- (first-deleted-index (if (eq table-key deleted-hash-key-mar=
ker)
- vector-index))
+ (first-deleted-index (and reuse
+ (eq table-key deleted-hash-key-ma=
rker)
+ vector-index))
(count (+ entries entries))
(length (+ count $nhash.vector_overhead)))
(declare (fixnum secondary-hash initial-index count length))
@@ -1314,12 +1361,13 @@
(setq table-key (%svref vector vector-index))
(when (=3D vector-index initial-index)
(return (or first-deleted-index
- (error "Bug: no deleted entries in table"))))
+ (error "Bug: no room in table"))))
(if (eql table-key key)
(return vector-index)
(if (eq table-key free-hash-marker)
(return (or first-deleted-index vector-index))
- (if (and (null first-deleted-index)
+ (if (and reuse
+ (null first-deleted-index)
(eq table-key deleted-hash-key-marker))
(setq first-deleted-index vector-index))))))))
(eq-hash-find-for-put hash key)))
@@ -1336,6 +1384,8 @@
;;; Rehash. Caller should have exclusive access to the hash table
;;; and have disabled interrupts.
(defun %rehash (hash)
+ (when (hash-lock-free-p hash)
+ (error "How did we get here?"))
(let* ((vector (nhash.vector hash))
(flags (nhash.vector.flags vector))
(vector-index (- $nhash.vector_overhead 2))
@@ -1832,6 +1882,8 @@
(return-from lock-free-enumerate-hash-keys-and-values
(lock-free-enumerate-hash-keys-and-values hash ke=
ys values)))
(unless (eq val free-hash-marker)
+ (when (eql key deleted-hash-key-marker)
+ (error "Bug: deleted key but not value?"))
(when keys (setf (%svref keys out-idx) key))
(when values (setf (%svref values out-idx) val))
(incf out-idx)))))))
Modified: trunk/source/lib/hash.lisp
=3D=3D=3D=3D=3D=3D=3D=3D=3D=3D=3D=3D=3D=3D=3D=3D=3D=3D=3D=3D=3D=3D=3D=3D=3D=
=3D=3D=3D=3D=3D=3D=3D=3D=3D=3D=3D=3D=3D=3D=3D=3D=3D=3D=3D=3D=3D=3D=3D=3D=3D=
=3D=3D=3D=3D=3D=3D=3D=3D=3D=3D=3D=3D=3D=3D=3D=3D=3D=3D=3D=3D=3D=3D=3D=3D=3D=
=3D=3D=3D
--- trunk/source/lib/hash.lisp (original)
+++ trunk/source/lib/hash.lisp Sat Sep 20 19:34:59 2008
@@ -106,9 +106,9 @@
;; gives the byte offset of the bit for LAP code. The two bytes in
;; question are at offsets $nhash.vector-weak-byte and
;; $nhash.vector-track-keys-byte offsets from the tagged vector.
-;; The 32 bits of the fixnum at nhash.vector.flags look like:
-;;
-;; TTTTKEC0 00000000 000WVFZ0 00000000
+;; The raw 32 bits of the fixnum at nhash.vector.flags look like:
+;;
+;; TKEC0000 00000000 WVFZ0000 00000000
;;
;;
;; $nhash_track_keys_bit "T" in the diagram above
Modified: trunk/source/lisp-kernel/gc-common.c
=3D=3D=3D=3D=3D=3D=3D=3D=3D=3D=3D=3D=3D=3D=3D=3D=3D=3D=3D=3D=3D=3D=3D=3D=3D=
=3D=3D=3D=3D=3D=3D=3D=3D=3D=3D=3D=3D=3D=3D=3D=3D=3D=3D=3D=3D=3D=3D=3D=3D=3D=
=3D=3D=3D=3D=3D=3D=3D=3D=3D=3D=3D=3D=3D=3D=3D=3D=3D=3D=3D=3D=3D=3D=3D=3D=3D=
=3D=3D=3D
--- trunk/source/lisp-kernel/gc-common.c (original)
+++ trunk/source/lisp-kernel/gc-common.c Sat Sep 20 19:34:59 2008
@@ -233,13 +233,13 @@
dnode =3D gc_area_dnode(weakelement);
if ((dnode < GCndnodes_in_area) && =
! ref_bit(markbits, dnode)) {
+ pairp[0] =3D slot_unbound;
if (keys_frozen) {
if (pairp[1] !=3D slot_unbound) {
pairp[1] =3D unbound;
}
}
else {
- pairp[0] =3D slot_unbound;
pairp[1] =3D lisp_nil;
}
hashp->weak_deletions_count +=3D (1<<fixnumshift);
Modified: trunk/source/lisp-kernel/x86-gc.c
=3D=3D=3D=3D=3D=3D=3D=3D=3D=3D=3D=3D=3D=3D=3D=3D=3D=3D=3D=3D=3D=3D=3D=3D=3D=
=3D=3D=3D=3D=3D=3D=3D=3D=3D=3D=3D=3D=3D=3D=3D=3D=3D=3D=3D=3D=3D=3D=3D=3D=3D=
=3D=3D=3D=3D=3D=3D=3D=3D=3D=3D=3D=3D=3D=3D=3D=3D=3D=3D=3D=3D=3D=3D=3D=3D=3D=
=3D=3D=3D
--- trunk/source/lisp-kernel/x86-gc.c (original)
+++ trunk/source/lisp-kernel/x86-gc.c Sat Sep 20 19:34:59 2008
@@ -385,6 +385,24 @@
invalidated on the lisp side, if/when we know
that rehashing is necessary. */
LispObj flags =3D ((hash_table_vector_header *) base)->flags;
+
+ if ((flags & nhash_keys_frozen_mask) &&
+ (((hash_table_vector_header *) base)->deleted_count > 0)) {
+ /* We're responsible for clearing out any deleted keys, since
+ lisp side can't do it without breaking the state machine
+ */
+ LispObj *pairp =3D base + hash_table_vector_header_count;
+ natural
+ npairs =3D (element_count - (hash_table_vector_header_count - =
1)) >> 1;
+
+ while (npairs--) {
+ if ((pairp[1] =3D=3D unbound) && (pairp[0] !=3D unbound)) {
+ pairp[0] =3D slot_unbound;
+ }
+ pairp +=3D2;
+ }
+ ((hash_table_vector_header *) base)->deleted_count =3D 0;
+ }
=
if (flags & nhash_weak_mask) {
((hash_table_vector_header *) base)->cache_key =3D undefined;
Modified: trunk/source/xdump/hashenv.lisp
=3D=3D=3D=3D=3D=3D=3D=3D=3D=3D=3D=3D=3D=3D=3D=3D=3D=3D=3D=3D=3D=3D=3D=3D=3D=
=3D=3D=3D=3D=3D=3D=3D=3D=3D=3D=3D=3D=3D=3D=3D=3D=3D=3D=3D=3D=3D=3D=3D=3D=3D=
=3D=3D=3D=3D=3D=3D=3D=3D=3D=3D=3D=3D=3D=3D=3D=3D=3D=3D=3D=3D=3D=3D=3D=3D=3D=
=3D=3D=3D
--- trunk/source/xdump/hashenv.lisp (original)
+++ trunk/source/xdump/hashenv.lisp Sat Sep 20 19:34:59 2008
@@ -37,7 +37,8 @@
nhash.vector.finalization-alist ; deleted out key/value pairs put =
here
nhash.vector.weak-deletions-count ; incremented when the GC deletes =
an element
nhash.vector.hash ; back-pointer
- nhash.vector.deleted-count ; number of deleted entries [not m=
aintained if lock-free]
+ nhash.vector.deleted-count ; if lock-free, hint to GC to dele=
te marked keys.
+ ; else number of deleted entries
nhash.vector.count ; number of valid entries [not mai=
ntained if lock-free]
nhash.vector.cache-idx ; index of last cached key/value p=
air
nhash.vector.cache-key ; cached key
More information about the Openmcl-cvs-notifications
mailing list