1.0.6.28: fix UNWIND-TO-FRAME-AND-CALL for #+SB-THREAD
[sbcl.git] / src / code / target-hash-table.lisp
1 ;;;; that part of the implementation of HASH-TABLE which lives solely
2 ;;;; on the target system, not on the cross-compilation host
3
4 ;;;; This software is part of the SBCL system. See the README file for
5 ;;;; more information.
6 ;;;;
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.
12
13 (in-package "SB!IMPL")
14 \f
15 ;;;; utilities
16
17 ;;; Without the locking the next vector can get cyclic causing
18 ;;; looping in a WITHOUT-GCING form, SHRINK-VECTOR can corrupt memory
19 ;;; and who knows what else.
20 ;;;
21 ;;; WITHOUT-GCING implies WITHOUT-INTERRUPTS.
22 (defmacro with-spinlock-and-without-gcing ((spinlock) &body body)
23   #!-sb-thread
24   (declare (ignore spinlock))
25   `(without-gcing
26      (unwind-protect
27           (progn
28             #!+sb-thread
29             (sb!thread::get-spinlock ,spinlock)
30             ,@body)
31        #!+sb-thread
32        (sb!thread::release-spinlock ,spinlock))))
33
34 (eval-when (:compile-toplevel :load-toplevel :execute)
35   (defconstant max-hash sb!xc:most-positive-fixnum))
36
37 (deftype hash ()
38   `(integer 0 ,max-hash))
39
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)))
49
50 #!-sb-fluid (declaim (inline eq-hash))
51 (defun eq-hash (key)
52   (declare (values hash (member t nil)))
53   (values (pointer-hash key)
54           (oddp (get-lisp-obj-address key))))
55
56 #!-sb-fluid (declaim (inline equal-hash))
57 (defun equal-hash (key)
58   (declare (values hash (member t nil)))
59   (typecase key
60     ;; For some types the definition of EQUAL implies a special hash
61     ((or string cons number bit-vector pathname)
62      (values (sxhash key) nil))
63     ;; Otherwise use an EQ hash, rather than SXHASH, since the values
64     ;; of SXHASH will be extremely badly distributed due to the
65     ;; requirements of the spec fitting badly with our implementation
66     ;; strategy.
67     (t
68      (eq-hash key))))
69
70 #!-sb-fluid (declaim (inline eql-hash))
71 (defun eql-hash (key)
72   (declare (values hash (member t nil)))
73   (if (numberp key)
74       (equal-hash key)
75       (eq-hash key)))
76
77 (defun equalp-hash (key)
78   (declare (values hash (member t nil)))
79   (typecase key
80     ;; Types requiring special treatment. Note that PATHNAME and
81     ;; HASH-TABLE are caught by the STRUCTURE-OBJECT test.
82     ((or array cons number character structure-object)
83      (values (psxhash key) nil))
84     (t
85      (eq-hash key))))
86
87 (defun almost-primify (num)
88   (declare (type index num))
89   #!+sb-doc
90   "Return an almost prime number greater than or equal to NUM."
91   (if (= (rem num 2) 0)
92       (setq num (+ 1 num)))
93   (if (= (rem num 3) 0)
94       (setq num (+ 2 num)))
95   (if (= (rem num 7) 0)
96       (setq num (+ 4 num)))
97   num)
98 \f
99 ;;;; user-defined hash table tests
100
101 (defvar *hash-table-tests* nil)
102
103 (defun define-hash-table-test (name test-fun hash-fun)
104   #!+sb-doc
105   "Define a new kind of hash table test."
106   (declare (type symbol name)
107            (type function test-fun hash-fun))
108   (setf *hash-table-tests*
109         (cons (list name test-fun hash-fun)
110               (remove name *hash-table-tests* :test #'eq :key #'car)))
111   name)
112 \f
113 ;;;; construction and simple accessors
114
115 (defconstant +min-hash-table-size+ 16)
116 (defconstant +min-hash-table-rehash-threshold+ (float 1/16 1.0))
117
118 (defun make-hash-table (&key (test 'eql)
119                         (size +min-hash-table-size+)
120                         (rehash-size 1.5)
121                         (rehash-threshold 1)
122                         (weakness nil))
123   #!+sb-doc
124   "Create and return a new hash table. The keywords are as follows:
125      :TEST -- Indicates what kind of test to use.
126      :SIZE -- A hint as to how many elements will be put in this hash
127        table.
128      :REHASH-SIZE -- Indicates how to expand the table when it fills up.
129        If an integer, add space for that many elements. If a floating
130        point number (which must be greater than 1.0), multiply the size
131        by that amount.
132      :REHASH-THRESHOLD -- Indicates how dense the table can become before
133        forcing a rehash. Can be any positive number <=1, with density
134        approaching zero as the threshold approaches 0. Density 1 means an
135        average of one entry per bucket.
136      :WEAKNESS -- IF NIL (the default) it is a normal non-weak hash table.
137        If one of :KEY, :VALUE, :KEY-AND-VALUE, :KEY-OR-VALUE it is a weak
138        hash table.
139        Depending on the type of weakness the lack of references to the
140        key and the value may allow for removal of the entry. If WEAKNESS
141        is :KEY and the key would otherwise be garbage the entry is eligible
142        for removal from the hash table. Similarly, if WEAKNESS is :VALUE
143        the life of an entry depends on its value's references. If WEAKNESS
144        is :KEY-AND-VALUE and either the key or the value would otherwise be
145        garbage the entry can be removed. If WEAKNESS is :KEY-OR-VALUE and
146        both the key and the value would otherwise be garbage the entry can
147        be removed."
148   (declare (type (or function symbol) test))
149   (declare (type unsigned-byte size))
150   (multiple-value-bind (test test-fun hash-fun)
151       (cond ((or (eq test #'eq) (eq test 'eq))
152              (values 'eq #'eq #'eq-hash))
153             ((or (eq test #'eql) (eq test 'eql))
154              (values 'eql #'eql #'eql-hash))
155             ((or (eq test #'equal) (eq test 'equal))
156              (values 'equal #'equal #'equal-hash))
157             ((or (eq test #'equalp) (eq test 'equalp))
158              (values 'equalp #'equalp #'equalp-hash))
159             (t
160              ;; FIXME: I'd like to remove *HASH-TABLE-TESTS* stuff.
161              ;; Failing that, I'd like to rename it to
162              ;; *USER-HASH-TABLE-TESTS*.
163              (dolist (info *hash-table-tests*
164                       (error "unknown :TEST for MAKE-HASH-TABLE: ~S"
165                              test))
166                (destructuring-bind (test-name test-fun hash-fun) info
167                  (when (or (eq test test-name) (eq test test-fun))
168                    (return (values test-name test-fun hash-fun)))))))
169     (let* ((size (max +min-hash-table-size+
170                       (min size
171                            ;; SIZE is just a hint, so if the user asks
172                            ;; for a SIZE which'd be too big for us to
173                            ;; easily implement, we bump it down.
174                            (floor array-dimension-limit 1024))))
175            (rehash-size (if (integerp rehash-size)
176                             rehash-size
177                             (float rehash-size 1.0)))
178            ;; FIXME: Original REHASH-THRESHOLD default should be 1.0,
179            ;; not 1, to make it easier for the compiler to avoid
180            ;; boxing.
181            (rehash-threshold (max +min-hash-table-rehash-threshold+
182                                   (float rehash-threshold 1.0)))
183            (size+1 (1+ size))       ; The first element is not usable.
184            ;; KLUDGE: The most natural way of expressing the below is
185            ;; (round (/ (float size+1) rehash-threshold)), and indeed
186            ;; it was expressed like that until 0.7.0. However,
187            ;; MAKE-HASH-TABLE is called very early in cold-init, and
188            ;; the SPARC has no primitive instructions for rounding,
189            ;; but only for truncating; therefore, we fudge this issue
190            ;; a little. The other uses of truncate, below, similarly
191            ;; used to be round. -- CSR, 2002-10-01
192            ;;
193            ;; Note that this has not yet been audited for
194            ;; correctness. It just seems to work. -- CSR, 2002-11-02
195            (scaled-size (truncate (/ (float size+1) rehash-threshold)))
196            (length (almost-primify (max scaled-size
197                                         (1+ +min-hash-table-size+))))
198            (index-vector (make-array length
199                                      :element-type
200                                      '(unsigned-byte #.sb!vm:n-word-bits)
201                                      :initial-element 0))
202            ;; Needs to be the half the length of the KV vector to link
203            ;; KV entries - mapped to indeces at 2i and 2i+1 -
204            ;; together.
205            (next-vector (make-array size+1
206                                     :element-type
207                                     '(unsigned-byte #.sb!vm:n-word-bits)))
208            (kv-vector (make-array (* 2 size+1)
209                                   :initial-element +empty-ht-slot+))
210            (table (%make-hash-table
211                    :test test
212                    :test-fun test-fun
213                    :hash-fun hash-fun
214                    :rehash-size rehash-size
215                    :rehash-threshold rehash-threshold
216                    :rehash-trigger size
217                    :table kv-vector
218                    :weakness weakness
219                    :index-vector index-vector
220                    :next-vector next-vector
221                    :hash-vector
222                    (unless (eq test 'eq)
223                      (make-array size+1
224                                  :element-type '(unsigned-byte
225                                                  #.sb!vm:n-word-bits)
226                                  :initial-element +magic-hash-vector-value+))
227                    :spinlock (sb!thread::make-spinlock))))
228       (declare (type index size+1 scaled-size length))
229       ;; Set up the free list, all free. These lists are 0 terminated.
230       (do ((i 1 (1+ i)))
231           ((>= i size))
232         (setf (aref next-vector i) (1+ i)))
233       (setf (aref next-vector size) 0)
234       (setf (hash-table-next-free-kv table) 1)
235       (setf (hash-table-needing-rehash table) 0)
236       (setf (aref kv-vector 0) table)
237       table)))
238
239 (defun hash-table-count (hash-table)
240   #!+sb-doc
241   "Return the number of entries in the given HASH-TABLE."
242   (declare (type hash-table hash-table)
243            (values index))
244   (hash-table-number-entries hash-table))
245
246 #!+sb-doc
247 (setf (fdocumentation 'hash-table-rehash-size 'function)
248       "Return the rehash-size HASH-TABLE was created with.")
249
250 #!+sb-doc
251 (setf (fdocumentation 'hash-table-rehash-threshold 'function)
252       "Return the rehash-threshold HASH-TABLE was created with.")
253
254 (defun hash-table-size (hash-table)
255   #!+sb-doc
256   "Return a size that can be used with MAKE-HASH-TABLE to create a hash
257    table that can hold however many entries HASH-TABLE can hold without
258    having to be grown."
259   (hash-table-rehash-trigger hash-table))
260
261 #!+sb-doc
262 (setf (fdocumentation 'hash-table-test 'function)
263       "Return the test HASH-TABLE was created with.")
264
265 #!+sb-doc
266 (setf (fdocumentation 'hash-table-weakness 'function)
267       "Return the WEAKNESS of HASH-TABLE which is one of NIL, :KEY,
268 :VALUE, :KEY-AND-VALUE, :KEY-OR-VALUE.")
269 \f
270 ;;;; accessing functions
271
272 ;;; Make new vectors for the table, extending the table based on the
273 ;;; rehash-size.
274 (defun rehash (table)
275   (declare (type hash-table table))
276   (let* ((old-kv-vector (hash-table-table table))
277          (old-next-vector (hash-table-next-vector table))
278          (old-hash-vector (hash-table-hash-vector table))
279          (old-size (length old-next-vector))
280          (new-size
281           (let ((rehash-size (hash-table-rehash-size table)))
282             (etypecase rehash-size
283               (fixnum
284                (+ rehash-size old-size))
285               (float
286                (the index (truncate (* rehash-size old-size)))))))
287          (new-kv-vector (make-array (* 2 new-size)
288                                     :initial-element +empty-ht-slot+))
289          (new-next-vector
290           (make-array new-size
291                       :element-type '(unsigned-byte #.sb!vm:n-word-bits)
292                       :initial-element 0))
293          (new-hash-vector
294           (when old-hash-vector
295             (make-array new-size
296                         :element-type '(unsigned-byte #.sb!vm:n-word-bits)
297                         :initial-element +magic-hash-vector-value+)))
298          (old-index-vector (hash-table-index-vector table))
299          (new-length (almost-primify
300                       (truncate (/ (float new-size)
301                                    (hash-table-rehash-threshold table)))))
302          (new-index-vector
303           (make-array new-length
304                       :element-type '(unsigned-byte #.sb!vm:n-word-bits)
305                       :initial-element 0)))
306     (declare (type index new-size new-length old-size))
307
308     ;; Disable GC tricks on the OLD-KV-VECTOR.
309     (set-header-data old-kv-vector sb!vm:vector-normal-subtype)
310
311     ;; Non-empty weak hash tables always need GC support.
312     (when (and (hash-table-weakness table) (plusp (hash-table-count table)))
313       (set-header-data new-kv-vector sb!vm:vector-valid-hashing-subtype))
314
315     ;; FIXME: here and in several other places in the hash table code,
316     ;; loops like this one are used when FILL or REPLACE would be
317     ;; appropriate.  why are standard CL functions not used?
318     ;; Performance issues?  General laziness?  -- NJF, 2004-03-10
319
320     ;; Copy over the kv-vector. The element positions should not move
321     ;; in case there are active scans.
322     (dotimes (i (* old-size 2))
323       (declare (type index i))
324       (setf (aref new-kv-vector i) (aref old-kv-vector i)))
325
326     ;; Copy over the hash-vector.
327     (when old-hash-vector
328       (dotimes (i old-size)
329         (setf (aref new-hash-vector i) (aref old-hash-vector i))))
330
331     (setf (hash-table-next-free-kv table) 0)
332     (setf (hash-table-needing-rehash table) 0)
333     ;; Rehash all the entries; last to first so that after the pushes
334     ;; the chains are first to last.
335     (do ((i (1- new-size) (1- i)))
336         ((zerop i))
337       (declare (type index/2 i))
338       (let ((key (aref new-kv-vector (* 2 i)))
339             (value (aref new-kv-vector (1+ (* 2 i)))))
340         (cond ((and (eq key +empty-ht-slot+)
341                     (eq value +empty-ht-slot+))
342                ;; Slot is empty, push it onto the free list.
343                (setf (aref new-next-vector i)
344                      (hash-table-next-free-kv table))
345                (setf (hash-table-next-free-kv table) i))
346               ((and new-hash-vector
347                     (not (= (aref new-hash-vector i)
348                             +magic-hash-vector-value+)))
349                ;; Can use the existing hash value (not EQ based)
350                (let* ((hashing (aref new-hash-vector i))
351                       (index (rem hashing new-length))
352                       (next (aref new-index-vector index)))
353                  (declare (type index index)
354                           (type hash hashing))
355                  ;; Push this slot into the next chain.
356                  (setf (aref new-next-vector i) next)
357                  (setf (aref new-index-vector index) i)))
358               (t
359                ;; EQ base hash.
360                ;; Enable GC tricks.
361                (set-header-data new-kv-vector
362                                 sb!vm:vector-valid-hashing-subtype)
363                (let* ((hashing (pointer-hash key))
364                       (index (rem hashing new-length))
365                       (next (aref new-index-vector index)))
366                  (declare (type index index)
367                           (type hash hashing))
368                  ;; Push this slot onto the next chain.
369                  (setf (aref new-next-vector i) next)
370                  (setf (aref new-index-vector index) i))))))
371     (setf (hash-table-table table) new-kv-vector)
372     (setf (hash-table-index-vector table) new-index-vector)
373     (setf (hash-table-next-vector table) new-next-vector)
374     (setf (hash-table-hash-vector table) new-hash-vector)
375     ;; Shrink the old vectors to 0 size to help the conservative GC.
376     (%shrink-vector old-kv-vector 0)
377     (%shrink-vector old-index-vector 0)
378     (%shrink-vector old-next-vector 0)
379     (when old-hash-vector
380       (%shrink-vector old-hash-vector 0))
381     (setf (hash-table-rehash-trigger table) new-size))
382   (values))
383
384 ;;; Use the same size as before, re-using the vectors.
385 (defun rehash-without-growing (table)
386   (declare (type hash-table table))
387   (let* ((kv-vector (hash-table-table table))
388          (next-vector (hash-table-next-vector table))
389          (hash-vector (hash-table-hash-vector table))
390          (size (length next-vector))
391          (index-vector (hash-table-index-vector table))
392          (length (length index-vector)))
393     (declare (type index size length))
394
395     ;; Non-empty weak hash tables always need GC support.
396     (unless (and (hash-table-weakness table) (plusp (hash-table-count table)))
397       ;; Disable GC tricks, they will be re-enabled during the re-hash
398       ;; if necessary.
399       (set-header-data kv-vector sb!vm:vector-normal-subtype))
400
401     ;; Rehash all the entries.
402     (setf (hash-table-next-free-kv table) 0)
403     (setf (hash-table-needing-rehash table) 0)
404     (dotimes (i size)
405       (setf (aref next-vector i) 0))
406     (dotimes (i length)
407       (setf (aref index-vector i) 0))
408     (do ((i (1- size) (1- i)))
409         ((zerop i))
410       (declare (type index/2 i))
411       (let ((key (aref kv-vector (* 2 i)))
412             (value (aref kv-vector (1+ (* 2 i)))))
413         (cond ((and (eq key +empty-ht-slot+)
414                     (eq value +empty-ht-slot+))
415                ;; Slot is empty, push it onto free list.
416                (setf (aref next-vector i) (hash-table-next-free-kv table))
417                (setf (hash-table-next-free-kv table) i))
418               ((and hash-vector (not (= (aref hash-vector i)
419                                         +magic-hash-vector-value+)))
420                ;; Can use the existing hash value (not EQ based)
421                (let* ((hashing (aref hash-vector i))
422                       (index (rem hashing length))
423                       (next (aref index-vector index)))
424                  (declare (type index index))
425                  ;; Push this slot into the next chain.
426                  (setf (aref next-vector i) next)
427                  (setf (aref index-vector index) i)))
428               (t
429                ;; EQ base hash.
430                ;; Enable GC tricks.
431                (set-header-data kv-vector sb!vm:vector-valid-hashing-subtype)
432                (let* ((hashing (pointer-hash key))
433                       (index (rem hashing length))
434                       (next (aref index-vector index)))
435                  (declare (type index index)
436                           (type hash hashing))
437                  ;; Push this slot into the next chain.
438                  (setf (aref next-vector i) next)
439                  (setf (aref index-vector index) i)))))))
440   (values))
441
442 (defun flush-needing-rehash (table)
443   (let* ((kv-vector (hash-table-table table))
444          (index-vector (hash-table-index-vector table))
445          (next-vector (hash-table-next-vector table))
446          (length (length index-vector)))
447     (do ((next (hash-table-needing-rehash table)))
448         ((zerop next))
449       (declare (type index/2 next))
450       (let* ((key (aref kv-vector (* 2 next)))
451              (hashing (pointer-hash key))
452              (index (rem hashing length))
453              (temp (aref next-vector next)))
454         (setf (aref next-vector next) (aref index-vector index))
455         (setf (aref index-vector index) next)
456         (setf next temp))))
457   (setf (hash-table-needing-rehash table) 0)
458   (values))
459
460 (defun gethash (key hash-table &optional default)
461   #!+sb-doc
462   "Finds the entry in HASH-TABLE whose key is KEY and returns the associated
463    value and T as multiple values, or returns DEFAULT and NIL if there is no
464    such entry. Entries can be added using SETF."
465   (declare (type hash-table hash-table)
466            (values t (member t nil)))
467   (gethash3 key hash-table default))
468
469 (defun gethash2 (key hash-table)
470   #!+sb-doc
471   "Two argument version of GETHASH"
472   (declare (type hash-table hash-table)
473            (values t (member t nil)))
474   (gethash3 key hash-table nil))
475
476 (defun gethash3 (key hash-table default)
477   #!+sb-doc
478   "Three argument version of GETHASH"
479   (declare (type hash-table hash-table)
480            (values t (member t nil)))
481   (with-spinlock-and-without-gcing ((hash-table-spinlock hash-table))
482    (cond ((= (get-header-data (hash-table-table hash-table))
483              sb!vm:vector-must-rehash-subtype)
484           (rehash-without-growing hash-table))
485          ((not (zerop (hash-table-needing-rehash hash-table)))
486           (flush-needing-rehash hash-table)))
487
488    ;; First check the cache.  Use EQ here for speed.
489    (let ((cache (hash-table-cache hash-table))
490          (table (hash-table-table hash-table)))
491
492      (if (and cache (< cache (length table)) (eq (aref table cache) key))
493          (values (aref table (1+ cache)) t)
494
495        ;; Search for key in the hash table.
496        (multiple-value-bind (hashing eq-based)
497            (funcall (hash-table-hash-fun hash-table) key)
498          (declare (type hash hashing))
499          (let* ((index-vector (hash-table-index-vector hash-table))
500                 (length (length index-vector))
501                 (index (rem hashing length))
502                 (next (aref index-vector index))
503                 (next-vector (hash-table-next-vector hash-table))
504                 (hash-vector (hash-table-hash-vector hash-table))
505                 (test-fun (hash-table-test-fun hash-table)))
506            (declare (type index index))
507            ;; Search next-vector chain for a matching key.
508            (if (or eq-based (not hash-vector))
509                (do ((next next (aref next-vector next)))
510                    ((zerop next) (values default nil))
511                  (declare (type index/2 next))
512                  (when (eq key (aref table (* 2 next)))
513                    (setf (hash-table-cache hash-table) (* 2 next))
514                    (return (values (aref table (1+ (* 2 next))) t))))
515              (do ((next next (aref next-vector next)))
516                  ((zerop next) (values default nil))
517                (declare (type index/2 next))
518                (when (and (= hashing (aref hash-vector next))
519                           (funcall test-fun key (aref table (* 2 next))))
520                  ;; Found.
521                  (setf (hash-table-cache hash-table) (* 2 next))
522                  (return (values (aref table (1+ (* 2 next))) t)))))))))))
523
524 ;;; so people can call #'(SETF GETHASH)
525 (defun (setf gethash) (new-value key table &optional default)
526   (declare (ignore default))
527   (%puthash key table new-value))
528
529 (defun %puthash (key hash-table value)
530   (declare (type hash-table hash-table))
531   (aver (hash-table-index-vector hash-table))
532   (with-spinlock-and-without-gcing ((hash-table-spinlock hash-table))
533    ;; We need to rehash here so that a current key can be found if it
534    ;; exists. Check that there is room for one more entry. May not be
535    ;; needed if the key is already present.
536    (cond ((zerop (hash-table-next-free-kv hash-table))
537           (rehash hash-table))
538          ((= (get-header-data (hash-table-table hash-table))
539              sb!vm:vector-must-rehash-subtype)
540           (rehash-without-growing hash-table))
541          ((not (zerop (hash-table-needing-rehash hash-table)))
542           (flush-needing-rehash hash-table)))
543
544    (let ((cache (hash-table-cache hash-table))
545          (kv-vector (hash-table-table hash-table)))
546
547      ;; Check the cache
548      (if (and cache (< cache (length kv-vector))
549               (eq (aref kv-vector cache) key))
550          ;; If cached, just store here
551          (setf (aref kv-vector (1+ cache)) value)
552
553        ;; Search for key in the hash table.
554        (multiple-value-bind (hashing eq-based)
555            (funcall (hash-table-hash-fun hash-table) key)
556          (declare (type hash hashing))
557          (let* ((index-vector (hash-table-index-vector hash-table))
558                 (length (length index-vector))
559                 (index (rem hashing length))
560                 (next (aref index-vector index))
561                 (kv-vector (hash-table-table hash-table))
562                 (next-vector (hash-table-next-vector hash-table))
563                 (hash-vector (hash-table-hash-vector hash-table))
564                 (test-fun (hash-table-test-fun hash-table)))
565            (declare (type index index next))
566            (when (hash-table-weakness hash-table)
567              (set-header-data kv-vector sb!vm:vector-valid-hashing-subtype))
568            (cond ((or eq-based (not hash-vector))
569                   (when eq-based
570                     (set-header-data kv-vector
571                                      sb!vm:vector-valid-hashing-subtype))
572
573                   ;; Search next-vector chain for a matching key.
574                   (do ((next next (aref next-vector next)))
575                       ((zerop next))
576                     (declare (type index/2 next))
577                     (when (eq key (aref kv-vector (* 2 next)))
578                       ;; Found, just replace the value.
579                       (setf (hash-table-cache hash-table) (* 2 next))
580                       (setf (aref kv-vector (1+ (* 2 next))) value)
581                       (return-from %puthash value))))
582                  (t
583                   ;; Search next-vector chain for a matching key.
584                   (do ((next next (aref next-vector next)))
585                       ((zerop next))
586                     (declare (type index/2 next))
587                     (when (and (= hashing (aref hash-vector next))
588                                (funcall test-fun key
589                                         (aref kv-vector (* 2 next))))
590                       ;; Found, just replace the value.
591                       (setf (hash-table-cache hash-table) (* 2 next))
592                       (setf (aref kv-vector (1+ (* 2 next))) value)
593                       (return-from %puthash value)))))
594
595            ;; Pop a KV slot off the free list
596            (let ((free-kv-slot (hash-table-next-free-kv hash-table)))
597              (declare (type index/2 free-kv-slot))
598              ;; Double-check for overflow.
599              (aver (not (zerop free-kv-slot)))
600              (setf (hash-table-next-free-kv hash-table)
601                    (aref next-vector free-kv-slot))
602              (incf (hash-table-number-entries hash-table))
603
604              (setf (hash-table-cache hash-table) (* 2 free-kv-slot))
605              (setf (aref kv-vector (* 2 free-kv-slot)) key)
606              (setf (aref kv-vector (1+ (* 2 free-kv-slot))) value)
607
608              ;; Setup the hash-vector if necessary.
609              (when hash-vector
610                (if (not eq-based)
611                    (setf (aref hash-vector free-kv-slot) hashing)
612                    (aver (= (aref hash-vector free-kv-slot)
613                             +magic-hash-vector-value+))))
614
615              ;; Push this slot into the next chain.
616              (setf (aref next-vector free-kv-slot) next)
617              (setf (aref index-vector index) free-kv-slot)))))))
618   value)
619
620 (defun remhash (key hash-table)
621   #!+sb-doc
622   "Remove the entry in HASH-TABLE associated with KEY. Return T if there
623    was such an entry, or NIL if not."
624   (declare (type hash-table hash-table)
625            (values (member t nil)))
626   (with-spinlock-and-without-gcing ((hash-table-spinlock hash-table))
627    ;; We need to rehash here so that a current key can be found if it
628    ;; exists.
629    (cond ((= (get-header-data (hash-table-table hash-table))
630              sb!vm:vector-must-rehash-subtype)
631           (rehash-without-growing hash-table))
632          ((not (zerop (hash-table-needing-rehash hash-table)))
633           (flush-needing-rehash hash-table)))
634
635    ;; For now, just clear the cache
636    (setf (hash-table-cache hash-table) nil)
637
638    ;; Search for key in the hash table.
639    (multiple-value-bind (hashing eq-based)
640        (funcall (hash-table-hash-fun hash-table) key)
641      (declare (type hash hashing))
642      (let* ((index-vector (hash-table-index-vector hash-table))
643             (length (length index-vector))
644             (index (rem hashing length))
645             (next (aref index-vector index))
646             (table (hash-table-table hash-table))
647             (next-vector (hash-table-next-vector hash-table))
648             (hash-vector (hash-table-hash-vector hash-table))
649             (test-fun (hash-table-test-fun hash-table)))
650        (declare (type index index)
651                 (type index/2 next))
652        (flet ((clear-slot (chain-vector prior-slot-location slot-location)
653                 (declare (type index/2 slot-location))
654                 ;; Mark slot as empty.
655                 (setf (aref table (* 2 slot-location)) +empty-ht-slot+
656                       (aref table (1+ (* 2 slot-location))) +empty-ht-slot+)
657                 ;; Update the prior pointer in the chain to skip this.
658                 (setf (aref chain-vector prior-slot-location)
659                       (aref next-vector slot-location))
660                 ;; Push KV slot onto free chain.
661                 (setf (aref next-vector slot-location)
662                       (hash-table-next-free-kv hash-table))
663                 (setf (hash-table-next-free-kv hash-table) slot-location)
664                 (when hash-vector
665                   (setf (aref hash-vector slot-location)
666                         +magic-hash-vector-value+))
667                 (decf (hash-table-number-entries hash-table))
668                 t))
669          (cond ((zerop next)
670                 nil)
671                ((if (or eq-based (not hash-vector))
672                     (eq key (aref table (* 2 next)))
673                     (and (= hashing (aref hash-vector next))
674                          (funcall test-fun key (aref table (* 2 next)))))
675                 (clear-slot index-vector index next))
676                ;; Search next-vector chain for a matching key.
677                ((or eq-based (not hash-vector))
678                 ;; EQ based
679                 (do ((prior next next)
680                      (next (aref next-vector next) (aref next-vector next)))
681                     ((zerop next) nil)
682                   (declare (type index next))
683                   (when (eq key (aref table (* 2 next)))
684                     (return-from remhash (clear-slot next-vector prior next)))))
685                (t
686                 ;; not EQ based
687                 (do ((prior next next)
688                      (next (aref next-vector next) (aref next-vector next)))
689                     ((zerop next) nil)
690                   (declare (type index/2 next))
691                   (when (and (= hashing (aref hash-vector next))
692                              (funcall test-fun key (aref table (* 2 next))))
693                     (return-from remhash
694                       (clear-slot next-vector prior next)))))))))))
695
696 (defun clrhash (hash-table)
697   #!+sb-doc
698   "This removes all the entries from HASH-TABLE and returns the hash table
699    itself."
700   (declare (optimize speed))
701   (with-spinlock-and-without-gcing ((hash-table-spinlock hash-table))
702     (let* ((kv-vector (hash-table-table hash-table))
703            (next-vector (hash-table-next-vector hash-table))
704            (hash-vector (hash-table-hash-vector hash-table))
705            (size (length next-vector))
706            (index-vector (hash-table-index-vector hash-table)))
707       ;; Disable GC tricks.
708       (set-header-data kv-vector sb!vm:vector-normal-subtype)
709       ;; Mark all slots as empty by setting all keys and values to magic
710       ;; tag.
711       (aver (eq (aref kv-vector 0) hash-table))
712       (fill kv-vector +empty-ht-slot+ :start 2)
713       ;; Set up the free list, all free.
714       (do ((i 1 (1+ i)))
715           ((>= i (1- size)))
716         (setf (aref next-vector i) (1+ i)))
717       (setf (aref next-vector (1- size)) 0)
718       (setf (hash-table-next-free-kv hash-table) 1)
719       (setf (hash-table-needing-rehash hash-table) 0)
720       ;; Clear the index-vector.
721       (fill index-vector 0)
722       ;; Clear the hash-vector.
723       (when hash-vector
724         (fill hash-vector +magic-hash-vector-value+)))
725     (setf (hash-table-cache hash-table) nil)
726     (setf (hash-table-number-entries hash-table) 0))
727   hash-table)
728 \f
729 ;;;; MAPHASH
730
731 ;;; FIXME: This should be made into a compiler transform for two reasons:
732 ;;;   1. It would then be available for compiling the entire system,
733 ;;;      not only parts of the system which are defined after DEFUN MAPHASH.
734 ;;;   2. It could be conditional on compilation policy, so that
735 ;;;      it could be compiled as a full call instead of an inline
736 ;;;      expansion when SPACE>SPEED.
737 (declaim (inline maphash))
738 (defun maphash (function-designator hash-table)
739   #!+sb-doc
740   "For each entry in HASH-TABLE, call the designated two-argument function on
741 the key and value of the entry. Return NIL."
742   ;; This essentially duplicates WITH-HASH-TABLE-ITERATOR, so
743   ;; any changes here should be reflected there as well.
744   (let ((fun (%coerce-callable-to-fun function-designator))
745         (size (length (hash-table-next-vector hash-table))))
746     (declare (type function fun))
747     (do ((i 1 (1+ i)))
748         ((>= i size))
749       (declare (type index/2 i))
750       (let* ((kv-vector (hash-table-table hash-table))
751              (key (aref kv-vector (* 2 i)))
752              (value (aref kv-vector (1+ (* 2 i)))))
753         ;; We are running without locking or WITHOUT-GCING. For a weak
754         ;; :VALUE hash table it's possible that the GC hit after KEY
755         ;; was read and now the entry is gone. So check if either the
756         ;; key or the value is empty.
757         (unless (or (eq key +empty-ht-slot+)
758                     (eq value +empty-ht-slot+))
759           (funcall fun key value))))))
760 \f
761 ;;;; methods on HASH-TABLE
762
763 ;;; Return a list of keyword args and values to use for MAKE-HASH-TABLE
764 ;;; when reconstructing HASH-TABLE.
765 (defun %hash-table-ctor-args (hash-table)
766   `(:test             ',(hash-table-test             hash-table)
767     :size             ',(hash-table-size             hash-table)
768     :rehash-size      ',(hash-table-rehash-size      hash-table)
769     :rehash-threshold ',(hash-table-rehash-threshold hash-table)
770     :weakness         ',(hash-table-weakness         hash-table)))
771
772 ;;; Return an association list representing the same data as HASH-TABLE.
773 (defun %hash-table-alist (hash-table)
774   (let ((result nil))
775     (maphash (lambda (key value)
776                (push (cons key value) result))
777              hash-table)
778     result))
779
780 ;;; Stuff an association list into HASH-TABLE. Return the hash table,
781 ;;; so that we can use this for the *PRINT-READABLY* case in
782 ;;; PRINT-OBJECT (HASH-TABLE T) without having to worry about LET
783 ;;; forms and readable gensyms and stuff.
784 (defun %stuff-hash-table (hash-table alist)
785   (dolist (x alist)
786     (setf (gethash (car x) hash-table) (cdr x)))
787   hash-table)
788
789 (def!method print-object ((hash-table hash-table) stream)
790   (declare (type stream stream))
791   (cond ((or (not *print-readably*) (not *read-eval*))
792          (print-unreadable-object (hash-table stream :type t :identity t)
793            (format stream
794                    ":TEST ~S :COUNT ~S"
795                    (hash-table-test hash-table)
796                    (hash-table-count hash-table))))
797         (t
798          (with-standard-io-syntax
799           (format stream
800                   "#.~W"
801                   `(%stuff-hash-table (make-hash-table ,@(%hash-table-ctor-args
802                                                           hash-table))
803                                      ',(%hash-table-alist hash-table)))))))
804
805 (def!method make-load-form ((hash-table hash-table) &optional environment)
806   (declare (ignore environment))
807   (values `(make-hash-table ,@(%hash-table-ctor-args hash-table))
808           `(%stuff-hash-table ,hash-table ',(%hash-table-alist hash-table))))