1 ;;;; that part of the implementation of HASH-TABLE which lives solely
2 ;;;; on the target system, not on the cross-compilation host
4 ;;;; This software is part of the SBCL system. See the README file for
7 ;;;; This software is derived from the CMU CL system, which was
8 ;;;; written at Carnegie Mellon University and released into the
9 ;;;; public domain. The software is in the public domain and is
10 ;;;; provided with absolutely no warranty. See the COPYING and CREDITS
11 ;;;; files for more information.
13 (in-package "SB!IMPL")
17 (eval-when (:compile-toplevel :load-toplevel :execute)
18 (defconstant max-hash sb!xc:most-positive-fixnum))
20 ;;; Code for detecting concurrent accesses to the same table from
21 ;;; multiple threads. Only compiled in when the :SB-HASH-TABLE-DEBUG
22 ;;; feature is enabled. The main reason for the existence of this code
23 ;;; is to detect thread-unsafe uses of hash-tables in sbcl itself,
24 ;;; where debugging anythign can be impossible after an important
25 ;;; internal hash-table has been corrupted. It's plausible that this
26 ;;; could be useful for some user code too, but the runtime cost is
27 ;;; really too high to enable it by default.
28 (defmacro with-concurrent-access-check (hash-table &body body)
29 (declare (ignorable hash-table))
30 #!-sb-hash-table-debug
32 #!+sb-hash-table-debug
33 (once-only ((hash-table hash-table))
38 ;; Don't signal more errors for this table.
39 (setf (hash-table-concurrent-access-error ,hash-table) nil)
40 (error "Concurrent access to ~A" ,hash-table)))
41 (if (hash-table-concurrent-access-error ,hash-table)
42 (let ((thread (hash-table-accessing-thread ,hash-table)))
46 (not (eql thread sb!thread::*current-thread*)))
48 (setf (hash-table-accessing-thread ,hash-table)
49 sb!thread::*current-thread*)
51 (unless (eql (hash-table-accessing-thread ,hash-table)
52 sb!thread::*current-thread*)
54 (setf (hash-table-accessing-thread ,hash-table) thread)))
58 `(integer 0 ,max-hash))
60 ;;; FIXME: Does this always make a nonnegative FIXNUM? If so, then
61 ;;; explain why. If not (or if the reason it always makes a
62 ;;; nonnegative FIXNUM is only the accident that pointers in supported
63 ;;; architectures happen to be in the lower half of the address
64 ;;; space), then fix it.
65 #!-sb-fluid (declaim (inline pointer-hash))
66 (defun pointer-hash (key)
67 (declare (values hash))
68 (truly-the hash (%primitive sb!c:make-fixnum key)))
70 #!-sb-fluid (declaim (inline eq-hash))
72 (declare (values hash (member t nil)))
73 (values (pointer-hash key)
74 (oddp (get-lisp-obj-address key))))
76 #!-sb-fluid (declaim (inline equal-hash))
77 (defun equal-hash (key)
78 (declare (values hash (member t nil)))
80 ;; For some types the definition of EQUAL implies a special hash
81 ((or string cons number bit-vector pathname)
82 (values (sxhash key) nil))
83 ;; Otherwise use an EQ hash, rather than SXHASH, since the values
84 ;; of SXHASH will be extremely badly distributed due to the
85 ;; requirements of the spec fitting badly with our implementation
90 #!-sb-fluid (declaim (inline eql-hash))
92 (declare (values hash (member t nil)))
97 (defun equalp-hash (key)
98 (declare (values hash (member t nil)))
100 ;; Types requiring special treatment. Note that PATHNAME and
101 ;; HASH-TABLE are caught by the STRUCTURE-OBJECT test.
102 ((or array cons number character structure-object)
103 (values (psxhash key) nil))
107 (defun ceil-power-of-two (num)
108 (declare (type index num))
109 (ash 1 (integer-length num)))
111 (declaim (inline index-for-hashing))
112 (defun index-for-hashing (index length)
113 (declare (type index index length))
114 ;; We're using power of two tables which obviously are very
115 ;; sensitive to the exact values of the low bits in the hash
116 ;; value. Do a little shuffling of the value to mix the high bits in
119 (+ (logxor #b11100101010001011010100111
126 ;;;; user-defined hash table tests
128 (defvar *hash-table-tests* nil)
130 (defun define-hash-table-test (name test-fun hash-fun)
132 "Define a new kind of hash table test."
133 (declare (type symbol name)
134 (type function test-fun hash-fun))
135 (setf *hash-table-tests*
136 (cons (list name test-fun hash-fun)
137 (remove name *hash-table-tests* :test #'eq :key #'car)))
140 ;;;; construction and simple accessors
142 (defconstant +min-hash-table-size+ 16)
143 (defconstant +min-hash-table-rehash-threshold+ (float 1/16 1.0))
145 (defun make-hash-table (&key (test 'eql)
146 (size +min-hash-table-size+)
151 "Create and return a new hash table. The keywords are as follows:
152 :TEST -- Indicates what kind of test to use.
153 :SIZE -- A hint as to how many elements will be put in this hash
155 :REHASH-SIZE -- Indicates how to expand the table when it fills up.
156 If an integer, add space for that many elements. If a floating
157 point number (which must be greater than 1.0), multiply the size
159 :REHASH-THRESHOLD -- Indicates how dense the table can become before
160 forcing a rehash. Can be any positive number <=1, with density
161 approaching zero as the threshold approaches 0. Density 1 means an
162 average of one entry per bucket.
163 :WEAKNESS -- IF NIL (the default) it is a normal non-weak hash table.
164 If one of :KEY, :VALUE, :KEY-AND-VALUE, :KEY-OR-VALUE it is a weak
166 Depending on the type of weakness the lack of references to the
167 key and the value may allow for removal of the entry. If WEAKNESS
168 is :KEY and the key would otherwise be garbage the entry is eligible
169 for removal from the hash table. Similarly, if WEAKNESS is :VALUE
170 the life of an entry depends on its value's references. If WEAKNESS
171 is :KEY-AND-VALUE and either the key or the value would otherwise be
172 garbage the entry can be removed. If WEAKNESS is :KEY-OR-VALUE and
173 both the key and the value would otherwise be garbage the entry can
175 (declare (type (or function symbol) test))
176 (declare (type unsigned-byte size))
177 (multiple-value-bind (test test-fun hash-fun)
178 (cond ((or (eq test #'eq) (eq test 'eq))
179 (values 'eq #'eq #'eq-hash))
180 ((or (eq test #'eql) (eq test 'eql))
181 (values 'eql #'eql #'eql-hash))
182 ((or (eq test #'equal) (eq test 'equal))
183 (values 'equal #'equal #'equal-hash))
184 ((or (eq test #'equalp) (eq test 'equalp))
185 (values 'equalp #'equalp #'equalp-hash))
187 ;; FIXME: I'd like to remove *HASH-TABLE-TESTS* stuff.
188 ;; Failing that, I'd like to rename it to
189 ;; *USER-HASH-TABLE-TESTS*.
190 (dolist (info *hash-table-tests*
191 (error "unknown :TEST for MAKE-HASH-TABLE: ~S"
193 (destructuring-bind (test-name test-fun hash-fun) info
194 (when (or (eq test test-name) (eq test test-fun))
195 (return (values test-name test-fun hash-fun)))))))
196 (let* ((size (max +min-hash-table-size+
198 ;; SIZE is just a hint, so if the user asks
199 ;; for a SIZE which'd be too big for us to
200 ;; easily implement, we bump it down.
201 (floor array-dimension-limit 1024))))
202 (rehash-size (if (integerp rehash-size)
204 (float rehash-size 1.0)))
205 ;; FIXME: Original REHASH-THRESHOLD default should be 1.0,
206 ;; not 1, to make it easier for the compiler to avoid
208 (rehash-threshold (max +min-hash-table-rehash-threshold+
209 (float rehash-threshold 1.0)))
210 (size+1 (1+ size)) ; The first element is not usable.
211 ;; KLUDGE: The most natural way of expressing the below is
212 ;; (round (/ (float size+1) rehash-threshold)), and indeed
213 ;; it was expressed like that until 0.7.0. However,
214 ;; MAKE-HASH-TABLE is called very early in cold-init, and
215 ;; the SPARC has no primitive instructions for rounding,
216 ;; but only for truncating; therefore, we fudge this issue
217 ;; a little. The other uses of truncate, below, similarly
218 ;; used to be round. -- CSR, 2002-10-01
220 ;; Note that this has not yet been audited for
221 ;; correctness. It just seems to work. -- CSR, 2002-11-02
222 (scaled-size (truncate (/ (float size+1) rehash-threshold)))
223 (length (ceil-power-of-two (max scaled-size
224 (1+ +min-hash-table-size+))))
225 (index-vector (make-array length
227 '(unsigned-byte #.sb!vm:n-word-bits)
229 ;; Needs to be the half the length of the KV vector to link
230 ;; KV entries - mapped to indeces at 2i and 2i+1 -
232 (next-vector (make-array size+1
234 '(unsigned-byte #.sb!vm:n-word-bits)))
235 (kv-vector (make-array (* 2 size+1)
236 :initial-element +empty-ht-slot+))
237 (table (%make-hash-table
241 :rehash-size rehash-size
242 :rehash-threshold rehash-threshold
246 :index-vector index-vector
247 :next-vector next-vector
249 (unless (eq test 'eq)
251 :element-type '(unsigned-byte
253 :initial-element +magic-hash-vector-value+))
254 :spinlock (sb!thread::make-spinlock))))
255 (declare (type index size+1 scaled-size length))
256 ;; Set up the free list, all free. These lists are 0 terminated.
259 (setf (aref next-vector i) (1+ i)))
260 (setf (aref next-vector size) 0)
261 (setf (hash-table-next-free-kv table) 1)
262 (setf (aref kv-vector 0) table)
265 (defun hash-table-count (hash-table)
267 "Return the number of entries in the given HASH-TABLE."
268 (declare (type hash-table hash-table)
270 (hash-table-number-entries hash-table))
273 (setf (fdocumentation 'hash-table-rehash-size 'function)
274 "Return the rehash-size HASH-TABLE was created with.")
277 (setf (fdocumentation 'hash-table-rehash-threshold 'function)
278 "Return the rehash-threshold HASH-TABLE was created with.")
280 (defun hash-table-size (hash-table)
282 "Return a size that can be used with MAKE-HASH-TABLE to create a hash
283 table that can hold however many entries HASH-TABLE can hold without
285 (hash-table-rehash-trigger hash-table))
288 (setf (fdocumentation 'hash-table-test 'function)
289 "Return the test HASH-TABLE was created with.")
292 (setf (fdocumentation 'hash-table-weakness 'function)
293 "Return the WEAKNESS of HASH-TABLE which is one of NIL, :KEY,
294 :VALUE, :KEY-AND-VALUE, :KEY-OR-VALUE.")
296 ;;; Called when we detect circular chains in a hash-table.
297 (defun signal-corrupt-hash-table (hash-table)
298 (error "Corrupt NEXT-chain in ~A. This is probably caused by ~
299 multiple threads accessing the same hash-table without locking."
303 ;;;; accessing functions
305 ;;; Make new vectors for the table, extending the table based on the
307 (defun rehash (table)
308 (declare (type hash-table table))
310 (let* ((old-kv-vector (hash-table-table table))
311 (old-next-vector (hash-table-next-vector table))
312 (old-hash-vector (hash-table-hash-vector table))
313 (old-size (length old-next-vector))
316 (let ((rehash-size (hash-table-rehash-size table)))
317 (etypecase rehash-size
319 (+ rehash-size old-size))
321 (the index (truncate (* rehash-size old-size))))))))
322 (new-kv-vector (make-array (* 2 new-size)
323 :initial-element +empty-ht-slot+))
326 :element-type '(unsigned-byte #.sb!vm:n-word-bits)
329 (when old-hash-vector
331 :element-type '(unsigned-byte #.sb!vm:n-word-bits)
332 :initial-element +magic-hash-vector-value+)))
333 (new-length new-size)
335 (make-array new-length
336 :element-type '(unsigned-byte #.sb!vm:n-word-bits)
337 :initial-element 0)))
338 (declare (type index new-size new-length old-size))
340 ;; Disable GC tricks on the OLD-KV-VECTOR.
341 (set-header-data old-kv-vector sb!vm:vector-normal-subtype)
343 ;; Non-empty weak hash tables always need GC support.
344 (when (and (hash-table-weakness table) (plusp (hash-table-count table)))
345 (set-header-data new-kv-vector sb!vm:vector-valid-hashing-subtype))
347 ;; FIXME: here and in several other places in the hash table code,
348 ;; loops like this one are used when FILL or REPLACE would be
349 ;; appropriate. why are standard CL functions not used?
350 ;; Performance issues? General laziness? -- NJF, 2004-03-10
352 ;; Copy over the kv-vector. The element positions should not move
353 ;; in case there are active scans.
354 (dotimes (i (* old-size 2))
355 (declare (type index i))
356 (setf (aref new-kv-vector i) (aref old-kv-vector i)))
358 ;; Copy over the hash-vector.
359 (when old-hash-vector
360 (dotimes (i old-size)
361 (setf (aref new-hash-vector i) (aref old-hash-vector i))))
363 (setf (hash-table-next-free-kv table) 0)
364 ;; Rehash all the entries; last to first so that after the pushes
365 ;; the chains are first to last.
366 (do ((i (1- new-size) (1- i)))
368 (declare (type index/2 i))
369 (let ((key (aref new-kv-vector (* 2 i)))
370 (value (aref new-kv-vector (1+ (* 2 i)))))
371 (cond ((and (eq key +empty-ht-slot+)
372 (eq value +empty-ht-slot+))
373 ;; Slot is empty, push it onto the free list.
374 (setf (aref new-next-vector i)
375 (hash-table-next-free-kv table))
376 (setf (hash-table-next-free-kv table) i))
377 ((and new-hash-vector
378 (not (= (aref new-hash-vector i)
379 +magic-hash-vector-value+)))
380 ;; Can use the existing hash value (not EQ based)
381 (let* ((hashing (aref new-hash-vector i))
382 (index (index-for-hashing hashing new-length))
383 (next (aref new-index-vector index)))
384 (declare (type index index)
386 ;; Push this slot into the next chain.
387 (setf (aref new-next-vector i) next)
388 (setf (aref new-index-vector index) i)))
392 (set-header-data new-kv-vector
393 sb!vm:vector-valid-hashing-subtype)
394 (let* ((hashing (pointer-hash key))
395 (index (index-for-hashing hashing new-length))
396 (next (aref new-index-vector index)))
397 (declare (type index index)
399 ;; Push this slot onto the next chain.
400 (setf (aref new-next-vector i) next)
401 (setf (aref new-index-vector index) i))))))
402 (setf (hash-table-table table) new-kv-vector)
403 (setf (hash-table-index-vector table) new-index-vector)
404 (setf (hash-table-next-vector table) new-next-vector)
405 (setf (hash-table-hash-vector table) new-hash-vector)
406 ;; Fill the old kv-vector with 0 to help the conservative GC. Even
407 ;; if nothing else were zeroed, it's important to clear the
408 ;; special first cells in old-kv-vector.
409 (fill old-kv-vector 0)
410 (setf (hash-table-rehash-trigger table) new-size)
411 (setf (hash-table-needs-rehash-p table) nil))
414 ;;; Use the same size as before, re-using the vectors.
415 (defun rehash-without-growing (table)
416 (declare (type hash-table table))
418 (let* ((kv-vector (hash-table-table table))
419 (next-vector (hash-table-next-vector table))
420 (hash-vector (hash-table-hash-vector table))
421 (size (length next-vector))
422 (index-vector (hash-table-index-vector table))
423 (length (length index-vector)))
424 (declare (type index size length))
426 ;; Non-empty weak hash tables always need GC support.
427 (unless (and (hash-table-weakness table) (plusp (hash-table-count table)))
428 ;; Disable GC tricks, they will be re-enabled during the re-hash
430 (set-header-data kv-vector sb!vm:vector-normal-subtype))
432 ;; Rehash all the entries.
433 (setf (hash-table-next-free-kv table) 0)
435 (setf (aref next-vector i) 0))
437 (setf (aref index-vector i) 0))
438 (do ((i (1- size) (1- i)))
440 (declare (type index/2 i))
441 (let ((key (aref kv-vector (* 2 i)))
442 (value (aref kv-vector (1+ (* 2 i)))))
443 (cond ((and (eq key +empty-ht-slot+)
444 (eq value +empty-ht-slot+))
445 ;; Slot is empty, push it onto free list.
446 (setf (aref next-vector i) (hash-table-next-free-kv table))
447 (setf (hash-table-next-free-kv table) i))
448 ((and hash-vector (not (= (aref hash-vector i)
449 +magic-hash-vector-value+)))
450 ;; Can use the existing hash value (not EQ based)
451 (let* ((hashing (aref hash-vector i))
452 (index (index-for-hashing hashing length))
453 (next (aref index-vector index)))
454 (declare (type index index))
455 ;; Push this slot into the next chain.
456 (setf (aref next-vector i) next)
457 (setf (aref index-vector index) i)))
461 (set-header-data kv-vector sb!vm:vector-valid-hashing-subtype)
462 (let* ((hashing (pointer-hash key))
463 (index (index-for-hashing hashing length))
464 (next (aref index-vector index)))
465 (declare (type index index)
467 ;; Push this slot into the next chain.
468 (setf (aref next-vector i) next)
469 (setf (aref index-vector index) i)))))))
470 ;; Clear the rehash bit only at the very end, otherwise another thread
471 ;; might see a partially rehashed table as a normal one.
472 (setf (hash-table-needs-rehash-p table) nil)
475 (declaim (inline maybe-rehash))
476 (defun maybe-rehash (hash-table ensure-free-slot-p)
477 (when (hash-table-weakness hash-table)
480 (and ensure-free-slot-p
481 (zerop (hash-table-next-free-kv hash-table))))
482 (rehash-without-growing-p ()
483 (hash-table-needs-rehash-p hash-table)))
484 (declare (inline rehash-p rehash-without-growing-p))
486 ;; Use recursive spinlocks since for weak tables the
487 ;; spinlock has already been acquired. GC must be inhibited
488 ;; to prevent the GC from seeing a rehash in progress.
489 (sb!thread::with-recursive-system-spinlock
490 ((hash-table-spinlock hash-table) :without-gcing t)
491 ;; Repeat the condition inside the lock to ensure that if
492 ;; two reader threads enter MAYBE-REHASH at the same time
493 ;; only one rehash is performed.
495 (rehash hash-table))))
496 ((rehash-without-growing-p)
497 (sb!thread::with-recursive-system-spinlock
498 ((hash-table-spinlock hash-table) :without-gcing t)
499 (when (rehash-without-growing-p)
501 (rehash-without-growing hash-table))))))))
503 (declaim (inline update-hash-table-cache))
504 (defun update-hash-table-cache (hash-table index)
505 (unless (hash-table-weakness hash-table)
506 (setf (hash-table-cache hash-table) index)))
508 (defmacro with-hash-table-locks ((hash-table inline &rest pin-objects)
510 `(with-concurrent-access-check ,hash-table
511 ;; Inhibit GC for the duration of BODY if the GC might mutate the
512 ;; HASH-TABLE in some way (currently true only if the table is
513 ;; weak). We also need to lock the table to ensure that two
514 ;; concurrent writers can't create a cyclical vector that would
515 ;; cause scav_weak_hash_table_chain to loop.
517 ;; Otherwise we can avoid the 2x-3x overhead, and just pin the key.
518 (if (hash-table-weakness ,hash-table)
519 (sb!thread::with-recursive-system-spinlock
520 ((hash-table-spinlock hash-table) :without-gcing t)
522 (with-pinned-objects ,pin-objects
524 ;; Inline the implementation function on the fast path
525 ;; only. (On the slow path it'll just bloat the
526 ;; generated code with no benefit).
527 (declare (inline ,@inline))
530 (defun gethash (key hash-table &optional default)
532 "Finds the entry in HASH-TABLE whose key is KEY and returns the associated
533 value and T as multiple values, or returns DEFAULT and NIL if there is no
534 such entry. Entries can be added using SETF."
535 (declare (type hash-table hash-table)
536 (values t (member t nil)))
537 (gethash3 key hash-table default))
539 (declaim (maybe-inline %gethash3))
540 (defun %gethash3 (key hash-table default)
541 (declare (type hash-table hash-table)
543 (values t (member t nil)))
546 (let ((start-epoch sb!kernel::*gc-epoch*))
547 (macrolet ((result (value foundp)
548 ;; When the table has multiple concurrent readers,
549 ;; it's possible that there was a GC after this
550 ;; thread called MAYBE-REHASH from %GETHASH3, and
551 ;; some other thread then rehashed the table. If
552 ;; this happens, we might not find the key even if
553 ;; it's in the table. To protect against this,
554 ;; redo the lookup if the GC epoch counter has changed.
555 ;; -- JES, 2007-09-30
556 `(if (and (not ,foundp)
557 (not (eql start-epoch sb!kernel::*gc-epoch*)))
559 (return-from %gethash3 (values ,value ,foundp))))
561 ;; The next-vector chain is circular. This is caused
562 ;; caused by thread-unsafe mutations of the table.
563 `(signal-corrupt-hash-table hash-table)))
564 (maybe-rehash hash-table nil)
565 ;; Note that it's OK for a GC + a REHASH-WITHOUT-GROWING to
566 ;; be triggered by another thread after this point, since the
567 ;; GC epoch check will catch it.
568 (let ((cache (hash-table-cache hash-table))
569 (table (hash-table-table hash-table)))
570 ;; First check the cache. Use EQ here for speed.
572 (< cache (length table))
573 (eq (aref table cache) key))
574 (let ((value (aref table (1+ cache))))
576 ;; Search for key in the hash table.
577 (multiple-value-bind (hashing eq-based)
578 (funcall (hash-table-hash-fun hash-table) key)
579 (declare (type hash hashing))
580 (let* ((index-vector (hash-table-index-vector hash-table))
581 (length (length index-vector))
582 (index (index-for-hashing hashing length))
583 (next (aref index-vector index))
584 (next-vector (hash-table-next-vector hash-table))
585 (hash-vector (hash-table-hash-vector hash-table))
586 (test-fun (hash-table-test-fun hash-table)))
587 (declare (type index index))
588 ;; Search next-vector chain for a matching key.
589 (if (or eq-based (not hash-vector))
590 (do ((next next (aref next-vector next))
592 ((zerop next) (result default nil))
593 (declare (type index/2 next i))
596 (when (eq key (aref table (* 2 next)))
597 (update-hash-table-cache hash-table (* 2 next))
598 (let ((value (aref table (1+ (* 2 next)))))
600 (do ((next next (aref next-vector next))
602 ((zerop next) (result default nil))
603 (declare (type index/2 next i))
606 (when (and (= hashing (aref hash-vector next))
607 (funcall test-fun key
608 (aref table (* 2 next))))
610 (update-hash-table-cache hash-table (* 2 next))
611 (let ((value (aref table (1+ (* 2 next)))))
612 (result value t)))))))))))))
614 (defun gethash3 (key hash-table default)
615 "Three argument version of GETHASH"
616 (declare (type hash-table hash-table))
617 (with-hash-table-locks (hash-table (%gethash3) key)
618 (%gethash3 key hash-table default)))
620 ;;; so people can call #'(SETF GETHASH)
621 (defun (setf gethash) (new-value key table &optional default)
622 (declare (ignore default))
623 (%puthash key table new-value))
625 (declaim (maybe-inline %%puthash))
626 (defun %%puthash (key hash-table value)
627 (declare (optimize speed))
628 ;; We need to rehash here so that a current key can be found if it
629 ;; exists. Check that there is room for one more entry. May not be
630 ;; needed if the key is already present.
631 (maybe-rehash hash-table t)
632 ;; Search for key in the hash table.
633 (multiple-value-bind (hashing eq-based)
634 (funcall (hash-table-hash-fun hash-table) key)
635 (declare (type hash hashing))
636 (let* ((index-vector (hash-table-index-vector hash-table))
637 (length (length index-vector))
638 (index (index-for-hashing hashing length))
639 (next (aref index-vector index))
640 (kv-vector (hash-table-table hash-table))
641 (next-vector (hash-table-next-vector hash-table))
642 (hash-vector (hash-table-hash-vector hash-table))
643 (test-fun (hash-table-test-fun hash-table)))
644 (declare (type index index next))
645 (when (hash-table-weakness hash-table)
646 (set-header-data kv-vector sb!vm:vector-valid-hashing-subtype))
647 (cond ((or eq-based (not hash-vector))
649 (set-header-data kv-vector
650 sb!vm:vector-valid-hashing-subtype))
651 ;; Search next-vector chain for a matching key.
652 (do ((next next (aref next-vector next))
655 (declare (type index/2 next i))
657 (signal-corrupt-hash-table hash-table))
658 (when (eq key (aref kv-vector (* 2 next)))
659 ;; Found, just replace the value.
660 (update-hash-table-cache hash-table (* 2 next))
661 (setf (aref kv-vector (1+ (* 2 next))) value)
662 (return-from %%puthash value))))
664 ;; Search next-vector chain for a matching key.
665 (do ((next next (aref next-vector next))
668 (declare (type index/2 next i))
670 (signal-corrupt-hash-table hash-table))
671 (when (and (= hashing (aref hash-vector next))
672 (funcall test-fun key
673 (aref kv-vector (* 2 next))))
674 ;; Found, just replace the value.
675 (update-hash-table-cache hash-table (* 2 next))
676 (setf (aref kv-vector (1+ (* 2 next))) value)
677 (return-from %%puthash value)))))
678 ;; Pop a KV slot off the free list
679 (let ((free-kv-slot (hash-table-next-free-kv hash-table)))
680 (declare (type index/2 free-kv-slot))
681 ;; Double-check for overflow.
682 (aver (not (zerop free-kv-slot)))
683 (setf (hash-table-next-free-kv hash-table)
684 (aref next-vector free-kv-slot))
685 (incf (hash-table-number-entries hash-table))
686 (update-hash-table-cache hash-table (* 2 free-kv-slot))
687 (setf (aref kv-vector (* 2 free-kv-slot)) key)
688 (setf (aref kv-vector (1+ (* 2 free-kv-slot))) value)
689 ;; Setup the hash-vector if necessary.
692 (setf (aref hash-vector free-kv-slot) hashing)
693 (aver (= (aref hash-vector free-kv-slot)
694 +magic-hash-vector-value+))))
695 ;; Push this slot into the next chain.
696 (setf (aref next-vector free-kv-slot) next)
697 (setf (aref index-vector index) free-kv-slot)))
700 (defun %puthash (key hash-table value)
701 (declare (type hash-table hash-table))
702 (aver (hash-table-index-vector hash-table))
703 (let ((cache (hash-table-cache hash-table))
704 (kv-vector (hash-table-table hash-table)))
707 (< cache (length kv-vector))
708 (eq (aref kv-vector cache) key))
709 ;; If cached, just store here
710 (setf (aref kv-vector (1+ cache)) value)
711 ;; Otherwise do things the hard way
712 (with-hash-table-locks (hash-table (%%puthash) key)
713 (%%puthash key hash-table value)))))
715 (declaim (maybe-inline %remhash))
716 (defun %remhash (key hash-table)
717 ;; We need to rehash here so that a current key can be found if it
720 ;; Note that if a GC happens after MAYBE-REHASH returns and another
721 ;; thread the accesses the table (triggering a rehash), we might not
722 ;; find the key even if it is in the table. But that's ok, since the
723 ;; only concurrent case that we safely allow is multiple readers
725 (maybe-rehash hash-table nil)
726 ;; Search for key in the hash table.
727 (multiple-value-bind (hashing eq-based)
728 (funcall (hash-table-hash-fun hash-table) key)
729 (declare (type hash hashing))
730 (let* ((index-vector (hash-table-index-vector hash-table))
731 (length (length index-vector))
732 (index (index-for-hashing hashing length))
733 (next (aref index-vector index))
734 (table (hash-table-table hash-table))
735 (next-vector (hash-table-next-vector hash-table))
736 (hash-vector (hash-table-hash-vector hash-table))
737 (test-fun (hash-table-test-fun hash-table)))
738 (declare (type index index)
740 (flet ((clear-slot (chain-vector prior-slot-location slot-location)
741 (declare (type index/2 slot-location))
742 ;; Mark slot as empty.
743 (setf (aref table (* 2 slot-location)) +empty-ht-slot+
744 (aref table (1+ (* 2 slot-location))) +empty-ht-slot+)
745 ;; Update the prior pointer in the chain to skip this.
746 (setf (aref chain-vector prior-slot-location)
747 (aref next-vector slot-location))
748 ;; Push KV slot onto free chain.
749 (setf (aref next-vector slot-location)
750 (hash-table-next-free-kv hash-table))
751 (setf (hash-table-next-free-kv hash-table) slot-location)
753 (setf (aref hash-vector slot-location)
754 +magic-hash-vector-value+))
755 (decf (hash-table-number-entries hash-table))
759 ((if (or eq-based (not hash-vector))
760 (eq key (aref table (* 2 next)))
761 (and (= hashing (aref hash-vector next))
762 (funcall test-fun key (aref table (* 2 next)))))
763 (clear-slot index-vector index next))
764 ;; Search next-vector chain for a matching key.
765 ((or eq-based (not hash-vector))
767 (do ((prior next next)
769 (next (aref next-vector next) (aref next-vector next)))
771 (declare (type index next))
773 (signal-corrupt-hash-table hash-table))
774 (when (eq key (aref table (* 2 next)))
775 (return-from %remhash (clear-slot next-vector prior next)))))
778 (do ((prior next next)
780 (next (aref next-vector next) (aref next-vector next)))
782 (declare (type index/2 next))
784 (signal-corrupt-hash-table hash-table))
785 (when (and (= hashing (aref hash-vector next))
786 (funcall test-fun key (aref table (* 2 next))))
787 (return-from %remhash
788 (clear-slot next-vector prior next))))))))))
790 (defun remhash (key hash-table)
792 "Remove the entry in HASH-TABLE associated with KEY. Return T if there
793 was such an entry, or NIL if not."
794 (declare (type hash-table hash-table)
795 (values (member t nil)))
796 ;; For now, just clear the cache
797 (setf (hash-table-cache hash-table) nil)
798 (with-hash-table-locks (hash-table (%remhash) key)
799 (%remhash key hash-table)))
801 (defun clrhash (hash-table)
803 "This removes all the entries from HASH-TABLE and returns the hash table
805 (with-hash-table-locks (hash-table nil)
806 (let* ((kv-vector (hash-table-table hash-table))
807 (next-vector (hash-table-next-vector hash-table))
808 (hash-vector (hash-table-hash-vector hash-table))
809 (size (length next-vector))
810 (index-vector (hash-table-index-vector hash-table)))
811 ;; Disable GC tricks.
812 (set-header-data kv-vector sb!vm:vector-normal-subtype)
813 ;; Mark all slots as empty by setting all keys and values to magic
815 (aver (eq (aref kv-vector 0) hash-table))
816 (fill kv-vector +empty-ht-slot+ :start 2)
817 ;; Set up the free list, all free.
820 (setf (aref next-vector i) (1+ i)))
821 (setf (aref next-vector (1- size)) 0)
822 (setf (hash-table-next-free-kv hash-table) 1)
823 ;; Clear the index-vector.
824 (fill index-vector 0)
825 ;; Clear the hash-vector.
827 (fill hash-vector +magic-hash-vector-value+)))
828 (setf (hash-table-cache hash-table) nil)
829 (setf (hash-table-number-entries hash-table) 0)
835 ;;; FIXME: This should be made into a compiler transform for two reasons:
836 ;;; 1. It would then be available for compiling the entire system,
837 ;;; not only parts of the system which are defined after DEFUN MAPHASH.
838 ;;; 2. It could be conditional on compilation policy, so that
839 ;;; it could be compiled as a full call instead of an inline
840 ;;; expansion when SPACE>SPEED.
841 (declaim (inline maphash))
842 (defun maphash (function-designator hash-table)
844 "For each entry in HASH-TABLE, call the designated two-argument function on
845 the key and value of the entry. Return NIL."
846 ;; This essentially duplicates WITH-HASH-TABLE-ITERATOR, so
847 ;; any changes here should be reflected there as well.
848 (let ((fun (%coerce-callable-to-fun function-designator))
849 (size (length (hash-table-next-vector hash-table))))
850 (declare (type function fun))
853 (declare (type index/2 i))
854 (let* ((kv-vector (hash-table-table hash-table))
855 (key (aref kv-vector (* 2 i)))
856 (value (aref kv-vector (1+ (* 2 i)))))
857 ;; We are running without locking or WITHOUT-GCING. For a weak
858 ;; :VALUE hash table it's possible that the GC hit after KEY
859 ;; was read and now the entry is gone. So check if either the
860 ;; key or the value is empty.
861 (unless (or (eq key +empty-ht-slot+)
862 (eq value +empty-ht-slot+))
863 (funcall fun key value))))))
865 ;;;; methods on HASH-TABLE
867 ;;; Return a list of keyword args and values to use for MAKE-HASH-TABLE
868 ;;; when reconstructing HASH-TABLE.
869 (defun %hash-table-ctor-args (hash-table)
870 `(:test ',(hash-table-test hash-table)
871 :size ',(hash-table-size hash-table)
872 :rehash-size ',(hash-table-rehash-size hash-table)
873 :rehash-threshold ',(hash-table-rehash-threshold hash-table)
874 :weakness ',(hash-table-weakness hash-table)))
876 ;;; Return an association list representing the same data as HASH-TABLE.
877 (defun %hash-table-alist (hash-table)
879 (maphash (lambda (key value)
880 (push (cons key value) result))
884 ;;; Stuff an association list into HASH-TABLE. Return the hash table,
885 ;;; so that we can use this for the *PRINT-READABLY* case in
886 ;;; PRINT-OBJECT (HASH-TABLE T) without having to worry about LET
887 ;;; forms and readable gensyms and stuff.
888 (defun %stuff-hash-table (hash-table alist)
890 (setf (gethash (car x) hash-table) (cdr x)))
893 (def!method print-object ((hash-table hash-table) stream)
894 (declare (type stream stream))
895 (cond ((or (not *print-readably*) (not *read-eval*))
896 (print-unreadable-object (hash-table stream :type t :identity t)
899 (hash-table-test hash-table)
900 (hash-table-count hash-table))))
902 (with-standard-io-syntax
905 `(%stuff-hash-table (make-hash-table ,@(%hash-table-ctor-args
907 ',(%hash-table-alist hash-table)))))))
909 (def!method make-load-form ((hash-table hash-table) &optional environment)
910 (declare (ignore environment))
911 (values `(make-hash-table ,@(%hash-table-ctor-args hash-table))
912 `(%stuff-hash-table ,hash-table ',(%hash-table-alist hash-table))))