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 ;; This stuff is performance critical and unwind-protect is too
18 ;; slow. And without the locking the next vector can get cyclic
19 ;; causing looping in a WITHOUT-GCING form, SHRINK-VECTOR can corrupt
20 ;; memory and who knows what else.
21 (defmacro with-spinlock-and-without-gcing ((spinlock) &body body)
23 (declare (ignore spinlock))
25 (let ((*gc-inhibit* t))
27 (sb!thread::get-spinlock ,spinlock)
30 (sb!thread::release-spinlock ,spinlock)
31 ;; the test is racy, but it can err only on the overeager side
32 (sb!kernel::maybe-handle-pending-gc)))
34 (eval-when (:compile-toplevel :load-toplevel :execute)
35 (defconstant max-hash sb!xc:most-positive-fixnum))
38 `(integer 0 ,max-hash))
40 ;;; FIXME: Does this always make a nonnegative FIXNUM? If so, then
41 ;;; explain why. If not (or if the reason it always makes a
42 ;;; nonnegative FIXNUM is only the accident that pointers in supported
43 ;;; architectures happen to be in the lower half of the address
44 ;;; space), then fix it.
45 #!-sb-fluid (declaim (inline pointer-hash))
46 (defun pointer-hash (key)
47 (declare (values hash))
48 (truly-the hash (%primitive sb!c:make-fixnum key)))
50 #!-sb-fluid (declaim (inline eq-hash))
52 (declare (values hash (member t nil)))
53 (values (pointer-hash key)
54 (oddp (get-lisp-obj-address key))))
56 #!-sb-fluid (declaim (inline equal-hash))
57 (defun equal-hash (key)
58 (declare (values hash (member t nil)))
59 (values (sxhash key) nil))
61 #!-sb-fluid (declaim (inline eql-hash))
63 (declare (values hash (member t nil)))
68 (defun equalp-hash (key)
69 (declare (values hash (member t nil)))
70 (values (psxhash key) nil))
72 (defun almost-primify (num)
73 (declare (type index num))
75 "Return an almost prime number greater than or equal to NUM."
84 ;;;; user-defined hash table tests
86 (defvar *hash-table-tests* nil)
88 (defun define-hash-table-test (name test-fun hash-fun)
90 "Define a new kind of hash table test."
91 (declare (type symbol name)
92 (type function test-fun hash-fun))
93 (setf *hash-table-tests*
94 (cons (list name test-fun hash-fun)
95 (remove name *hash-table-tests* :test #'eq :key #'car)))
98 ;;;; construction and simple accessors
100 (defconstant +min-hash-table-size+ 16)
101 (defconstant +min-hash-table-rehash-threshold+ (float 1/16 1.0))
103 (defun make-hash-table (&key (test 'eql)
104 (size +min-hash-table-size+)
109 "Create and return a new hash table. The keywords are as follows:
110 :TEST -- Indicates what kind of test to use.
111 :SIZE -- A hint as to how many elements will be put in this hash
113 :REHASH-SIZE -- Indicates how to expand the table when it fills up.
114 If an integer, add space for that many elements. If a floating
115 point number (which must be greater than 1.0), multiply the size
117 :REHASH-THRESHOLD -- Indicates how dense the table can become before
118 forcing a rehash. Can be any positive number <=1, with density
119 approaching zero as the threshold approaches 0. Density 1 means an
120 average of one entry per bucket.
121 :WEAK-P -- (This is an extension from CMU CL, not currently supported
122 in SBCL 0.6.6, but perhaps supported in a future version.) If T,
123 don't keep entries if the key would otherwise be garbage."
124 (declare (type (or function symbol) test))
125 (declare (type unsigned-byte size))
127 (error "stub: unsupported WEAK-P option"))
128 (multiple-value-bind (test test-fun hash-fun)
129 (cond ((or (eq test #'eq) (eq test 'eq))
130 (values 'eq #'eq #'eq-hash))
131 ((or (eq test #'eql) (eq test 'eql))
132 (values 'eql #'eql #'eql-hash))
133 ((or (eq test #'equal) (eq test 'equal))
134 (values 'equal #'equal #'equal-hash))
135 ((or (eq test #'equalp) (eq test 'equalp))
136 (values 'equalp #'equalp #'equalp-hash))
138 ;; FIXME: I'd like to remove *HASH-TABLE-TESTS* stuff.
139 ;; Failing that, I'd like to rename it to
140 ;; *USER-HASH-TABLE-TESTS*.
141 (dolist (info *hash-table-tests*
142 (error "unknown :TEST for MAKE-HASH-TABLE: ~S"
144 (destructuring-bind (test-name test-fun hash-fun) info
145 (when (or (eq test test-name) (eq test test-fun))
146 (return (values test-name test-fun hash-fun)))))))
147 (let* ((size (max +min-hash-table-size+
149 ;; SIZE is just a hint, so if the user asks
150 ;; for a SIZE which'd be too big for us to
151 ;; easily implement, we bump it down.
152 (floor array-dimension-limit 1024))))
153 (rehash-size (if (integerp rehash-size)
155 (float rehash-size 1.0)))
156 ;; FIXME: Original REHASH-THRESHOLD default should be 1.0,
157 ;; not 1, to make it easier for the compiler to avoid
159 (rehash-threshold (max +min-hash-table-rehash-threshold+
160 (float rehash-threshold 1.0)))
161 (size+1 (1+ size)) ; The first element is not usable.
162 ;; KLUDGE: The most natural way of expressing the below is
163 ;; (round (/ (float size+1) rehash-threshold)), and indeed
164 ;; it was expressed like that until 0.7.0. However,
165 ;; MAKE-HASH-TABLE is called very early in cold-init, and
166 ;; the SPARC has no primitive instructions for rounding,
167 ;; but only for truncating; therefore, we fudge this issue
168 ;; a little. The other uses of truncate, below, similarly
169 ;; used to be round. -- CSR, 2002-10-01
171 ;; Note that this has not yet been audited for
172 ;; correctness. It just seems to work. -- CSR, 2002-11-02
173 (scaled-size (truncate (/ (float size+1) rehash-threshold)))
174 (length (almost-primify (max scaled-size
175 (1+ +min-hash-table-size+))))
176 (index-vector (make-array length
178 '(unsigned-byte #.sb!vm:n-word-bits)
180 ;; needs to be the same length as the KV vector
181 ;; (FIXME: really? why doesn't the code agree?)
182 (next-vector (make-array size+1
184 '(unsigned-byte #.sb!vm:n-word-bits)))
185 (kv-vector (make-array (* 2 size+1)
186 :initial-element +empty-ht-slot+))
187 (table (%make-hash-table
191 :rehash-size rehash-size
192 :rehash-threshold rehash-threshold
196 :index-vector index-vector
197 :next-vector next-vector
198 :hash-vector (unless (eq test 'eq)
200 :element-type '(unsigned-byte #.sb!vm:n-word-bits)
201 :initial-element +magic-hash-vector-value+))
202 :spinlock (sb!thread::make-spinlock))))
203 (declare (type index size+1 scaled-size length))
204 ;; Set up the free list, all free. These lists are 0 terminated.
207 (setf (aref next-vector i) (1+ i)))
208 (setf (aref next-vector size) 0)
209 (setf (hash-table-next-free-kv table) 1)
210 (setf (hash-table-needing-rehash table) 0)
211 (setf (aref kv-vector 0) table)
214 (defun hash-table-count (hash-table)
216 "Return the number of entries in the given HASH-TABLE."
217 (declare (type hash-table hash-table)
219 (hash-table-number-entries hash-table))
222 (setf (fdocumentation 'hash-table-rehash-size 'function)
223 "Return the rehash-size HASH-TABLE was created with.")
226 (setf (fdocumentation 'hash-table-rehash-threshold 'function)
227 "Return the rehash-threshold HASH-TABLE was created with.")
229 (defun hash-table-size (hash-table)
231 "Return a size that can be used with MAKE-HASH-TABLE to create a hash
232 table that can hold however many entries HASH-TABLE can hold without
234 (hash-table-rehash-trigger hash-table))
237 (setf (fdocumentation 'hash-table-test 'function)
238 "Return the test HASH-TABLE was created with.")
241 (setf (fdocumentation 'hash-table-weak-p 'function)
242 "Return T if HASH-TABLE will not keep entries for keys that would
243 otherwise be garbage, and NIL if it will.")
245 ;;;; accessing functions
247 ;;; Make new vectors for the table, extending the table based on the
249 (defun rehash (table)
250 (declare (type hash-table table))
251 (let* ((old-kv-vector (hash-table-table table))
252 (old-next-vector (hash-table-next-vector table))
253 (old-hash-vector (hash-table-hash-vector table))
254 (old-size (length old-next-vector))
256 (let ((rehash-size (hash-table-rehash-size table)))
257 (etypecase rehash-size
259 (+ rehash-size old-size))
261 (the index (truncate (* rehash-size old-size)))))))
262 (new-kv-vector (make-array (* 2 new-size)
263 :initial-element +empty-ht-slot+))
264 (new-next-vector (make-array new-size
265 :element-type '(unsigned-byte #.sb!vm:n-word-bits)
267 (new-hash-vector (when old-hash-vector
269 :element-type '(unsigned-byte #.sb!vm:n-word-bits)
270 :initial-element +magic-hash-vector-value+)))
271 (old-index-vector (hash-table-index-vector table))
272 (new-length (almost-primify
273 (truncate (/ (float new-size)
274 (hash-table-rehash-threshold table)))))
275 (new-index-vector (make-array new-length
276 :element-type '(unsigned-byte #.sb!vm:n-word-bits)
277 :initial-element 0)))
278 (declare (type index new-size new-length old-size))
280 ;; Disable GC tricks on the OLD-KV-VECTOR.
281 (set-header-data old-kv-vector sb!vm:vector-normal-subtype)
283 ;; FIXME: here and in several other places in the hash table code,
284 ;; loops like this one are used when FILL or REPLACE would be
285 ;; appropriate. why are standard CL functions not used?
286 ;; Performance issues? General laziness? -- NJF, 2004-03-10
288 ;; Copy over the kv-vector. The element positions should not move
289 ;; in case there are active scans.
290 (dotimes (i (* old-size 2))
291 (declare (type index i))
292 (setf (aref new-kv-vector i) (aref old-kv-vector i)))
294 ;; Copy over the hash-vector.
295 (when old-hash-vector
296 (dotimes (i old-size)
297 (setf (aref new-hash-vector i) (aref old-hash-vector i))))
299 (setf (hash-table-next-free-kv table) 0)
300 (setf (hash-table-needing-rehash table) 0)
301 ;; Rehash all the entries; last to first so that after the pushes
302 ;; the chains are first to last.
303 (do ((i (1- new-size) (1- i)))
305 (let ((key (aref new-kv-vector (* 2 i)))
306 (value (aref new-kv-vector (1+ (* 2 i)))))
307 (cond ((and (eq key +empty-ht-slot+)
308 (eq value +empty-ht-slot+))
309 ;; Slot is empty, push it onto the free list.
310 (setf (aref new-next-vector i)
311 (hash-table-next-free-kv table))
312 (setf (hash-table-next-free-kv table) i))
313 ((and new-hash-vector
314 (not (= (aref new-hash-vector i) +magic-hash-vector-value+)))
315 ;; Can use the existing hash value (not EQ based)
316 (let* ((hashing (aref new-hash-vector i))
317 (index (rem hashing new-length))
318 (next (aref new-index-vector index)))
319 (declare (type index index)
321 ;; Push this slot into the next chain.
322 (setf (aref new-next-vector i) next)
323 (setf (aref new-index-vector index) i)))
327 (set-header-data new-kv-vector
328 sb!vm:vector-valid-hashing-subtype)
329 (let* ((hashing (pointer-hash key))
330 (index (rem hashing new-length))
331 (next (aref new-index-vector index)))
332 (declare (type index index)
334 ;; Push this slot onto the next chain.
335 (setf (aref new-next-vector i) next)
336 (setf (aref new-index-vector index) i))))))
337 (setf (hash-table-table table) new-kv-vector)
338 (setf (hash-table-index-vector table) new-index-vector)
339 (setf (hash-table-next-vector table) new-next-vector)
340 (setf (hash-table-hash-vector table) new-hash-vector)
341 ;; Shrink the old vectors to 0 size to help the conservative GC.
342 (shrink-vector old-kv-vector 0)
343 (shrink-vector old-index-vector 0)
344 (shrink-vector old-next-vector 0)
345 (when old-hash-vector
346 (shrink-vector old-hash-vector 0))
347 (setf (hash-table-rehash-trigger table) new-size))
350 ;;; Use the same size as before, re-using the vectors.
351 (defun rehash-without-growing (table)
352 (declare (type hash-table table))
353 (let* ((kv-vector (hash-table-table table))
354 (next-vector (hash-table-next-vector table))
355 (hash-vector (hash-table-hash-vector table))
356 (size (length next-vector))
357 (index-vector (hash-table-index-vector table))
358 (length (length index-vector)))
359 (declare (type index size length))
361 ;; Disable GC tricks, they will be re-enabled during the re-hash
363 (set-header-data kv-vector sb!vm:vector-normal-subtype)
365 ;; Rehash all the entries.
366 (setf (hash-table-next-free-kv table) 0)
367 (setf (hash-table-needing-rehash table) 0)
369 (setf (aref next-vector i) 0))
371 (setf (aref index-vector i) 0))
372 (do ((i (1- size) (1- i)))
374 (let ((key (aref kv-vector (* 2 i)))
375 (value (aref kv-vector (1+ (* 2 i)))))
376 (cond ((and (eq key +empty-ht-slot+)
377 (eq value +empty-ht-slot+))
378 ;; Slot is empty, push it onto free list.
379 (setf (aref next-vector i) (hash-table-next-free-kv table))
380 (setf (hash-table-next-free-kv table) i))
381 ((and hash-vector (not (= (aref hash-vector i) +magic-hash-vector-value+)))
382 ;; Can use the existing hash value (not EQ based)
383 (let* ((hashing (aref hash-vector i))
384 (index (rem hashing length))
385 (next (aref index-vector index)))
386 (declare (type index index))
387 ;; Push this slot into the next chain.
388 (setf (aref next-vector i) next)
389 (setf (aref index-vector index) i)))
393 (set-header-data kv-vector sb!vm:vector-valid-hashing-subtype)
394 (let* ((hashing (pointer-hash key))
395 (index (rem hashing length))
396 (next (aref index-vector index)))
397 (declare (type index index)
399 ;; Push this slot into the next chain.
400 (setf (aref next-vector i) next)
401 (setf (aref index-vector index) i)))))))
404 (defun flush-needing-rehash (table)
405 (let* ((kv-vector (hash-table-table table))
406 (index-vector (hash-table-index-vector table))
407 (next-vector (hash-table-next-vector table))
408 (length (length index-vector)))
409 (do ((next (hash-table-needing-rehash table)))
411 (declare (type index next))
412 (let* ((key (aref kv-vector (* 2 next)))
413 (hashing (pointer-hash key))
414 (index (rem hashing length))
415 (temp (aref next-vector next)))
416 (setf (aref next-vector next) (aref index-vector index))
417 (setf (aref index-vector index) next)
419 (setf (hash-table-needing-rehash table) 0)
422 (defun gethash (key hash-table &optional default)
424 "Finds the entry in HASH-TABLE whose key is KEY and returns the associated
425 value and T as multiple values, or returns DEFAULT and NIL if there is no
426 such entry. Entries can be added using SETF."
427 (declare (type hash-table hash-table)
428 (values t (member t nil)))
429 (gethash3 key hash-table default))
431 (defun gethash2 (key hash-table)
433 "Two argument version of GETHASH"
434 (declare (type hash-table hash-table)
435 (values t (member t nil)))
436 (gethash3 key hash-table nil))
438 (defun gethash3 (key hash-table default)
440 "Three argument version of GETHASH"
441 (declare (type hash-table hash-table)
442 (values t (member t nil)))
443 (with-spinlock-and-without-gcing ((hash-table-spinlock hash-table))
444 (cond ((= (get-header-data (hash-table-table hash-table))
445 sb!vm:vector-must-rehash-subtype)
446 (rehash-without-growing hash-table))
447 ((not (zerop (hash-table-needing-rehash hash-table)))
448 (flush-needing-rehash hash-table)))
450 ;; First check the cache. Use EQ here for speed.
451 (let ((cache (hash-table-cache hash-table))
452 (table (hash-table-table hash-table)))
454 (if (and cache (< cache (length table)) (eq (aref table cache) key))
455 (values (aref table (1+ cache)) t)
457 ;; Search for key in the hash table.
458 (multiple-value-bind (hashing eq-based)
459 (funcall (hash-table-hash-fun hash-table) key)
460 (declare (type hash hashing))
461 (let* ((index-vector (hash-table-index-vector hash-table))
462 (length (length index-vector))
463 (index (rem hashing length))
464 (next (aref index-vector index))
465 (next-vector (hash-table-next-vector hash-table))
466 (hash-vector (hash-table-hash-vector hash-table))
467 (test-fun (hash-table-test-fun hash-table)))
468 (declare (type index index))
469 ;; Search next-vector chain for a matching key.
470 (if (or eq-based (not hash-vector))
471 (do ((next next (aref next-vector next)))
472 ((zerop next) (values default nil))
473 (declare (type index next))
474 (when (eq key (aref table (* 2 next)))
475 (setf (hash-table-cache hash-table) (* 2 next))
476 (return (values (aref table (1+ (* 2 next))) t))))
477 (do ((next next (aref next-vector next)))
478 ((zerop next) (values default nil))
479 (declare (type index next))
480 (when (and (= hashing (aref hash-vector next))
481 (funcall test-fun key (aref table (* 2 next))))
483 (setf (hash-table-cache hash-table) (* 2 next))
484 (return (values (aref table (1+ (* 2 next))) t)))))))))))
486 ;;; so people can call #'(SETF GETHASH)
487 (defun (setf gethash) (new-value key table &optional default)
488 (declare (ignore default))
489 (%puthash key table new-value))
491 (defun %puthash (key hash-table value)
492 (declare (type hash-table hash-table))
493 (aver (hash-table-index-vector hash-table))
494 (with-spinlock-and-without-gcing ((hash-table-spinlock hash-table))
495 ;; We need to rehash here so that a current key can be found if it
496 ;; exists. Check that there is room for one more entry. May not be
497 ;; needed if the key is already present.
498 (cond ((zerop (hash-table-next-free-kv hash-table))
500 ((= (get-header-data (hash-table-table hash-table))
501 sb!vm:vector-must-rehash-subtype)
502 (rehash-without-growing hash-table))
503 ((not (zerop (hash-table-needing-rehash hash-table)))
504 (flush-needing-rehash hash-table)))
506 (let ((cache (hash-table-cache hash-table))
507 (kv-vector (hash-table-table hash-table)))
510 (if (and cache (< cache (length kv-vector)) (eq (aref kv-vector cache) key))
511 ;; If cached, just store here
512 (setf (aref kv-vector (1+ cache)) value)
514 ;; Search for key in the hash table.
515 (multiple-value-bind (hashing eq-based)
516 (funcall (hash-table-hash-fun hash-table) key)
517 (declare (type hash hashing))
518 (let* ((index-vector (hash-table-index-vector hash-table))
519 (length (length index-vector))
520 (index (rem hashing length))
521 (next (aref index-vector index))
522 (kv-vector (hash-table-table hash-table))
523 (next-vector (hash-table-next-vector hash-table))
524 (hash-vector (hash-table-hash-vector hash-table))
525 (test-fun (hash-table-test-fun hash-table)))
526 (declare (type index index))
528 (cond ((or eq-based (not hash-vector))
530 (set-header-data kv-vector sb!vm:vector-valid-hashing-subtype))
532 ;; Search next-vector chain for a matching key.
533 (do ((next next (aref next-vector next)))
535 (declare (type index next))
536 (when (eq key (aref kv-vector (* 2 next)))
537 ;; Found, just replace the value.
538 (setf (hash-table-cache hash-table) (* 2 next))
539 (setf (aref kv-vector (1+ (* 2 next))) value)
540 (return-from %puthash value))))
542 ;; Search next-vector chain for a matching key.
543 (do ((next next (aref next-vector next)))
545 (declare (type index next))
546 (when (and (= hashing (aref hash-vector next))
547 (funcall test-fun key
548 (aref kv-vector (* 2 next))))
549 ;; Found, just replace the value.
550 (setf (hash-table-cache hash-table) (* 2 next))
551 (setf (aref kv-vector (1+ (* 2 next))) value)
552 (return-from %puthash value)))))
554 ;; Pop a KV slot off the free list
555 (let ((free-kv-slot (hash-table-next-free-kv hash-table)))
556 ;; Double-check for overflow.
557 (aver (not (zerop free-kv-slot)))
558 (setf (hash-table-next-free-kv hash-table)
559 (aref next-vector free-kv-slot))
560 (incf (hash-table-number-entries hash-table))
562 (setf (hash-table-cache hash-table) (* 2 free-kv-slot))
563 (setf (aref kv-vector (* 2 free-kv-slot)) key)
564 (setf (aref kv-vector (1+ (* 2 free-kv-slot))) value)
566 ;; Setup the hash-vector if necessary.
569 (setf (aref hash-vector free-kv-slot) hashing)
570 (aver (= (aref hash-vector free-kv-slot)
571 +magic-hash-vector-value+))))
573 ;; Push this slot into the next chain.
574 (setf (aref next-vector free-kv-slot) next)
575 (setf (aref index-vector index) free-kv-slot)))))))
578 (defun remhash (key hash-table)
580 "Remove the entry in HASH-TABLE associated with KEY. Return T if there
581 was such an entry, or NIL if not."
582 (declare (type hash-table hash-table)
583 (values (member t nil)))
584 (with-spinlock-and-without-gcing ((hash-table-spinlock hash-table))
585 ;; We need to rehash here so that a current key can be found if it
587 (cond ((= (get-header-data (hash-table-table hash-table))
588 sb!vm:vector-must-rehash-subtype)
589 (rehash-without-growing hash-table))
590 ((not (zerop (hash-table-needing-rehash hash-table)))
591 (flush-needing-rehash hash-table)))
593 ;; For now, just clear the cache
594 (setf (hash-table-cache hash-table) nil)
596 ;; Search for key in the hash table.
597 (multiple-value-bind (hashing eq-based)
598 (funcall (hash-table-hash-fun hash-table) key)
599 (declare (type hash hashing))
600 (let* ((index-vector (hash-table-index-vector hash-table))
601 (length (length index-vector))
602 (index (rem hashing length))
603 (next (aref index-vector index))
604 (table (hash-table-table hash-table))
605 (next-vector (hash-table-next-vector hash-table))
606 (hash-vector (hash-table-hash-vector hash-table))
607 (test-fun (hash-table-test-fun hash-table)))
608 (declare (type index index next))
609 (flet ((clear-slot (chain-vector prior-slot-location slot-location)
610 ;; Mark slot as empty.
611 (setf (aref table (* 2 slot-location)) +empty-ht-slot+
612 (aref table (1+ (* 2 slot-location))) +empty-ht-slot+)
613 ;; Update the prior pointer in the chain to skip this.
614 (setf (aref chain-vector prior-slot-location)
615 (aref next-vector slot-location))
616 ;; Push KV slot onto free chain.
617 (setf (aref next-vector slot-location)
618 (hash-table-next-free-kv hash-table))
619 (setf (hash-table-next-free-kv hash-table) slot-location)
621 (setf (aref hash-vector slot-location)
622 +magic-hash-vector-value+))
623 (decf (hash-table-number-entries hash-table))
627 ((if (or eq-based (not hash-vector))
628 (eq key (aref table (* 2 next)))
629 (and (= hashing (aref hash-vector next))
630 (funcall test-fun key (aref table (* 2 next)))))
631 (clear-slot index-vector index next))
632 ;; Search next-vector chain for a matching key.
633 ((or eq-based (not hash-vector))
635 (do ((prior next next)
636 (next (aref next-vector next) (aref next-vector next)))
638 (declare (type index next))
639 (when (eq key (aref table (* 2 next)))
640 (return-from remhash (clear-slot next-vector prior next)))))
643 (do ((prior next next)
644 (next (aref next-vector next) (aref next-vector next)))
646 (declare (type index next))
647 (when (and (= hashing (aref hash-vector next))
648 (funcall test-fun key (aref table (* 2 next))))
649 (return-from remhash (clear-slot next-vector prior next)))))))))))
651 (defun clrhash (hash-table)
653 "This removes all the entries from HASH-TABLE and returns the hash table
655 (declare (optimize speed))
656 (with-spinlock-and-without-gcing ((hash-table-spinlock hash-table))
657 (let* ((kv-vector (hash-table-table hash-table))
658 (next-vector (hash-table-next-vector hash-table))
659 (hash-vector (hash-table-hash-vector hash-table))
660 (size (length next-vector))
661 (index-vector (hash-table-index-vector hash-table)))
662 ;; Disable GC tricks.
663 (set-header-data kv-vector sb!vm:vector-normal-subtype)
664 ;; Mark all slots as empty by setting all keys and values to magic
666 (aver (eq (aref kv-vector 0) hash-table))
667 (fill kv-vector +empty-ht-slot+ :start 2)
668 ;; Set up the free list, all free.
671 (setf (aref next-vector i) (1+ i)))
672 (setf (aref next-vector (1- size)) 0)
673 (setf (hash-table-next-free-kv hash-table) 1)
674 (setf (hash-table-needing-rehash hash-table) 0)
675 ;; Clear the index-vector.
676 (fill index-vector 0)
677 ;; Clear the hash-vector.
679 (fill hash-vector +magic-hash-vector-value+)))
680 (setf (hash-table-cache hash-table) nil)
681 (setf (hash-table-number-entries hash-table) 0))
686 ;;; FIXME: This should be made into a compiler transform for two reasons:
687 ;;; 1. It would then be available for compiling the entire system,
688 ;;; not only parts of the system which are defined after DEFUN MAPHASH.
689 ;;; 2. It could be conditional on compilation policy, so that
690 ;;; it could be compiled as a full call instead of an inline
691 ;;; expansion when SPACE>SPEED.
692 (declaim (inline maphash))
693 (defun maphash (function-designator hash-table)
695 "For each entry in HASH-TABLE, call the designated two-argument function
696 on the key and value of the entry. Return NIL."
697 (let ((fun (%coerce-callable-to-fun function-designator))
698 (size (length (hash-table-next-vector hash-table))))
699 (declare (type function fun))
702 (declare (type index i))
703 (let* ((kv-vector (hash-table-table hash-table))
704 (key (aref kv-vector (* 2 i)))
705 (value (aref kv-vector (1+ (* 2 i)))))
706 (unless (and (eq key +empty-ht-slot+)
707 (eq value +empty-ht-slot+))
708 (funcall fun key value))))))
710 ;;;; methods on HASH-TABLE
712 ;;; Return a list of keyword args and values to use for MAKE-HASH-TABLE
713 ;;; when reconstructing HASH-TABLE.
714 (defun %hash-table-ctor-args (hash-table)
715 (when (hash-table-weak-p hash-table)
716 ;; FIXME: This might actually work with no trouble, but as of
717 ;; sbcl-0.6.12.10 when this code was written, weak hash tables
718 ;; weren't working yet, so I couldn't test it. When weak hash
719 ;; tables are supported again, this should be fixed.
720 (error "can't dump weak hash tables readably")) ; defensive programming..
721 `(:test ',(hash-table-test hash-table)
722 :size ',(hash-table-size hash-table)
723 :rehash-size ',(hash-table-rehash-size hash-table)
724 :rehash-threshold ',(hash-table-rehash-threshold hash-table)))
726 ;;; Return an association list representing the same data as HASH-TABLE.
727 (defun %hash-table-alist (hash-table)
729 (maphash (lambda (key value)
730 (push (cons key value) result))
734 ;;; Stuff an association list into HASH-TABLE. Return the hash table,
735 ;;; so that we can use this for the *PRINT-READABLY* case in
736 ;;; PRINT-OBJECT (HASH-TABLE T) without having to worry about LET
737 ;;; forms and readable gensyms and stuff.
738 (defun %stuff-hash-table (hash-table alist)
740 (setf (gethash (car x) hash-table) (cdr x)))
743 (def!method print-object ((hash-table hash-table) stream)
744 (declare (type stream stream))
745 (cond ((or (not *print-readably*) (not *read-eval*))
746 (print-unreadable-object (hash-table stream :type t :identity t)
749 (hash-table-test hash-table)
750 (hash-table-count hash-table))))
752 (with-standard-io-syntax
755 `(%stuff-hash-table (make-hash-table ,@(%hash-table-ctor-args
757 ',(%hash-table-alist hash-table)))))))
759 (def!method make-load-form ((hash-table hash-table) &optional environment)
760 (declare (ignore environment))
761 (values `(make-hash-table ,@(%hash-table-ctor-args hash-table))
762 `(%stuff-hash-table ,hash-table ',(%hash-table-alist hash-table))))