X-Git-Url: http://repo.macrolet.net/gitweb/?a=blobdiff_plain;f=src%2Fcode%2Ftarget-hash-table.lisp;h=a9bcc87a62e6b30f274f3a5fc6ae5958bc62fc5e;hb=4ec0d70e08ea4b512d45ddbd6c82e8f6a91a914f;hp=06f62d271cce7e67629a587584abcbbb1bd6686f;hpb=f318d0b1654042ed8f1b887852a9ba1f539208e4;p=sbcl.git diff --git a/src/code/target-hash-table.lisp b/src/code/target-hash-table.lisp index 06f62d2..a9bcc87 100644 --- a/src/code/target-hash-table.lisp +++ b/src/code/target-hash-table.lisp @@ -14,9 +14,6 @@ ;;;; utilities -(eval-when (:compile-toplevel :load-toplevel :execute) - (defconstant max-hash sb!xc:most-positive-fixnum)) - ;;; Code for detecting concurrent accesses to the same table from ;;; multiple threads. Only compiled in when the :SB-HASH-TABLE-DEBUG ;;; feature is enabled. The main reason for the existence of this code @@ -25,47 +22,54 @@ ;;; internal hash-table has been corrupted. It's plausible that this ;;; could be useful for some user code too, but the runtime cost is ;;; really too high to enable it by default. -(defmacro with-concurrent-access-check (hash-table &body body) - (declare (ignorable hash-table)) +(defmacro with-concurrent-access-check (hash-table operation &body body) + (declare (ignorable hash-table operation) + (type (member :read :write) operation)) #!-sb-hash-table-debug `(progn ,@body) #!+sb-hash-table-debug - (once-only ((hash-table hash-table)) - `(progn - (flet ((body-fun () - ,@body) - (error-fun () - ;; Don't signal more errors for this table. - (setf (hash-table-concurrent-access-error ,hash-table) nil) - (error "Concurrent access to ~A" ,hash-table))) - (if (hash-table-concurrent-access-error ,hash-table) - (let ((thread (hash-table-accessing-thread ,hash-table))) + (let ((thread-slot-accessor (if (eq operation :read) + 'hash-table-reading-thread + 'hash-table-writing-thread))) + (once-only ((hash-table hash-table)) + `(progn + (flet ((body-fun () + ,@body) + (error-fun () + ;; Don't signal more errors for this table. + (setf (hash-table-signal-concurrent-access ,hash-table) nil) + (cerror "Ignore the concurrent access" + "Concurrent access to ~A" ,hash-table))) + (declare (inline body-fun)) + (if (hash-table-signal-concurrent-access ,hash-table) (unwind-protect (progn - (when (and thread - (not (eql thread sb!thread::*current-thread*))) + (unless (and (null (hash-table-writing-thread + ,hash-table)) + ,@(when (eq operation :write) + `((null (hash-table-reading-thread + ,hash-table))))) (error-fun)) - (setf (hash-table-accessing-thread ,hash-table) + (setf (,thread-slot-accessor ,hash-table) sb!thread::*current-thread*) (body-fun)) - (unless (eql (hash-table-accessing-thread ,hash-table) - sb!thread::*current-thread*) + (unless (and ,@(when (eq operation :read) + `((null (hash-table-writing-thread + ,hash-table)))) + ,@(when (eq operation :write) + ;; no readers are allowed while writing + `((null (hash-table-reading-thread + ,hash-table)) + (eq (hash-table-writing-thread + ,hash-table) + sb!thread::*current-thread*)))) (error-fun)) - (setf (hash-table-accessing-thread ,hash-table) thread))) - (body-fun)))))) - -(deftype hash () - `(integer 0 ,max-hash)) - -;;; FIXME: Does this always make a nonnegative FIXNUM? If so, then -;;; explain why. If not (or if the reason it always makes a -;;; nonnegative FIXNUM is only the accident that pointers in supported -;;; architectures happen to be in the lower half of the address -;;; space), then fix it. -#!-sb-fluid (declaim (inline pointer-hash)) -(defun pointer-hash (key) - (declare (values hash)) - (truly-the hash (%primitive sb!c:make-fixnum key))) + (when (eq (,thread-slot-accessor ,hash-table) + sb!thread::*current-thread*) + ;; this is not 100% correct here and may hide + ;; concurrent access in rare circumstances. + (setf (,thread-slot-accessor ,hash-table) nil))) + (body-fun))))))) #!-sb-fluid (declaim (inline eq-hash)) (defun eq-hash (key) @@ -104,74 +108,175 @@ (t (eq-hash key)))) -(defun ceil-power-of-two (num) - (declare (type index num)) - (ash 1 (integer-length num))) - (declaim (inline index-for-hashing)) -(defun index-for-hashing (index length) - (declare (type index index length)) +(defun index-for-hashing (hash length) + (declare (type hash hash length)) ;; We're using power of two tables which obviously are very ;; sensitive to the exact values of the low bits in the hash ;; value. Do a little shuffling of the value to mix the high bits in ;; there too. - (logand (1- length) - (+ (logxor #b11100101010001011010100111 - index) - (ash index -6) - (ash index -15) - (ash index -23)))) + (truly-the index + (logand (1- length) + (+ (logxor #b11100101010001011010100111 + hash) + (ash hash -3) + (ash hash -12) + (ash hash -20))))) ;;;; user-defined hash table tests -(defvar *hash-table-tests* nil) +(defvar *user-hash-table-tests* nil) -(defun define-hash-table-test (name test-fun hash-fun) - #!+sb-doc - "Define a new kind of hash table test." - (declare (type symbol name) - (type function test-fun hash-fun)) - (setf *hash-table-tests* - (cons (list name test-fun hash-fun) - (remove name *hash-table-tests* :test #'eq :key #'car))) +(defun register-hash-table-test (name hash-fun) + (declare (symbol name) (function hash-fun)) + (unless (fboundp name) + (error "Cannot register ~S has a hash table test: undefined function." + name)) + (with-single-package-locked-error + (:symbol name "defining ~S as a hash table test") + (let* ((test-fun (fdefinition name)) + (this (list name test-fun hash-fun)) + (spec (assoc name *user-hash-table-tests*))) + (cond (spec + (unless (and (eq (second spec) test-fun) + (eq (third spec) hash-fun)) + (style-warn "Redefining hash table test ~S." name) + (setf (cdr spec) (cdr this)))) + (t + (push this *user-hash-table-tests*))))) name) + +(defmacro define-hash-table-test (name hash-function) + #!+sb-doc + "Defines NAME as a new kind of hash table test for use with the :TEST +argument to MAKE-HASH-TABLE, and associates a default HASH-FUNCTION with it. + +NAME must be a symbol naming a global two argument equivalence predicate. +Afterwards both 'NAME and #'NAME can be used with :TEST argument. In both +cases HASH-TABLE-TEST will return the symbol NAME. + +HASH-FUNCTION must be a symbol naming a global hash function consistent with +the predicate, or be a LAMBDA form implementing one in the current lexical +environment. The hash function must compute the same hash code for any two +objects for which NAME returns true, and subsequent calls with already hashed +objects must always return the same hash code. + +Note: The :HASH-FUNCTION keyword argument to MAKE-HASH-TABLE can be used to +override the specified default hash-function. + +Attempting to define NAME in a locked package as hash-table test causes a +package lock violation. + +Examples: + + ;;; 1. + + ;; We want to use objects of type FOO as keys (by their + ;; names.) EQUALP would work, but would make the names + ;; case-insensitive -- wich we don't want. + (defstruct foo (name nil :type (or null string))) + + ;; Define an equivalence test function and a hash function. + (defun foo-name= (f1 f2) (equal (foo-name f1) (foo-name f2))) + (defun sxhash-foo-name (f) (sxhash (foo-name f))) + + (define-hash-table-test foo-name= sxhash-foo-name) + + ;; #'foo-name would work too. + (defun make-foo-table () (make-hash-table :test 'foo-name=)) + + ;;; 2. + + (defun == (x y) (= x y)) + + (define-hash-table-test == + (lambda (x) + ;; Hash codes must be consistent with test, so + ;; not (SXHASH X), since + ;; (= 1 1.0) => T + ;; (= (SXHASH 1) (SXHASH 1.0)) => NIL + ;; Note: this doesn't deal with complex numbers or + ;; bignums too large to represent as double floats. + (sxhash (coerce x 'double-float)))) + + ;; #'== would work too + (defun make-number-table () (make-hash-table :test '==)) +" + (check-type name symbol) + (if (member name '(eq eql equal equalp)) + (error "Cannot redefine standard hash table test ~S." name) + (cond ((symbolp hash-function) + `(register-hash-table-test ',name (symbol-function ',hash-function))) + ((and (consp hash-function) (eq 'lambda (car hash-function))) + `(register-hash-table-test ',name #',hash-function)) + (t + (error "Malformed HASH-FUNCTION: ~S" hash-function))))) ;;;; construction and simple accessors (defconstant +min-hash-table-size+ 16) (defconstant +min-hash-table-rehash-threshold+ (float 1/16 1.0)) -(defun make-hash-table (&key (test 'eql) +(defun make-hash-table (&key + (test 'eql) (size +min-hash-table-size+) (rehash-size 1.5) (rehash-threshold 1) - (weakness nil)) + (hash-function 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. - :SIZE -- A hint as to how many elements will be put in this hash - table. - :REHASH-SIZE -- Indicates how to expand the table when it fills up. - If an integer, add space for that many elements. If a floating - point number (which must be greater than 1.0), multiply the size - by that amount. - :REHASH-THRESHOLD -- Indicates how dense the table can become before - 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. - 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 - key and the value may allow for removal of the entry. If WEAKNESS - is :KEY and the key would otherwise be garbage the entry is eligible - for removal from the hash table. Similarly, if WEAKNESS is :VALUE - the life of an entry depends on its value's references. If WEAKNESS - 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." + + :TEST + Determines how keys are compared. Must a designator for one of the + standard hash table tests, or a hash table test defined using + SB-EXT:DEFINE-HASH-TABLE-TEST. Additionally, when an explicit + HASH-FUNCTION is provided (see below), any two argument equivalence + predicate can be used as the TEST. + + :SIZE + A hint as to how many elements will be put in this hash table. + + :REHASH-SIZE + Indicates how to expand the table when it fills up. If an integer, add + space for that many elements. If a floating point number (which must be + greater than 1.0), multiply the size by that amount. + + :REHASH-THRESHOLD + Indicates how dense the table can become before 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. + + :HASH-FUNCTION + If NIL (the default), a hash function based on the TEST argument is used, + which then must be one of the standardized hash table test functions, or + one for which a default hash function has been defined using + SB-EXT:DEFINE-HASH-TABLE-TEST. If HASH-FUNCTION is specified, the TEST + argument can be any two argument predicate consistent with it. The + HASH-FUNCTION is expected to return a non-negative fixnum hash code. + + :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 key and + the value may allow for removal of the entry. If WEAKNESS is :KEY and the + key would otherwise be garbage the entry is eligible for removal from the + hash table. Similarly, if WEAKNESS is :VALUE the life of an entry depends + on its value's references. If WEAKNESS 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. + + :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) @@ -184,15 +289,42 @@ ((or (eq test #'equalp) (eq test 'equalp)) (values 'equalp #'equalp #'equalp-hash)) (t - ;; FIXME: I'd like to remove *HASH-TABLE-TESTS* stuff. - ;; Failing that, I'd like to rename it to - ;; *USER-HASH-TABLE-TESTS*. - (dolist (info *hash-table-tests* - (error "unknown :TEST for MAKE-HASH-TABLE: ~S" - test)) + ;; FIXME: It would be nice to have a compiler-macro + ;; that resolved this at compile time: we could grab + ;; the alist cell in a LOAD-TIME-VALUE, etc. + (dolist (info *user-hash-table-tests* + (if hash-function + (if (functionp test) + (values (%fun-name test) test nil) + (values test (%coerce-callable-to-fun test) nil)) + (error "Unknown :TEST for MAKE-HASH-TABLE: ~S" + test))) (destructuring-bind (test-name test-fun hash-fun) info (when (or (eq test test-name) (eq test test-fun)) (return (values test-name test-fun hash-fun))))))) + (when hash-function + (setf hash-fun + ;; Quickly check if the function has return return type which + ;; guarantees that the secondary return value is always NIL: + ;; (VALUES * &OPTIONAL), (VALUES * NULL ...) or (VALUES * + ;; &OPTIONAL NULL ...) + (let* ((actual (%coerce-callable-to-fun hash-function)) + (type-spec (%fun-type actual)) + (return-spec (when (consp type-spec) + (caddr type-spec))) + (extra-vals (when (consp return-spec) + (cddr return-spec)))) + (if (and (consp extra-vals) + (or (eq 'null (car extra-vals)) + (and (eq '&optional (car extra-vals)) + (or (not (cdr extra-vals)) + (eq 'null (cadr extra-vals)))))) + actual + ;; If there is a potential secondary value, make sure we + ;; don't accidentally claim EQ based hashing... + (lambda (object) + (declare (optimize (safety 0) (speed 3))) + (values (funcall actual object) nil)))))) (let* ((size (max +min-hash-table-size+ (min size ;; SIZE is just a hint, so if the user asks @@ -220,8 +352,8 @@ ;; Note that this has not yet been audited for ;; correctness. It just seems to work. -- CSR, 2002-11-02 (scaled-size (truncate (/ (float size+1) rehash-threshold))) - (length (ceil-power-of-two (max scaled-size - (1+ +min-hash-table-size+)))) + (length (power-of-two-ceiling (max scaled-size + (1+ +min-hash-table-size+)))) (index-vector (make-array length :element-type '(unsigned-byte #.sb!vm:n-word-bits) @@ -251,7 +383,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))) @@ -277,6 +409,10 @@ (setf (fdocumentation 'hash-table-rehash-threshold 'function) "Return the rehash-threshold HASH-TABLE was created with.") +#!+sb-doc +(setf (fdocumentation 'hash-table-synchronized-p 'function) + "Returns T if HASH-TABLE is synchronized.") + (defun hash-table-size (hash-table) #!+sb-doc "Return a size that can be used with MAKE-HASH-TABLE to create a hash @@ -312,12 +448,12 @@ multiple threads accessing the same hash-table without locking." (old-hash-vector (hash-table-hash-vector table)) (old-size (length old-next-vector)) (new-size - (ceil-power-of-two - (let ((rehash-size (hash-table-rehash-size table))) - (etypecase rehash-size - (fixnum - (+ rehash-size old-size)) - (float + (power-of-two-ceiling + (let ((rehash-size (hash-table-rehash-size table))) + (etypecase rehash-size + (fixnum + (+ rehash-size old-size)) + (float (the index (truncate (* rehash-size old-size)))))))) (new-kv-vector (make-array (* 2 new-size) :initial-element +empty-ht-slot+)) @@ -481,6 +617,7 @@ multiple threads accessing the same hash-table without locking." (zerop (hash-table-next-free-kv hash-table)))) (rehash-without-growing-p () (hash-table-needs-rehash-p hash-table))) + (declare (inline rehash-p rehash-without-growing-p)) (cond ((rehash-p) ;; Use recursive spinlocks since for weak tables the ;; spinlock has already been acquired. GC must be inhibited @@ -496,41 +633,41 @@ multiple threads accessing the same hash-table without locking." (sb!thread::with-recursive-system-spinlock ((hash-table-spinlock hash-table) :without-gcing t) (when (rehash-without-growing-p) - (without-gcing - (rehash-without-growing hash-table)))))))) + (rehash-without-growing hash-table))))))) (declaim (inline update-hash-table-cache)) (defun update-hash-table-cache (hash-table index) (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 (operation :write) 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))))) + (declare (type (member :read :write) operation)) + (with-unique-names (body-fun) + `(flet ((,body-fun () + (with-concurrent-access-check ,hash-table ,operation + (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)) @@ -553,7 +690,7 @@ multiple threads accessing the same hash-table without locking." ;; redo the lookup if the GC epoch counter has changed. ;; -- JES, 2007-09-30 `(if (and (not ,foundp) - (not (eql start-epoch sb!kernel::*gc-epoch*))) + (not (eq start-epoch sb!kernel::*gc-epoch*))) (go start) (return-from %gethash3 (values ,value ,foundp)))) (overflow () @@ -564,35 +701,35 @@ multiple threads accessing the same hash-table without locking." ;; Note that it's OK for a GC + a REHASH-WITHOUT-GROWING to ;; be triggered by another thread after this point, since the ;; GC epoch check will catch it. - (let ((cache (hash-table-cache hash-table)) - (table (hash-table-table hash-table))) + (let ((cache (hash-table-cache hash-table)) + (table (hash-table-table hash-table))) ;; First check the cache. Use EQ here for speed. (if (and cache (< cache (length table)) (eq (aref table cache) key)) (let ((value (aref table (1+ cache)))) (result value t)) - ;; Search for key in the hash table. - (multiple-value-bind (hashing eq-based) - (funcall (hash-table-hash-fun hash-table) key) - (declare (type hash hashing)) - (let* ((index-vector (hash-table-index-vector hash-table)) - (length (length index-vector)) + ;; Search for key in the hash table. + (multiple-value-bind (hashing eq-based) + (funcall (hash-table-hash-fun hash-table) key) + (declare (type hash hashing)) + (let* ((index-vector (hash-table-index-vector hash-table)) + (length (length index-vector)) (index (index-for-hashing hashing length)) - (next (aref index-vector index)) - (next-vector (hash-table-next-vector hash-table)) - (hash-vector (hash-table-hash-vector hash-table)) - (test-fun (hash-table-test-fun hash-table))) - (declare (type index index)) - ;; Search next-vector chain for a matching key. - (if (or eq-based (not hash-vector)) + (next (aref index-vector index)) + (next-vector (hash-table-next-vector hash-table)) + (hash-vector (hash-table-hash-vector hash-table)) + (test-fun (hash-table-test-fun hash-table))) + (declare (type index index)) + ;; Search next-vector chain for a matching key. + (if (or eq-based (not hash-vector)) (do ((next next (aref next-vector next)) (i 0 (1+ i))) ((zerop next) (result default nil)) (declare (type index/2 next i)) (when (> i length) (overflow)) - (when (eq key (aref table (* 2 next))) + (when (eq key (aref table (* 2 next))) (update-hash-table-cache hash-table (* 2 next)) (let ((value (aref table (1+ (* 2 next))))) (result value t)))) @@ -602,10 +739,10 @@ multiple threads accessing the same hash-table without locking." (declare (type index/2 next i)) (when (> i length) (overflow)) - (when (and (= hashing (aref hash-vector next)) + (when (and (= hashing (aref hash-vector next)) (funcall test-fun key (aref table (* 2 next)))) - ;; Found. + ;; Found. (update-hash-table-cache hash-table (* 2 next)) (let ((value (aref table (1+ (* 2 next))))) (result value t))))))))))))) @@ -613,7 +750,8 @@ 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 :operation :read :inline (%gethash3) + :pin (key)) (%gethash3 key hash-table default))) ;;; so people can call #'(SETF GETHASH) @@ -624,97 +762,106 @@ multiple threads accessing the same hash-table without locking." (declaim (maybe-inline %%puthash)) (defun %%puthash (key hash-table value) (declare (optimize speed)) - ;; We need to rehash here so that a current key can be found if it - ;; exists. Check that there is room for one more entry. May not be - ;; needed if the key is already present. + ;; We need to rehash here so that a current key can be found if it + ;; exists. Check that there is room for one more entry. May not be + ;; needed if the key is already present. (maybe-rehash hash-table t) - ;; Search for key in the hash table. - (multiple-value-bind (hashing eq-based) - (funcall (hash-table-hash-fun hash-table) key) - (declare (type hash hashing)) - (let* ((index-vector (hash-table-index-vector hash-table)) - (length (length index-vector)) + ;; Search for key in the hash table. + (multiple-value-bind (hashing eq-based) + (funcall (hash-table-hash-fun hash-table) key) + (declare (type hash hashing)) + (let* ((index-vector (hash-table-index-vector hash-table)) + (length (length index-vector)) (index (index-for-hashing hashing length)) - (next (aref index-vector index)) - (kv-vector (hash-table-table hash-table)) - (next-vector (hash-table-next-vector hash-table)) - (hash-vector (hash-table-hash-vector hash-table)) - (test-fun (hash-table-test-fun hash-table))) - (declare (type index index next)) - (when (hash-table-weakness hash-table) - (set-header-data kv-vector sb!vm:vector-valid-hashing-subtype)) - (cond ((or eq-based (not hash-vector)) - (when eq-based - (set-header-data kv-vector - sb!vm:vector-valid-hashing-subtype)) - ;; Search next-vector chain for a matching key. + (next (aref index-vector index)) + (kv-vector (hash-table-table hash-table)) + (next-vector (hash-table-next-vector hash-table)) + (hash-vector (hash-table-hash-vector hash-table)) + (test-fun (hash-table-test-fun hash-table))) + (declare (type index index next)) + (when (hash-table-weakness hash-table) + (set-header-data kv-vector sb!vm:vector-valid-hashing-subtype)) + (cond ((or eq-based (not hash-vector)) + (when eq-based + (set-header-data kv-vector + sb!vm:vector-valid-hashing-subtype)) + ;; Search next-vector chain for a matching key. (do ((next next (aref next-vector next)) (i 0 (1+ i))) - ((zerop next)) + ((zerop next)) (declare (type index/2 next i)) (when (> i length) (signal-corrupt-hash-table hash-table)) - (when (eq key (aref kv-vector (* 2 next))) - ;; Found, just replace the value. + (when (eq key (aref kv-vector (* 2 next))) + ;; Found, just replace the value. (update-hash-table-cache hash-table (* 2 next)) - (setf (aref kv-vector (1+ (* 2 next))) value) + (setf (aref kv-vector (1+ (* 2 next))) value) (return-from %%puthash value)))) - (t - ;; Search next-vector chain for a matching key. + (t + ;; Search next-vector chain for a matching key. (do ((next next (aref next-vector next)) (i 0 (1+ i))) - ((zerop next)) + ((zerop next)) (declare (type index/2 next i)) (when (> i length) (signal-corrupt-hash-table hash-table)) - (when (and (= hashing (aref hash-vector next)) - (funcall test-fun key - (aref kv-vector (* 2 next)))) - ;; Found, just replace the value. + (when (and (= hashing (aref hash-vector next)) + (funcall test-fun key + (aref kv-vector (* 2 next)))) + ;; Found, just replace the value. (update-hash-table-cache hash-table (* 2 next)) - (setf (aref kv-vector (1+ (* 2 next))) value) + (setf (aref kv-vector (1+ (* 2 next))) value) (return-from %%puthash value))))) - ;; Pop a KV slot off the free list - (let ((free-kv-slot (hash-table-next-free-kv hash-table))) - (declare (type index/2 free-kv-slot)) - ;; Double-check for overflow. - (aver (not (zerop free-kv-slot))) - (setf (hash-table-next-free-kv hash-table) - (aref next-vector free-kv-slot)) - (incf (hash-table-number-entries hash-table)) + ;; Pop a KV slot off the free list + (let ((free-kv-slot (hash-table-next-free-kv hash-table))) + (declare (type index/2 free-kv-slot)) + ;; Double-check for overflow. + (aver (not (zerop free-kv-slot))) + (setf (hash-table-next-free-kv hash-table) + (aref next-vector free-kv-slot)) + (incf (hash-table-number-entries hash-table)) (update-hash-table-cache hash-table (* 2 free-kv-slot)) - (setf (aref kv-vector (* 2 free-kv-slot)) key) - (setf (aref kv-vector (1+ (* 2 free-kv-slot))) value) - ;; Setup the hash-vector if necessary. - (when hash-vector - (if (not eq-based) - (setf (aref hash-vector free-kv-slot) hashing) - (aver (= (aref hash-vector free-kv-slot) - +magic-hash-vector-value+)))) - ;; Push this slot into the next chain. - (setf (aref next-vector free-kv-slot) next) + (setf (aref kv-vector (* 2 free-kv-slot)) key) + (setf (aref kv-vector (1+ (* 2 free-kv-slot))) value) + ;; Setup the hash-vector if necessary. + (when hash-vector + (if (not eq-based) + (setf (aref hash-vector free-kv-slot) hashing) + (aver (= (aref hash-vector free-kv-slot) + +magic-hash-vector-value+)))) + ;; Push this slot into the next chain. + (setf (aref next-vector free-kv-slot) next) (setf (aref index-vector index) free-kv-slot))) value)) (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)) - (kv-vector (hash-table-table hash-table))) - ;; Check the cache - (if (and cache - (< cache (length kv-vector)) - (eq (aref kv-vector cache) key)) - ;; 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))))) + (macrolet ((put-it (lockedp) + `(let ((cache (hash-table-cache hash-table)) + (kv-vector (hash-table-table hash-table))) + ;; Check the cache + (if (and cache + (< cache (length kv-vector)) + (eq (aref kv-vector cache) key)) + ;; If cached, just store here + (setf (aref kv-vector (1+ cache)) value) + ;; Otherwise do things the hard way + ,(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) - ;; We need to rehash here so that a current key can be found if it - ;; exists. + ;; We need to rehash here so that a current key can be found if it + ;; exists. ;; ;; Note that if a GC happens after MAYBE-REHASH returns and another ;; thread the accesses the table (triggering a rehash), we might not @@ -722,111 +869,114 @@ multiple threads accessing the same hash-table without locking." ;; only concurrent case that we safely allow is multiple readers ;; with no writers. (maybe-rehash hash-table nil) - ;; Search for key in the hash table. - (multiple-value-bind (hashing eq-based) - (funcall (hash-table-hash-fun hash-table) key) - (declare (type hash hashing)) - (let* ((index-vector (hash-table-index-vector hash-table)) - (length (length index-vector)) + ;; Search for key in the hash table. + (multiple-value-bind (hashing eq-based) + (funcall (hash-table-hash-fun hash-table) key) + (declare (type hash hashing)) + (let* ((index-vector (hash-table-index-vector hash-table)) + (length (length index-vector)) (index (index-for-hashing hashing length)) - (next (aref index-vector index)) - (table (hash-table-table hash-table)) - (next-vector (hash-table-next-vector hash-table)) - (hash-vector (hash-table-hash-vector hash-table)) - (test-fun (hash-table-test-fun hash-table))) - (declare (type index index) - (type index/2 next)) - (flet ((clear-slot (chain-vector prior-slot-location slot-location) - (declare (type index/2 slot-location)) - ;; Mark slot as empty. - (setf (aref table (* 2 slot-location)) +empty-ht-slot+ - (aref table (1+ (* 2 slot-location))) +empty-ht-slot+) - ;; Update the prior pointer in the chain to skip this. - (setf (aref chain-vector prior-slot-location) - (aref next-vector slot-location)) - ;; Push KV slot onto free chain. - (setf (aref next-vector slot-location) - (hash-table-next-free-kv hash-table)) - (setf (hash-table-next-free-kv hash-table) slot-location) - (when hash-vector - (setf (aref hash-vector slot-location) - +magic-hash-vector-value+)) - (decf (hash-table-number-entries hash-table)) - t)) - (cond ((zerop next) - nil) - ((if (or eq-based (not hash-vector)) - (eq key (aref table (* 2 next))) - (and (= hashing (aref hash-vector next)) - (funcall test-fun key (aref table (* 2 next))))) - (clear-slot index-vector index next)) - ;; Search next-vector chain for a matching key. - ((or eq-based (not hash-vector)) - ;; EQ based - (do ((prior next next) + (next (aref index-vector index)) + (table (hash-table-table hash-table)) + (next-vector (hash-table-next-vector hash-table)) + (hash-vector (hash-table-hash-vector hash-table)) + (test-fun (hash-table-test-fun hash-table))) + (declare (type index index) + (type index/2 next)) + (flet ((clear-slot (chain-vector prior-slot-location slot-location) + (declare (type index/2 slot-location)) + ;; Mark slot as empty. + (setf (aref table (* 2 slot-location)) +empty-ht-slot+ + (aref table (1+ (* 2 slot-location))) +empty-ht-slot+) + ;; Update the prior pointer in the chain to skip this. + (setf (aref chain-vector prior-slot-location) + (aref next-vector slot-location)) + ;; Push KV slot onto free chain. + (setf (aref next-vector slot-location) + (hash-table-next-free-kv hash-table)) + (setf (hash-table-next-free-kv hash-table) slot-location) + (when hash-vector + (setf (aref hash-vector slot-location) + +magic-hash-vector-value+)) + ;; On parallel accesses this may turn out to be a + ;; type-error, so don't turn down the safety! + (decf (hash-table-number-entries hash-table)) + t)) + (cond ((zerop next) + nil) + ((if (or eq-based (not hash-vector)) + (eq key (aref table (* 2 next))) + (and (= hashing (aref hash-vector next)) + (funcall test-fun key (aref table (* 2 next))))) + (clear-slot index-vector index next)) + ;; Search next-vector chain for a matching key. + ((or eq-based (not hash-vector)) + ;; EQ based + (do ((prior next next) (i 0 (1+ i)) - (next (aref next-vector next) (aref next-vector next))) - ((zerop next) nil) - (declare (type index next)) + (next (aref next-vector next) (aref next-vector next))) + ((zerop next) nil) + (declare (type index next)) (when (> i length) (signal-corrupt-hash-table hash-table)) - (when (eq key (aref table (* 2 next))) + (when (eq key (aref table (* 2 next))) (return-from %remhash (clear-slot next-vector prior next))))) - (t - ;; not EQ based - (do ((prior next next) + (t + ;; not EQ based + (do ((prior next next) (i 0 (1+ i)) - (next (aref next-vector next) (aref next-vector next))) - ((zerop next) nil) - (declare (type index/2 next)) + (next (aref next-vector next) (aref next-vector next))) + ((zerop next) nil) + (declare (type index/2 next)) (when (> i length) (signal-corrupt-hash-table hash-table)) - (when (and (= hashing (aref hash-vector next)) - (funcall test-fun key (aref table (* 2 next)))) + (when (and (= hashing (aref hash-vector next)) + (funcall test-fun key (aref table (* 2 next)))) (return-from %remhash (clear-slot next-vector prior next)))))))))) (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))) - ;; For now, just clear the cache - (setf (hash-table-cache hash-table) nil) - (with-hash-table-locks (hash-table (%remhash) key) + (with-hash-table-locks (hash-table :inline (%remhash) :pin (key)) + ;; For now, just clear the cache + (setf (hash-table-cache hash-table) nil) (%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) - (let* ((kv-vector (hash-table-table hash-table)) - (next-vector (hash-table-next-vector hash-table)) - (hash-vector (hash-table-hash-vector hash-table)) - (size (length next-vector)) - (index-vector (hash-table-index-vector hash-table))) - ;; Disable GC tricks. - (set-header-data kv-vector sb!vm:vector-normal-subtype) - ;; Mark all slots as empty by setting all keys and values to magic - ;; tag. - (aver (eq (aref kv-vector 0) hash-table)) - (fill kv-vector +empty-ht-slot+ :start 2) - ;; Set up the free list, all free. - (do ((i 1 (1+ i))) - ((>= i (1- size))) - (setf (aref next-vector i) (1+ i))) - (setf (aref next-vector (1- size)) 0) - (setf (hash-table-next-free-kv hash-table) 1) - ;; Clear the index-vector. - (fill index-vector 0) - ;; Clear the hash-vector. - (when hash-vector - (fill hash-vector +magic-hash-vector-value+))) - (setf (hash-table-cache hash-table) nil) - (setf (hash-table-number-entries hash-table) 0) - hash-table)) + "This removes all the entries from HASH-TABLE and returns the hash +table itself." + (when (plusp (hash-table-number-entries hash-table)) + (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)) + (size (length next-vector)) + (index-vector (hash-table-index-vector hash-table))) + ;; Disable GC tricks. + (set-header-data kv-vector sb!vm:vector-normal-subtype) + ;; Mark all slots as empty by setting all keys and values to magic + ;; tag. + (aver (eq (aref kv-vector 0) hash-table)) + (fill kv-vector +empty-ht-slot+ :start 2) + ;; Set up the free list, all free. + (do ((i 1 (1+ i))) + ((>= i (1- size))) + (setf (aref next-vector i) (1+ i))) + (setf (aref next-vector (1- size)) 0) + (setf (hash-table-next-free-kv hash-table) 1) + ;; Clear the index-vector. + (fill index-vector 0) + ;; Clear the hash-vector. + (when hash-vector + (fill hash-vector +magic-hash-vector-value+))) + (setf (hash-table-cache hash-table) nil) + (setf (hash-table-number-entries hash-table) 0))) + hash-table) ;;;; MAPHASH @@ -841,7 +991,14 @@ multiple threads accessing the same hash-table without locking." (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." +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. 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)) @@ -894,16 +1051,16 @@ the key and value of the entry. Return NIL." (cond ((or (not *print-readably*) (not *read-eval*)) (print-unreadable-object (hash-table stream :type t :identity t) (format stream - ":TEST ~S :COUNT ~S" + ":TEST ~S :COUNT ~S~@[ :WEAKNESS ~S~]" (hash-table-test hash-table) - (hash-table-count hash-table)))) + (hash-table-count hash-table) + (hash-table-weakness hash-table)))) (t - (with-standard-io-syntax - (format stream - "#.~W" - `(%stuff-hash-table (make-hash-table ,@(%hash-table-ctor-args + (write-string "#." stream) + (write `(%stuff-hash-table (make-hash-table ,@(%hash-table-ctor-args hash-table)) - ',(%hash-table-alist hash-table))))))) + ',(%hash-table-alist hash-table)) + :stream stream)))) (def!method make-load-form ((hash-table hash-table) &optional environment) (declare (ignore environment))