index-into-sequence-derive-type: handle more complicated types.
[sbcl.git] / src / code / target-hash-table.lisp
blob715d2e61ecb6d4fad96de280935d5e9e4a4635a8
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
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.
13 (in-package "SB-IMPL")
16 (!begin-collecting-cold-init-forms)
18 ;;;; utilities
20 ;;;; TODOs:
21 ;;;; - change recursive locks to nonrecursive.
22 ;;;; This will, I fear, be impossible because we've exposed and documented
23 ;;;; an API that pretty much tells users that it's ok to create a synchronized
24 ;;;; table while *also* wrapping any random operation in the table lock.
25 ;;;; Hence recursion on the lock. (commit b9a1b17b079d315c)
26 ;;;; - place the 3 or 4 vectors in a separate structure that can be atomically
27 ;;;; swapped out for a new instance with new vectors. Remove array bounds
28 ;;;; checking since all the arrays will be tied together.
29 ;;;; - As a consequence of change 3bdd4d28ed, the compiler started to
30 ;;;; emit multiple definitions of certain INLINE global functions.
31 ;;;; Just referencing #'INLINED-FOO can cause genesis failures.
33 ;;; T if and only if table has non-null weakness kind.
34 (declaim (inline hash-table-weak-p))
35 (defun hash-table-weak-p (ht)
36 (logtest (hash-table-flags ht) hash-table-weak-flag))
38 ;;; Value of :synchronized constructor argument.
39 (declaim (inline hash-table-synchronized-p))
40 (defun hash-table-synchronized-p (ht)
41 (logtest (hash-table-flags ht) hash-table-synchronized-flag))
43 ;;; Keep in sync with weak_ht_alivep_funs[] in gc-common
44 (declaim (inline decode-hash-table-weakness))
45 (defun decode-hash-table-weakness (x)
46 ;; The bits of 'weakness' are interpreted as follows:
47 ;; bit 0 : live key forces value to be live
48 ;; bit 1 : live value forces key to be live
49 ;; both : either forces the other to be live
50 ;; :KEY-AND-VALUE has two zero bits, as neither object livens the other
51 (aref #(:key-and-value :key :value :key-or-value) x))
53 ;;; Non-NIL if this is some kind of weak hash table. For details see
54 ;;; the docstring of MAKE-HASH-TABLE.
55 (defun hash-table-weakness (ht)
56 "Return the WEAKNESS of HASH-TABLE which is one of NIL, :KEY,
57 :VALUE, :KEY-AND-VALUE, :KEY-OR-VALUE."
58 (and (hash-table-weak-p ht)
59 (decode-hash-table-weakness (ht-flags-weakness (hash-table-flags ht)))))
61 ;;; On 32-bit machines, the hashes are positive fixnums, but on
62 ;;; 64-bit, we use 2 more bits though must avoid conflict with
63 ;;; +MAGIC-HASH-VECTOR-VALUE+, which denotes an address-based hash in
64 ;;; HASH-TABLE-HASH-VECTOR.
65 (deftype clipped-hash () '(unsigned-byte #.+max-hash-table-bits+))
67 (declaim (inline clip-hash))
68 (defun clip-hash (hash)
69 (ldb (byte #.+max-hash-table-bits+ 0) hash))
71 (declaim (inline mask-hash))
72 (defun mask-hash (hash mask)
73 (truly-the index (logand mask hash)))
75 ;;; We're using power of two tables which obviously are very sensitive
76 ;;; to the entropy in the low bits in the hash value. We used to
77 ;;; indiscriminately apply PREFUZZ-HASH to the hash value returned by
78 ;;; the real hash function to mix in the high bits. This was
79 ;;; unnecessary and wasteful, so now we only CLIP-HASH. Still, let's
80 ;;; keep this function around for a while in case we find that some
81 ;;; hash functions (e.g. user provided ones) need it.
82 (declaim (inline prefuzz-hash))
83 (defun prefuzz-hash (hash)
84 (clip-hash (+ (logxor #b11100101010001011010100111 hash)
85 (ash hash -3)
86 (ash hash -12)
87 (ash hash -20))))
90 ;;; EQ hash functions
92 ;;; Define an inline function called NAME, which takes a single KEY
93 ;;; argument and returns 1. its CLIPPED-HASH and 2. whether the hash
94 ;;; is address-based. This requires a call to CLIP-HASH, which may be
95 ;;; unnecessary if the hash is then masked (e.g. to (1- N-BUCKETS))
96 ;;; anyway.
97 ;;;
98 ;;; For this reason, another function called NAME* is defined, which
99 ;;; does not clip the hash and may even return a bignum.
100 (defmacro define-eq-hash ((name name*) (address) &body body)
101 (with-unique-names (key)
102 `(progn
103 (declaim (ftype (sfunction (t) (values clipped-hash boolean)) ,name))
104 (declaim (inline ,name))
105 (defun ,name (,key)
106 (declare (optimize (sb-c:verify-arg-count 0)))
107 ;; It would be ok to pick off SYMBOL here and use its hash
108 ;; slot as far as semantics are concerned, but EQ-hash is
109 ;; supposed to be the lightest-weight in terms of speed, so
110 ;; I'm letting everything use address-based hashing, unlike
111 ;; the other standard hash-table hash functions which try use
112 ;; the hash slot of certain objects. Note also that as we add
113 ;; logic into the EQ-HASH function to decide whether the hash
114 ;; is address-based, we either have to replicate that logic
115 ;; into rehashing, or else actually call EQ-HASH to decide
116 ;; for us. -- DK, 2019-06-22
118 ;; Use GET-LISP-OBJ-ADDRESS instead of POINTER-HASH so that
119 ;; BODY can work with an unboxed word and perhaps be a bit
120 ;; faster as a result. Also, we get a bit tighter code with a
121 ;; symbol macrolet compared to binding HASH to
122 ;; (GET-LISP-OBJ-ADDRESS KEY).
123 (symbol-macrolet ((,address (get-lisp-obj-address ,key)))
124 (values (clip-hash (ldb (byte #.sb-vm:n-word-bits 0) (progn ,@body)))
125 (sb-vm:is-lisp-pointer (get-lisp-obj-address ,key)))))
126 (declaim (inline ,name*))
127 (defun ,name* (,key)
128 (symbol-macrolet ((,address (get-lisp-obj-address ,key)))
129 (values (ldb (byte #.sb-vm:n-word-bits 0) (progn ,@body))
130 (sb-vm:is-lisp-pointer (get-lisp-obj-address ,key))))))))
132 ;;; This is equivalent to the old way of calling PREFUZZ-HASH on
133 ;;; POINTER-HASH because HASH from GET-LISP-OBJ-ADDRESS is shifted
134 ;;; here an extra SB-VM:N-FIXNUM-TAG-BITS.
135 (define-eq-hash (eq-hash eq-hash*) (address)
136 (+ (logxor #b11100101010001011010100111
137 (ash address #.(- sb-vm:n-fixnum-tag-bits)))
138 (ash address #.(- (+ 3 sb-vm:n-fixnum-tag-bits)))
139 (ash address #.(- (+ 12 sb-vm:n-fixnum-tag-bits)))
140 (ash address #.(- (+ 20 sb-vm:n-fixnum-tag-bits)))))
143 (declaim (ftype (sfunction (t) (values fixnum boolean))
144 eql-hash equal-hash equalp-hash))
146 ;;; Note: We could somewhat easily add SAP-WIDETAG into the list of types
147 ;;; that get a stable hash for EQL tables (via SAP-HASH), however:
148 ;;; - we don't compare SAPs with SAP= when the table's test is EQL,
149 ;;; so there is no real advantage (nor requirement) to have a hash
150 ;;; derived from the object's contents.
151 ;;; - I don't imagine that users often store SAPs in hash-tables.
152 (declaim (inline eql-hash))
153 (defun eql-hash (key)
154 (declare (values fixnum boolean))
155 (if (%other-pointer-subtype-p
157 ;; SYMBOL is listed here so that we can hash symbols address-insensitively.
158 ;; We have to pick off a bunch of OTHER-POINTER objects anyway, so there
159 ;; no overhead to extending the widetag range by 1 widetag.
160 '#.(list sb-vm:bignum-widetag sb-vm:ratio-widetag sb-vm:double-float-widetag
161 sb-vm:single-float-widetag
162 sb-vm:complex-rational-widetag sb-vm:complex-single-float-widetag
163 sb-vm:complex-double-float-widetag
164 sb-vm:symbol-widetag))
165 ;; NON-NULL-SYMBOL-P skips a test for NIL which is sensible, and we're
166 ;; excluding NIL anyway because it's not an OTHER-POINTER.
167 ;; To produce the best code for NON-NULL-SYMBOL-P (omitting a lowtag test)
168 ;; we need to force the compiler to see that KEY is definitely an
169 ;; OTHER-POINTER (cf OTHER-POINTER-TN-REF-P) because %OTHER-POINTER-SUBTYPE-P
170 ;; doesn't suffice, though it would be nice if it did.
171 (values (clip-hash
172 (if (non-null-symbol-p
173 (truly-the (or (and number (not fixnum) #+64-bit (not single-float))
174 (and symbol (not null)))
175 key))
176 (symbol-hash (truly-the symbol key))
177 (number-sxhash (truly-the number key))))
178 nil)
179 ;; Consider picking off %INSTANCEP too before using EQ-HASH ?
180 (eq-hash key)))
182 ;;; Decide if WIDETAG (an OTHER-POINTER) should use SXHASH in EQUAL-HASH
183 (defmacro equal-hash-sxhash-widetag-p (widetag)
184 (let ((list `(,sb-vm:simple-base-string-widetag
185 #+sb-unicode ,sb-vm:simple-character-string-widetag
186 ,sb-vm:complex-base-string-widetag
187 #+sb-unicode ,sb-vm:complex-character-string-widetag
188 ,sb-vm:bignum-widetag
189 ,sb-vm:ratio-widetag
190 ,sb-vm:double-float-widetag
191 ,sb-vm:complex-rational-widetag
192 ,sb-vm:complex-single-float-widetag
193 ,sb-vm:complex-double-float-widetag
194 ,sb-vm:simple-bit-vector-widetag
195 ,sb-vm:complex-bit-vector-widetag)))
196 (let ((mask 0))
197 (dolist (i list mask)
198 (setf mask (logior mask (ash 1 (ash i -2)))))
199 #+64-bit `(logbitp (ash ,widetag -2) ,mask)
200 #-64-bit `(let ((bit (ash ,widetag -2)))
201 (if (<= bit 31)
202 (logbitp bit ,(ldb (byte 32 0) mask))
203 (logbitp (- bit 32) ,(ash mask -32)))))))
205 ;;; As a consequence of change 3bdd4d28ed, the compiler started to emit multiple
206 ;;; definitions of certain INLINE global functions.
207 ;;; Genesis is so fraught with other pitfalls and traps that I want no chance
208 ;;; of seeing duplicate definitions. So no INLINE here. Tail wagging the dog?
209 ;;; Perhaps, but that was an dangerous thing to sneakily allow.
210 ;; (declaim (inline equal-hash))
211 (defun equal-hash (key)
212 (declare (values fixnum boolean))
213 ;; Ultimately we just need to choose between SXHASH or EQ-HASH. As to using
214 ;; INSTANCE-SXHASH, it doesn't matter, and in fact it's quicker to use EQ-HASH.
215 ;; If the outermost object passed as a key is LIST, then it descends using SXHASH,
216 ;; you will in fact get stable hashes for nested objects.
217 (if (case (lowtag-of key)
218 (#.sb-vm:list-pointer-lowtag t)
219 ;; pathnames require SXHASH, all other instances are indifferent.
220 (#.sb-vm:instance-pointer-lowtag (pathnamep (truly-the instance key)))
221 (#.sb-vm:other-pointer-lowtag
222 (if (= (%other-pointer-widetag key) sb-vm:symbol-widetag)
223 (return-from equal-hash
224 (values (clip-hash (symbol-hash (truly-the symbol key))) nil))
225 (equal-hash-sxhash-widetag-p (%other-pointer-widetag key)))))
226 (values (clip-hash (sxhash key)) nil)
227 (eq-hash key)))
229 (defun equalp-hash (key)
230 (declare (values fixnum boolean))
231 (typecase key
232 ;; Types requiring special treatment. Note that PATHNAME and
233 ;; HASH-TABLE are caught by the STRUCTURE-OBJECT test.
234 ((or array cons number character structure-object)
235 (values (clip-hash (psxhash key)) nil))
236 (symbol (values (clip-hash (symbol-hash key)) nil))
237 ;; INSTANCE at this point means STANDARD-OBJECT and CONDITION,
238 ;; since STRUCTURE-OBJECT is recursed into by PSXHASH.
239 (instance (values (clip-hash (instance-sxhash key)) nil))
241 (eq-hash key))))
243 ;;;; user-defined hash table tests
245 (define-load-time-global *user-hash-table-tests* nil)
247 (defun register-hash-table-test (name hash-fun)
248 (declare (symbol name) (function hash-fun))
249 (unless (fboundp name)
250 (error "Cannot register ~S has a hash table test: undefined function."
251 name))
252 (with-single-package-locked-error
253 (:symbol name "defining ~S as a hash table test")
254 (let* ((test-fun (fdefinition name))
255 (this (list name test-fun hash-fun))
256 (spec (assoc name *user-hash-table-tests*)))
257 (cond (spec
258 (unless (and (eq (second spec) test-fun)
259 (eq (third spec) hash-fun))
260 (style-warn "Redefining hash table test ~S." name)
261 (setf (cdr spec) (cdr this))))
263 (push this *user-hash-table-tests*)))))
264 name)
266 (defmacro define-hash-table-test (name hash-function)
267 "Defines NAME as a new kind of hash table test for use with the :TEST
268 argument to MAKE-HASH-TABLE, and associates a default HASH-FUNCTION with it.
270 NAME must be a symbol naming a global two argument equivalence predicate.
271 Afterwards both 'NAME and #'NAME can be used with :TEST argument. In both
272 cases HASH-TABLE-TEST will return the symbol NAME.
274 HASH-FUNCTION must be a symbol naming a global hash function consistent with
275 the predicate, or be a LAMBDA form implementing one in the current lexical
276 environment. The hash function must compute the same hash code for any two
277 objects for which NAME returns true, and subsequent calls with already hashed
278 objects must always return the same hash code.
280 Note: The :HASH-FUNCTION keyword argument to MAKE-HASH-TABLE can be used to
281 override the specified default hash-function.
283 Attempting to define NAME in a locked package as hash-table test causes a
284 package lock violation.
286 Examples:
288 ;;; 1.
290 ;; We want to use objects of type FOO as keys (by their
291 ;; names.) EQUALP would work, but would make the names
292 ;; case-insensitive -- which we don't want.
293 (defstruct foo (name nil :type (or null string)))
295 ;; Define an equivalence test function and a hash function.
296 (defun foo-name= (f1 f2) (equal (foo-name f1) (foo-name f2)))
297 (defun sxhash-foo-name (f) (sxhash (foo-name f)))
299 (define-hash-table-test foo-name= sxhash-foo-name)
301 ;; #'foo-name would work too.
302 (defun make-foo-table () (make-hash-table :test 'foo-name=))
304 ;;; 2.
306 (defun == (x y) (= x y))
308 (define-hash-table-test ==
309 (lambda (x)
310 ;; Hash codes must be consistent with test, so
311 ;; not (SXHASH X), since
312 ;; (= 1 1.0) => T
313 ;; (= (SXHASH 1) (SXHASH 1.0)) => NIL
314 ;; Note: this doesn't deal with complex numbers or
315 ;; bignums too large to represent as double floats.
316 (sxhash (coerce x 'double-float))))
318 ;; #'== would work too
319 (defun make-number-table () (make-hash-table :test '==))
321 (check-type name symbol)
322 (if (member name '(eq eql equal equalp))
323 (error "Cannot redefine standard hash table test ~S." name)
324 (cond ((symbolp hash-function)
325 `(register-hash-table-test ',name (symbol-function ',hash-function)))
326 ((and (consp hash-function) (eq 'lambda (car hash-function)))
327 `(register-hash-table-test ',name #',hash-function))
329 (error "Malformed HASH-FUNCTION: ~S" hash-function)))))
331 ;;;; construction and simple accessors
333 ;;; The smallest table holds 7 items distributed among 8 buckets. So
334 ;;; we allocate 7 k/v pairs = 14 cells + 3 overhead = 17 cells, and at
335 ;;; maximum load the table will have a load factor of 87.5%
336 (defconstant kv-pairs-overhead-slots 3)
337 (defconstant bad-next-value #xfefefefe)
338 ;;; This constant is referenced via its name in cold load, so it needs to
339 ;;; be evaluable in the host.
340 (defconstant +min-hash-table-rehash-threshold+ #.(sb-xc:float 1/16 1.0))
342 ;; The GC will set this to 1 if it moves an address-sensitive key. This used
343 ;; to be signaled by a bit in the header of the kv vector, but that
344 ;; implementation caused some concurrency issues when we stopped
345 ;; inhibiting GC during hash-table lookup.
347 ;; This indicator properly belongs to the k/v vector for at least 2 reasons:
348 ;; - if the vector is on an already-written page but the table is not,
349 ;; it avoids a write fault when setting to true. This a boon to gencgc
350 ;; - if there were lock-free tables - which presumably operate by atomically
351 ;; changing out the vector for a new one - whether the vector is bucketized
352 ;; correctly after GC is an aspect of the vector, not the table
354 ;; We could do it with a single bit by implementing vops for atomic
355 ;; read/modify/write on the header. In C there's sync_or_and_fetch, etc.
356 (defconstant rehash-stamp-elt 1)
357 (defmacro kv-vector-rehash-stamp (vector) `(truly-the fixnum (svref ,vector 1)))
358 (defconstant kv-vector-rehashing 2)
360 ;;; The 'supplement' points to the hash-table if the table is weak,
361 ;;; or to the hash vector if the table is not weak.
362 ;;; Other possible values are NIL for an EQ table, or T for an EQL table.
363 ;;; For a concurrent GC, this element will not require a read barrier because
364 ;;; it must be treated as a strong reference even if the vector is weak.
365 (defmacro kv-vector-supplement (pairs)
366 `(svref ,pairs (1- (length ,pairs))))
368 (declaim (inline set-kv-hwm)) ; can't setf data-vector-ref
369 (defun set-kv-hwm (vector hwm) (setf (svref vector 0) hwm))
370 (defsetf kv-vector-high-water-mark set-kv-hwm)
372 ;;; Make a new key/value vector. Weak tables do not mark the vector as weak
373 ;;; initially, because the vector can't hold a backpointer to the table
374 ;;; since the table hasn't been made yet. (GC asserts that every weak hash-table
375 ;;; storage vector has a table pointer - no exceptions)
376 ;;; Also we can't set the HASHING bit in the header until the vector is prepared,
377 ;;; but if GC occurs meanwhile, it must not move this to a purely boxed page.
378 ;;; But we can set the ALLOC-MIXED bit. That's what it's there for.
379 (defmacro %alloc-kv-pairs (size)
380 `(let* ((nwords
381 (truly-the index (+ (* 2 (truly-the index/2 ,size))
382 ,kv-pairs-overhead-slots)))
383 (v (truly-the simple-vector
384 (allocate-vector (logior sb-vm::+vector-alloc-mixed-region-bit+
385 sb-vm:simple-vector-widetag)
386 nwords nwords))))
387 (declare (optimize (sb-c:insert-array-bounds-checks 0)))
388 (fill v (make-unbound-marker))
389 (setf (kv-vector-high-water-mark v) 0)
390 (setf (kv-vector-rehash-stamp v) 0)
391 ;; If GC observes VECTOR-HASHING-FLAG, it needs to see a valid value
392 ;; in the 'supplement' slot. Neither 0 nor +empty-ht-slot+ is valid.
393 ;; And if we ever get non-prezeroed-memory to work, this will be even more
394 ;; important to do things in the right order.
395 (setf (kv-vector-supplement v) nil)
396 (logior-array-flags v sb-vm:vector-hashing-flag)
399 (defun install-hash-table-lock (table)
400 (declare (inline sb-thread:make-mutex))
401 (let* ((lock (sb-thread:make-mutex :name "hash-table lock"))
402 (oldval (cas (hash-table-%lock (truly-the hash-table table)) nil lock)))
403 (if (eq oldval nil) lock oldval)))
405 (defconstant hash-table-kind-eq 0)
406 (defconstant hash-table-kind-eql 1)
407 (defconstant hash-table-kind-equal 2)
408 (defconstant hash-table-kind-equalp 3)
410 ;;; I don't want to change peoples' assumptions about what operations are threadsafe
411 ;;; on a weak table that was not created as expressly synchronized, so we continue to
412 ;;; create nearly all weak tables as synchronized. With such tables, lock acquisition
413 ;;; might be recursive, because we also told users that they can use
414 ;;; SB-EXT:WITH-LOCKED-HASH-TABLE even with tables that are self-locking.
415 ;;; This results in a really strange design in which it is exceptionally difficult
416 ;;; to plug in standard POSIX mutexes which do not default to being recursive.
417 ;;; To slightly mitigate the problem of assuming all mutexes should be recursive,
418 ;;; some of the system weak hash-table are frobbed to turn off SYNCHRONIZED.
419 ;;; Maybe I can figure out how to make concurrent weak GETHASH threadsafe,
420 ;;; but I've spent a bit of time on it and it is quite difficult.
422 (declaim (ftype (sfunction (t t t t t t t) (values hash-table))
423 %make-hash-table))
425 (defun make-hash-table (&key (test 'eql)
426 (size #.+min-hash-table-size+)
427 (rehash-size #.default-rehash-size)
428 (rehash-threshold 1)
429 (hash-function nil user-hashfun-p)
430 (weakness nil)
431 (synchronized))
432 "Create and return a new hash table. The keywords are as follows:
434 :TEST
435 Determines how keys are compared. Must a designator for one of the
436 standard hash table tests, or a hash table test defined using
437 SB-EXT:DEFINE-HASH-TABLE-TEST. Additionally, when an explicit
438 HASH-FUNCTION is provided (see below), any two argument equivalence
439 predicate can be used as the TEST.
441 :SIZE
442 A hint as to how many elements will be put in this hash table.
444 :REHASH-SIZE
445 Indicates how to expand the table when it fills up. If an integer, add
446 space for that many elements. If a floating point number (which must be
447 greater than 1.0), multiply the size by that amount.
449 :REHASH-THRESHOLD
450 Indicates how dense the table can become before forcing a rehash. Can be
451 any positive number <=1, with density approaching zero as the threshold
452 approaches 0. Density 1 means an average of one entry per bucket.
454 :HASH-FUNCTION
455 If unsupplied, a hash function based on the TEST argument is used,
456 which then must be one of the standardized hash table test functions, or
457 one for which a default hash function has been defined using
458 SB-EXT:DEFINE-HASH-TABLE-TEST. If HASH-FUNCTION is specified, the TEST
459 argument can be any two argument predicate consistent with it. The
460 HASH-FUNCTION is expected to return a non-negative fixnum hash code.
461 If TEST is neither standard nor defined by DEFINE-HASH-TABLE-TEST,
462 then the HASH-FUNCTION must be specified.
464 :WEAKNESS
465 When :WEAKNESS is not NIL, garbage collection may remove entries from the
466 hash table. The value of :WEAKNESS specifies how the presence of a key or
467 value in the hash table preserves their entries from garbage collection.
469 Valid values are:
471 :KEY means that the key of an entry must be live to guarantee that the
472 entry is preserved.
474 :VALUE means that the value of an entry must be live to guarantee that
475 the entry is preserved.
477 :KEY-AND-VALUE means that both the key and the value must be live to
478 guarantee that the entry is preserved.
480 :KEY-OR-VALUE means that either the key or the value must be live to
481 guarantee that the entry is preserved.
483 NIL (the default) means that entries are always preserved.
485 :SYNCHRONIZED
486 If NIL (the default), the hash-table may have multiple concurrent readers,
487 but results are undefined if a thread writes to the hash-table
488 concurrently with another reader or writer. If T, all concurrent accesses
489 are safe, but note that CLHS 3.6 (Traversal Rules and Side Effects)
490 remains in force. See also: SB-EXT:WITH-LOCKED-HASH-TABLE."
491 (declare (type (or function symbol) test))
492 (declare (type unsigned-byte size))
493 (multiple-value-bind (kind test test-fun hash-fun)
494 (cond ((or (eq test #'eq) (eq test 'eq))
495 (values 0 'eq #'eq #'eq-hash))
496 ((or (eq test #'eql) (eq test 'eql))
497 (values 1 'eql #'eql #'eql-hash))
498 ((or (eq test #'equal) (eq test 'equal))
499 (values 2 'equal #'equal #'equal-hash))
500 ((or (eq test #'equalp) (eq test 'equalp))
501 (values 3 'equalp #'equalp #'equalp-hash))
503 (dolist (info *user-hash-table-tests*
504 (flet ((proper-name (fun &aux (name (%fun-name fun)))
505 (if (and (symbolp name) (fboundp name) (eq (symbol-function name) fun))
506 name
507 fun)))
508 (if hash-function
509 (if (functionp test)
510 (values -1 (proper-name test) test nil)
511 (values -1 test (%coerce-callable-to-fun test) nil))
512 (error "Unknown :TEST for MAKE-HASH-TABLE: ~S" test))))
513 (destructuring-bind (test-name test-fun hash-fun) info
514 (when (or (eq test test-name) (eq test test-fun))
515 (return (values -1 test-name test-fun hash-fun)))))))
516 (when user-hashfun-p
517 ;; It is permitted to specify a custom hash function with any of the standard predicates.
518 ;; This forces use of the generalized table methods.
519 (setf hash-fun (%coerce-callable-to-fun hash-function)
520 kind -1))
521 (let* ((size (max +min-hash-table-size+
522 ;; Our table sizes are capped by the 32-bit integers used as indices
523 ;; into the chains. Prevent our code from failing if the user specified
524 ;; most-positive-fixnum here. (fndb says that size is 'unsigned-byte')
525 (min size (ash 1 24)))) ; 16M key/value pairs
526 (rehash-size (if (integerp rehash-size)
527 rehash-size
528 (float rehash-size 1.0))) ; always single-float
529 (rehash-threshold (max #.+min-hash-table-rehash-threshold+
530 (float rehash-threshold 1.0)))) ; always single-float
531 (%make-hash-table
532 ;; compute flags. The stored KIND bits don't matter for a user-supplied hash
533 ;; and/or test fun, however we don't want to imply that it is an EQ table
534 ;; because EQ tables don't get a hash-vector allocated.
535 (logior (if weakness
536 (or (loop for i below 4
537 when (eq (decode-hash-table-weakness i) weakness)
538 do (return (pack-ht-flags-weakness i)))
539 (unreachable))
541 (pack-ht-flags-kind (logand kind 3)) ; kind -1 becomes 3
542 (if (or weakness synchronized) hash-table-synchronized-flag 0)
543 (if (eql kind -1) hash-table-userfun-flag 0))
544 test test-fun hash-fun
545 size rehash-size rehash-threshold))))
547 (defmacro make-index-vector (n)
548 `(let ((a (make-array ,n :element-type 'hash-table-index
549 :initial-element 0)))
552 (defun validate-index-vector (tbl reason)
553 (let* ((iv (hash-table-index-vector tbl))
554 (pairs (hash-table-pairs tbl))
555 (npairs (length pairs)))
556 (dovector (indexval iv)
557 (when (> (* 2 indexval) npairs)
558 (bug "~a: Busted index vector on ~S, pairlen=~d 2*index=~d"
559 reason tbl npairs (* 2 indexval))))))
561 (defun %make-hash-table (flags test test-fun hash-fun size rehash-size rehash-threshold)
562 (declare (type single-float rehash-threshold))
563 (binding* (
564 ;; KLUDGE: The most natural way of expressing the below is
565 ;; (round (/ (float size) rehash-threshold)), and indeed
566 ;; it was expressed like that until 0.7.0. However,
567 ;; MAKE-HASH-TABLE is called very early in cold-init, and
568 ;; the SPARC has no primitive instructions for rounding,
569 ;; but only for truncating; therefore, we fudge this issue
570 ;; a little. The other uses of truncate, below, similarly
571 ;; used to be round. -- CSR, 2002-10-01
573 ;; Note that this has not yet been audited for
574 ;; correctness. It just seems to work. -- CSR, 2002-11-02
575 (scaled-size (truncate (/ (float size 1.0) rehash-threshold)))
576 (bucket-count (power-of-two-ceiling
577 (max scaled-size +min-hash-table-size+)))
578 (weakp (logtest flags hash-table-weak-flag))
579 ;; Non-weak tables created with no options other than :TEST
580 ;; are allocated at 0 size. Weak tables are complicated enough,
581 ;; so just do their usual thing.
582 (defaultp (and (not weakp) (= size +min-hash-table-size+)))
583 (index-vector
584 (if defaultp
585 #.(sb-xc:make-array 2 :element-type '(unsigned-byte 32)
586 :initial-element 0)
587 (make-index-vector bucket-count)))
588 (kv-vector (if defaultp #(0 0 nil) (%alloc-kv-pairs size)))
589 ;; Needs to be the half the length of the KV vector to link
590 ;; KV entries - mapped to indices at 2i and 2i+1 -
591 ;; together.
592 ;; We don't need this to be initially 0-filled, so don't specify
593 ;; an initial element (in case we ever meaningfully distinguish
594 ;; between don't-care and 0-fill)
595 (next-vector (if defaultp
596 #.(sb-xc:make-array 0 :element-type '(unsigned-byte 32))
597 (make-array (1+ size) :element-type 'hash-table-index
598 ;; For testing, preload huge values for all 'next' elements
599 ;; so that we generate an error if any is inadvertently read
600 ;; above the high-water-mark for the k/v vector.
601 #+sb-devel :initial-element #+sb-devel bad-next-value)))
602 (table-kind (ht-flags-kind flags))
603 (userfunp (logtest flags hash-table-userfun-flag))
604 ;; same here - don't care about initial contents
605 (hash-vector (when (or userfunp (>= table-kind 2))
606 (if defaultp
607 #.(sb-xc:make-array 1 :element-type '(unsigned-byte 32))
608 (make-array (1+ size) :element-type 'hash-table-index))))
609 ((getter setter remover)
610 (if weakp
611 (values #'gethash/weak #'puthash/weak #'remhash/weak)
612 (pick-table-methods (logtest flags hash-table-synchronized-flag)
613 (if userfunp -1 table-kind))))
614 (table
615 (funcall (if weakp #'%alloc-general-hash-table #'%alloc-hash-table)
616 flags getter setter remover #'clrhash-impl
617 test test-fun hash-fun
618 rehash-size rehash-threshold
619 kv-vector index-vector next-vector hash-vector)))
620 (declare (type index scaled-size))
621 ;; The trailing metadata element is either the table itself or the hash-vector
622 ;; depending on weakness. Non-weak hashing vectors can be GCed without looking
623 ;; at the table. Weak hashing vectors need the table.
624 ;; As a special-case, non-weak tables with EQL hashing put T in this slot.
625 ;; GC can't get the table kind since it doesn't have access to the table.
626 (cond (defaultp
627 ;; Stash the desired size for the first time the vectors are grown.
628 (setf (hash-table-cache table) (- size)
629 ;; Cause the overflow logic to be invoked on the first insert.
630 (hash-table-next-free-kv table) 0))
632 (setf (kv-vector-supplement kv-vector)
633 (if weakp
634 table
635 (or hash-vector (= table-kind hash-table-kind-eql))))
636 (when weakp
637 (logior-array-flags kv-vector (logior sb-vm:vector-hashing-flag
638 sb-vm:vector-weak-flag)))))
639 (when (logtest flags hash-table-synchronized-flag)
640 (install-hash-table-lock table))
641 table))
643 ;;; a "plain" hash-table has nothing fancy: default size, default growth rate,
644 ;;; not weak, not synchronized, not a user-defined hash fun and/or comparator.
645 (defun make-hash-table-using-defaults (kind)
646 (declare ((integer 0 3) kind))
647 (let ((test (aref #(eq eql equal equalp) kind)))
648 (declare (optimize (safety 0))) ; skip FBOUNDP checks
649 (let ((test-fun (symbol-function test))
650 (hash-fun (symbol-function
651 (aref #(eq-hash eql-hash equal-hash equalp-hash) kind))))
652 (%make-hash-table (pack-ht-flags-kind kind)
653 test test-fun hash-fun
654 +min-hash-table-size+
655 #.default-rehash-size
656 1.0)))) ; rehash threshold
658 ;;; We don't expose HASH-TABLE-%COUNT directly because it is SETFable.
659 (defun hash-table-count (hash-table)
660 "Return the number of entries in the given HASH-TABLE."
661 (declare (type hash-table hash-table)
662 (values index))
663 (hash-table-%count hash-table))
665 (setf (documentation 'hash-table-rehash-size 'function)
666 "Return the rehash-size HASH-TABLE was created with.")
668 (setf (documentation 'hash-table-rehash-threshold 'function)
669 "Return the rehash-threshold HASH-TABLE was created with.")
671 (setf (documentation 'hash-table-synchronized-p 'function)
672 "Returns T if HASH-TABLE is synchronized.")
674 (declaim (inline hash-table-pairs-capacity))
675 (defun hash-table-pairs-capacity (pairs)
676 (ash (- (length pairs) kv-pairs-overhead-slots) -1))
678 (defun hash-table-size (hash-table)
679 "Return a size that can be used with MAKE-HASH-TABLE to create a hash
680 table that can hold however many entries HASH-TABLE can hold without
681 having to be grown."
682 (let ((n (hash-table-pairs-capacity (hash-table-pairs hash-table))))
683 (if (= n 0) +min-hash-table-size+ n)))
685 (setf (documentation 'hash-table-test 'function)
686 "Return the test HASH-TABLE was created with.")
688 (defun signal-corrupt-hash-table (hash-table)
689 (error "Unsafe concurrent operations on ~A detected." hash-table))
690 ;;; Called when we detect circular chains in a hash-table.
691 (defun signal-corrupt-hash-table-bucket (hash-table)
692 (error "Corrupt NEXT-chain in ~A. This is probably caused by ~
693 multiple threads accessing the same hash-table without locking."
694 hash-table))
697 ;;;; accessing functions
699 ;;; Clear rehash bit and bump the rolling count, wrapping around to keep it a fixnum.
700 ;;; need-to-rehash is indicated by a stamp of #b______01 ; INITIAL-STAMP
701 ;;; which is changed during rehash to #b______10 ; REHASHING-STAMP
702 ;;; rolling count --------^^^^^^ (some number of bits)
703 (defmacro done-rehashing (table kv-vector initial-stamp)
704 (declare (ignorable table))
705 `(let ((rehashing-stamp (1+ ,initial-stamp))
706 ;; new stamp has the "count" field bumped up by 1, and the low 2 bits are 0.
707 (new-stamp (sb-vm::+-modfx ,initial-stamp 3)))
708 #+hash-table-metrics (aver (= (logand ,initial-stamp #b11) #b01))
709 ;; Assigning new stamp races with GC which might set the 'rehash' (low) bit again.
710 ;; At most one more attempt is needed since no other state change can occur -
711 ;; we don't need to keep trying to achieve a state in which 'rehash' is clear.
712 (let ((old (cas (svref ,kv-vector rehash-stamp-elt) rehashing-stamp new-stamp)))
713 (unless (eq old rehashing-stamp)
714 (aver (eq old (logior rehashing-stamp 1)))
715 #+hash-table-metrics (atomic-incf (hash-table-n-rehash-again ,table))
716 ;; Bump the count field, but leave the least-significant bit on.
717 (aver (eq old (cas (svref ,kv-vector rehash-stamp-elt) old (logior new-stamp 1))))))))
719 ;;; Rehash in one of two scenarios:
720 ;;; - up-sizing a table, be it weak or not
721 ;;; - rehashing a weak table due to key movement
722 ;;; Absent is the case of rehashing a non-weak table due to key movement.
723 ;;; That is special-cased in %REHASH-AND-FIND which does both at once as its name implies.
724 ;;; Note that this will never be called on a KV-VECTOR with the weakness bit set.
725 ;;; Therefore we can use SVREF in lieu of WEAK-KVV-REF for weak tables.
726 (macrolet
727 ((push-in-chain (bucket-index-expr)
728 `(let ((bucket (the index ,bucket-index-expr)))
729 (setf (aref next-vector i) (aref index-vector bucket)
730 (aref index-vector bucket) i))))
732 (defun rehash (kv-vector hash-vector index-vector next-vector table
733 &aux (next-free 0)
734 (hwm (kv-vector-high-water-mark kv-vector)))
735 (declare (simple-vector kv-vector)
736 (type (simple-array hash-table-index (*)) next-vector index-vector)
737 (type (or null (simple-array hash-table-index (*))) hash-vector)
738 (optimize (sb-c:insert-array-bounds-checks 0)))
739 (macrolet ((with-key ((key-var) &body body)
740 ;; If KEY-VAR is empty, then push I onto the freelist, otherwise invoke BODY
741 `(let* ((key-index (* 2 i))
742 (,key-var (aref kv-vector key-index)))
743 (if (empty-ht-slot-p ,key-var)
744 (setf (aref next-vector i) next-free next-free i)
745 (progn ,@body)))))
746 ;; Cases ordered for performance.
747 (if (null hash-vector)
748 (if (eq (hash-table-test table) 'eq)
749 (let ((mask (1- (length index-vector))))
750 ;; Scan backwards so that chains are in ascending index order.
751 (do ((i hwm (1- i))) ((zerop i))
752 (declare (type index/2 i)
753 (optimize (safety 0)))
754 (with-key (key)
755 (push-in-chain (mask-hash (eq-hash* key) mask)))))
756 (let ((mask (1- (length index-vector))))
757 (do ((i hwm (1- i))) ((zerop i))
758 (declare (type index/2 i)
759 (optimize (safety 0)))
760 (with-key (key)
761 (push-in-chain (mask-hash (eql-hash key) mask))))))
762 (let ((mask (1- (length index-vector))))
763 (do ((i hwm (1- i))) ((zerop i))
764 (declare (type index/2 i)
765 (optimize (safety 0)))
766 (with-key (key)
767 (let* ((stored-hash (aref hash-vector i))
768 (hash (if (/= stored-hash +magic-hash-vector-value+)
769 ;; Use the existing hash value (not
770 ;; address-based hash).
771 stored-hash
772 (eq-hash* key))))
773 (push-in-chain (mask-hash hash mask))))))))
774 ;; This is identical to the calculation of next-free-kv in INSERT-AT.
776 ;; Note that when called from GROW-HASH-TABLE, there are no empty
777 ;; slots below HWM, so testing for them in WITH-KEY is a waste, but
778 ;; it's an almost immeasurably small one. -- MG, 2024-01-26
779 (cond ((/= next-free 0) next-free)
780 ((= hwm (hash-table-pairs-capacity kv-vector)) 0)
781 (t (1+ hwm))))
783 ;;; Rehash due to key movement, and find KEY at the same time.
784 ;;; Finding the key obviates the need for the rehashing thread to loop
785 ;;; testing whether to rehash. Imagine an unlucky schedule wherein each rehash
786 ;;; ends up invalid due to maximally bad timing of GC, and every reader sees
787 ;;; nothing but 'need-to-rehash', and the INDEX vector is repeatedly overwritten
788 ;;; with zeros. The -AND-FIND aspect of this ensures progress.
789 (defun %rehash-and-find (table epoch key
790 &aux (kv-vector (hash-table-pairs table))
791 (next-vector (hash-table-next-vector table))
792 (hash-vector (hash-table-hash-vector table))
793 (rehashing-state (1+ epoch)))
794 (declare (hash-table table) (fixnum epoch))
795 #+hash-table-metrics (atomic-incf (hash-table-n-rehash+find table))
796 ;; Verify some invariants prior to disabling array bounds checking
797 (aver (>= (length kv-vector) #.(+ (* 2 +min-hash-table-size+)
798 kv-pairs-overhead-slots)))
799 (aver (= (ash (length kv-vector) -1) (length next-vector)))
800 (when hash-vector
801 (aver (= (length hash-vector) (length next-vector))))
802 ;; Empty cells must be in the free chain already, and no smashed cells exist.
803 (when (typep table 'general-hash-table)
804 (aver (null (hash-table-smashed-cells table))))
805 ;; Must not permit the rehashing state to stick due to a nonlocal exit.
806 ;; All further normal use of the table would be prevented.
807 (without-interrupts
808 ;; Transitioning from #b01 to #b10 clears the 'rehash' bit and sets the
809 ;; rehash-in-progress bit. It also gives this thread exclusive write access
810 ;; to the bucket chains since at most one thread can win this CAS.
811 (when (eq (cas (svref kv-vector rehash-stamp-elt) epoch rehashing-state) epoch)
812 ;; Rehash in place. For the duration of the rehash, readers who otherwise
813 ;; might have seen intact chains (by which to find address-insensitive keys)
814 ;; can't. No big deal. If we were willing to cons new vectors, we could
815 ;; rehash into them and CAS them in, but the advantage would be minimal-
816 ;; obsolete chains could only work for a possibly-empty subset of keys.
817 ;; Leave the free cell chain untouched, since rehashing
818 ;; due to key movement can not possibly affect that chain.
819 (let* ((index-vector (hash-table-index-vector table))
820 (hwm (kv-vector-high-water-mark kv-vector))
821 (result 0))
822 (declare (optimize (sb-c:insert-array-bounds-checks 0)))
823 (fill index-vector 0)
824 (macrolet ((with-key ((key-var) &body body)
825 ;; Process body only if KEY-VAR is nonempty, and also look
826 ;; for a probed key that is EQ to KEY.
827 `(let* ((key-index (* 2 i))
828 (,key-var (aref kv-vector key-index)))
829 (unless (empty-ht-slot-p ,key-var)
830 (when (eq ,key-var key) (setq result key-index))
831 ,@body))))
832 (cond
833 (hash-vector
834 (let ((mask (1- (length index-vector))))
835 (do ((i hwm (1- i))) ((zerop i))
836 (declare (type index/2 i)
837 (optimize (safety 0)))
838 (with-key (pair-key)
839 (let* ((stored-hash (aref hash-vector i))
840 (hash (if (/= stored-hash +magic-hash-vector-value+)
841 stored-hash
842 (eq-hash* pair-key))))
843 (push-in-chain (mask-hash hash mask)))))))
844 ((eq (hash-table-test table) 'eql)
845 (let ((mask (1- (length index-vector))))
846 (do ((i hwm (1- i))) ((zerop i))
847 (declare (type index/2 i)
848 (optimize (safety 0)))
849 (with-key (pair-key)
850 (push-in-chain (mask-hash (eql-hash pair-key) mask))))))
852 ;; No hash vector and not an EQL table, so it's an EQ table
853 (let ((mask (1- (length index-vector))))
854 (do ((i hwm (1- i))) ((zerop i))
855 (declare (type index/2 i)
856 (optimize (safety 0)))
857 (with-key (pair-key)
858 (push-in-chain (mask-hash (eq-hash* pair-key) mask))))))))
859 (done-rehashing table kv-vector epoch)
860 (unless (eql result 0)
861 (setf (hash-table-cache table) result))
862 result))))
863 ) ; end MACROLET
865 (defun %recompute-ht-vector-sizes (rehash-size old-size)
866 ;; Compute new vector lengths for the table, extending the table based on the
867 ;; rehash-size.
868 (declare (type (integer 1 (#.(ash 1 +max-hash-table-bits+))) old-size))
869 (let* ((new-size
870 (typecase rehash-size
871 (single-float
872 ;; This is the more common case by far, and we take some
873 ;; pains to tell TRUNCATE that the result fits in a
874 ;; fixnum.
875 (let ((new-size/float
876 ;; These magic constants are (FLOAT (ASH 1
877 ;; +MAX-HASH-TABLE-BITS+)).
878 (the (single-float * #-64-bit 5.368709e8
879 #+64-bit 2.1474836e9)
880 (truly-the (single-float 1.0)
881 (* rehash-size old-size)))))
882 (max (truncate new-size/float)
883 ;; Ensure that the size grows, e.g. for
884 ;; (TRUNCATE (* 14 1.01)) => 14.
885 (1+ old-size))))
886 (fixnum (+ rehash-size old-size))))
887 (new-n-buckets
888 (let ((pow2ceil (power-of-two-ceiling new-size)))
889 ;; If the default rehash-size was employed, let's try to keep the
890 ;; load factor (LF) within a reasonable band. Otherwise don't bother.
891 ;; The motivation for this decision is twofold:
892 ;; - if using defaults, it would be ideal to attempt to be nominally
893 ;; conscientious of the 1.5x resize amount.
894 ;; - we can't really accommodate arbitrary resize amounts, especially if small.
895 ;; (power-of-2 sizing can't do that- doubling is the only possibility)
896 ;; But we can produce the smallest table consistent with the request.
897 ;; Say e.g. REHASH-SIZE was 2 using the default initial size of 14.
898 ;; Resizing computes 16 k/v pairs which coincides exactly with
899 ;; 16 buckets (the nearest power of 2). But if we wish to avoid 100% load,
900 ;; what can we do? Re-double the bin count to 32? Decrease the k/v pair count
901 ;; to 15? Clearly neither of those make sense if the user is trying to say
902 ;; that (s)he wants 2 entries more which means "don't increase by a lot".
903 ;; Changing from 8 buckets (at the old size) to 32 buckets is a lot,
904 ;; so why do that? Conversely, it makes no sense to reduce the k/v pair
905 ;; limit just to keep the LF less than 100%. A similar problem occurs
906 ;; if you specify 1.001 or other float near 1.
907 ;; Anyway, chaining supports load factors in excess of 100%
908 (when (eql rehash-size default-rehash-size)
909 (let* ((pow2ceil (float pow2ceil))
910 (full-lf (/ new-size pow2ceil)))
911 (cond ((> full-lf 0.9)
912 ;; If we're going to decrease the size, make sure we definitely
913 ;; don't decrease below the old size.
914 (setq new-size (floor (* 0.85 pow2ceil)))) ; target LF = 85%
915 ((< full-lf 0.55)
916 (setq new-size (floor (* 0.65 pow2ceil))))))) ; target LF = 65%
917 pow2ceil)))
918 (values new-size new-n-buckets)))
920 ;;; Cache the expensive computation of RECOMPUTE-HT-VECTOR-SIZES for
921 ;;; when REHASH-SIZE is the default.
923 (defconstant +cache-default-ht-sizes-below+ 1024)
925 (declaim (type (simple-array fixnum (#.(* 2 +cache-default-ht-sizes-below+)))
926 *default-ht-sizes*))
927 (define-load-time-global *default-ht-sizes* nil)
928 #-sb-xc-host
929 (!cold-init-forms
930 (setq *default-ht-sizes*
931 (let ((v (make-array (* 2 +cache-default-ht-sizes-below+)
932 :element-type 'fixnum)))
933 (loop for size upfrom 1 below +cache-default-ht-sizes-below+
934 do (multiple-value-bind (new-size new-n-buckets)
935 (%recompute-ht-vector-sizes default-rehash-size size)
936 (setf (aref v (* 2 size)) new-size
937 (aref v (1+ (* 2 size))) new-n-buckets)))
938 v)))
940 (defun recompute-ht-vector-sizes (table)
941 (declare (optimize (sb-c:insert-array-bounds-checks 0)))
942 (let* ((table (truly-the hash-table table))
943 (old-size (hash-table-pairs-capacity (hash-table-pairs table)))
944 (rehash-size (hash-table-rehash-size table)))
945 (if (and (floatp rehash-size)
946 (= rehash-size default-rehash-size)
947 (< old-size +cache-default-ht-sizes-below+))
948 (let ((default-ht-sizes *default-ht-sizes*))
949 (values (aref default-ht-sizes (* 2 old-size))
950 (aref default-ht-sizes (1+ (* 2 old-size)))))
951 (%recompute-ht-vector-sizes rehash-size old-size))))
953 ;;; Enlarge TABLE. If it is weak, then both the old and new vectors are temporarily
954 ;;; made non-weak so that we don't have to deal with GC-related shenanigans.
955 (defun grow-hash-table (table)
956 (declare (type hash-table table))
957 (flet
958 ((realloc (size n-buckets initial-stamp &aux (hash-vector-p (hash-table-hash-vector table)))
959 (declare (type (integer 0 #.(- array-dimension-limit 2)) size n-buckets))
960 (macrolet ((new-vectors ()
961 ;; Return KV-VECTOR NEXT-VECTOR HASH-VECTOR INDEX-VECTOR)
962 `(values (%alloc-kv-pairs size)
963 (make-array size+1 :element-type 'hash-table-index
964 ;; for robustness testing, as explained in %MAKE-HASH-TABLE
965 #+sb-devel :initial-element #+sb-devel bad-next-value)
966 (when hash-vector-p
967 (make-array size+1 :element-type 'hash-table-index))
968 (let ((old-index-vector (hash-table-index-vector table)))
969 ;; When the index vector is not
970 ;; growing and hashes are valid,
971 ;; rehashing _may_ not be necessary.
972 (if (and (eq n-buckets (length old-index-vector))
973 (not (logtest 3 initial-stamp)))
974 old-index-vector
975 (make-index-vector n-buckets))))))
976 (declare (optimize (sb-c::type-check 0)))
977 (let ((size+1 (1+ size)))
978 #-system-tlabs (new-vectors)
979 #+system-tlabs
980 ;; If allocation was directed off the main heap when this table was made, then we assume
981 ;; that reallocation will allocate off the heap. If the old table is in dynamic space,
982 ;; then the new storage should be forced to dynamic space even if the user TLAB currently
983 ;; points outside of dynamic space.
984 ;; The reason for looking at TABLE here and not its storage, is that MAKE-HASH-TABLE can
985 ;; install a k/v pair vector that does not inform us where the table is:
986 ;; * (heap-allocated-p (sb-impl::hash-table-pairs (make-hash-table))) => :READ-ONLY
987 ;; The read-only vector is an optimization reducing the size of never-used tables
988 ;; down to the absolute minimum.
989 (if (dynamic-space-obj-p table)
990 (locally (declare (sb-c::tlab :system)) (new-vectors))
991 (new-vectors))))))
992 (when (= (hash-table-%count table) 0) ; special case for new table
993 ;; CACHE holds the desired initial size. Read it and then set it to a bogusly high value
994 (binding* ((size (- (hash-table-cache table)))
995 (scaled-size (truncate (/ (float size) (hash-table-rehash-threshold table))))
996 (bucket-count (power-of-two-ceiling (max scaled-size +min-hash-table-size+)))
997 ((kv-vector next-vector hash-vector index-vector) (realloc size bucket-count 1)))
998 (setf (kv-vector-supplement kv-vector) (or hash-vector (eq (hash-table-test table) 'eql))
999 (hash-table-pairs table) kv-vector
1000 (hash-table-index-vector table) index-vector
1001 (hash-table-next-vector table) next-vector
1002 (hash-table-hash-vector table) hash-vector)
1003 (return-from grow-hash-table 1)))
1004 (binding* (((new-size new-n-buckets)
1005 (recompute-ht-vector-sizes table))
1006 (old-kv-vector (hash-table-pairs table))
1007 (initial-stamp (kv-vector-rehash-stamp old-kv-vector))
1008 ((new-kv-vector new-next-vector new-hash-vector new-index-vector)
1009 (realloc new-size new-n-buckets initial-stamp))
1010 (hwm (kv-vector-high-water-mark old-kv-vector))
1011 (old-kv-vector-addr-hashing-p
1012 (test-header-data-bit old-kv-vector (ash sb-vm:vector-addr-hashing-flag
1013 sb-vm:array-flags-data-position))))
1015 (declare (type simple-vector new-kv-vector)
1016 (type (simple-array hash-table-index (*)) new-next-vector new-index-vector))
1018 ;; Rehash + resize only occurs when:
1019 ;; (1) every usable pair was at some point filled (so HWM = SIZE)
1020 ;; (2) no cells below HWM are available (so COUNT = SIZE)
1021 (aver (= hwm (hash-table-pairs-capacity old-kv-vector)))
1022 (when (and (not (hash-table-weak-p table)) (/= (hash-table-%count table) hwm))
1023 ;; If the table is not weak, then every cell pair has to be in use
1024 ;; as a precondition to resizing. If weak, this might not be true.
1025 (signal-corrupt-hash-table table))
1027 ;; Copy over the hash-vector,
1028 ;; This is done early because when GC scans the new vector, it needs to see
1029 ;; each hash to know which keys were hashed address-sensitively.
1030 (awhen (hash-table-hash-vector table)
1031 (replace (the (simple-array hash-table-index (*)) new-hash-vector)
1032 it :start1 1 :start2 1)) ; 1st element not used
1034 ;; The high-water-mark remains unchanged.
1035 ;; Set this before copying pairs, otherwise they would not be seen
1036 ;; in the new vector since GC scanning ignores elements below the HWM.
1037 (setf (kv-vector-high-water-mark new-kv-vector) hwm)
1038 ;; Reference the hash-vector from the KV vector.
1039 ;; Normally a weak hash-table's KV vector would reference the table
1040 ;; (because cull needs to examine the table bucket-by-bucket), and
1041 ;; not the hash-vector directly. But we can't reference the table
1042 ;; since using the table's hash-vector gets the OLD hash vector.
1043 ;; It might be OK to point the table at the new hash-vector now,
1044 ;; but I'd rather the table remain in a consistent state, in case we
1045 ;; ever devise a way to allow concurrent reads with a single writer,
1046 ;; for example.
1047 (setf (kv-vector-supplement new-kv-vector)
1048 (or new-hash-vector (eq (hash-table-test table) 'eql)))
1050 ;; Here and also in FINDHASH-WEAK, we keep the
1051 ;; SB-VM:VECTOR-ADDR-HASHING-FLAG. If a hash table is
1052 ;; address-based at any time, it'll remain so until CLRHASH even
1053 ;; if all address-based keys had been removed. This allows
1054 ;; rehashing to do less work and makes EQ hash tables a few
1055 ;; percents faster. In the rare case where the flag errs on the
1056 ;; side of conservativeness, the GC needs to do a bit more work.
1057 ;; If this ever becomes a problem, maybe the GC can detect this
1058 ;; and clear the flag. -- MG, 2023-10-13
1059 (when old-kv-vector-addr-hashing-p
1060 (logior-array-flags new-kv-vector sb-vm:vector-addr-hashing-flag))
1062 ;; Copy the k/v pairs excluding leading and trailing metadata.
1063 (replace new-kv-vector old-kv-vector
1064 :start1 2 :start2 2 :end2 (* 2 (1+ hwm)))
1066 ;; If the index hasn't grown, try to avoid rehashing.
1067 (when (eq new-index-vector (hash-table-index-vector table))
1068 (let ((old-next-vector (hash-table-next-vector table)))
1069 (replace new-next-vector old-next-vector
1070 :start1 1 :start2 1 :end1 (1+ hwm)))
1071 ;; We know from REALLOC that the hashes were valid and no
1072 ;; rehashing was in progress, but a GC that happened before
1073 ;; REPLACE above might have marked only OLD-KV-VECTOR (and not
1074 ;; NEW-KV-VECTOR) as needs-rehash, in which case we must do a
1075 ;; normal rehash after all. Note that looking at the low two
1076 ;; bits of the stamp is not enough here because they could
1077 ;; have been cleared already in another thread.
1078 (when (or (/= (kv-vector-rehash-stamp old-kv-vector) initial-stamp)
1079 (not (zerop (kv-vector-rehash-stamp new-kv-vector))))
1080 (setq new-index-vector (make-index-vector new-n-buckets))))
1082 ;; Preserve only the 'hashing' bit on the OLD-KV-VECTOR so that
1083 ;; its high-water-mark can meaningfully be reduced to 0 when done.
1084 ;; Clearing the address-sensitivity is a performance improvement
1085 ;; since GC won't check on a per-key basis whether to flag the vector
1086 ;; for rehash (it's going to be zeroed out).
1087 ;; Clearing the weakness causes all entries to stay alive.
1088 ;; Furthermore, clearing both makes the trailing metadata ignorable.
1089 (assign-vector-flags old-kv-vector sb-vm:vector-hashing-flag)
1090 (setf (kv-vector-supplement old-kv-vector) nil)
1092 (let ((next-free (cond ((eq new-index-vector (hash-table-index-vector table))
1093 (let ((old-next-free (hash-table-next-free-kv table)))
1094 (if (/= 0 old-next-free)
1095 old-next-free
1096 (1+ hwm))))
1098 (rehash new-kv-vector new-hash-vector
1099 new-index-vector new-next-vector table)))))
1100 (setf (hash-table-pairs table) new-kv-vector
1101 (hash-table-hash-vector table) new-hash-vector
1102 (hash-table-index-vector table) new-index-vector
1103 (hash-table-next-vector table) new-next-vector
1104 (hash-table-next-free-kv table) next-free)
1106 (when (hash-table-weak-p table)
1107 (setf (hash-table-smashed-cells table) nil)
1108 ;; Now that the table points to the right hash-vector
1109 ;; we can set the vector's backpointer and turn it weak.
1110 (setf (kv-vector-supplement new-kv-vector) table)
1111 (logior-array-flags new-kv-vector sb-vm:vector-weak-flag))
1113 ;; Zero-fill the old kv-vector. For weak hash-tables this removes the
1114 ;; strong references to each k/v. For non-weak vectors there is no technical
1115 ;; reason to do this except for safety. GC will not scavenge past the high water
1116 ;; mark, but if you had your hands on the old vector and decide to dereference
1117 ;; it (which is probably indicates a data race), you could deference a dangling
1118 ;; pointer. In other words, even if the vector were considered a root,
1119 ;; it wouldn't matter from a heap consistency perspective because it would
1120 ;; not transitively enliven anything, but you can't stop people from using
1121 ;; SVREF on it past the high water mark. To to make things safe,
1122 ;; we sort of have to zero-fill.
1123 ;; Also fwiw, it would be necessary to fix verify_range() to understand
1124 ;; that it MUST NOT verify past the hwm, and similary the low-level debugger
1125 ;; if we didn't zero-fill.
1126 ;; Or, if we could trust people not to look at the old vector, we could just
1127 ;; change the widetag into simple-array-word instead of scribbling over it.
1128 (fill old-kv-vector 0 :start 2 :end (* (1+ hwm) 2))
1129 (setf (kv-vector-high-water-mark old-kv-vector) 0)
1130 next-free))))
1132 (defun gethash (key hash-table &optional default)
1133 "Finds the entry in HASH-TABLE whose key is KEY and returns the
1134 associated value and T as multiple values, or returns DEFAULT and NIL
1135 if there is no such entry. Entries can be added using SETF."
1136 (declare (type hash-table hash-table)
1137 (values t (member t nil)))
1138 (gethash3 key hash-table default))
1140 ;;; Define a specialized variation of GETHASH3 for a standard test fun,
1141 ;;; or the general case.
1142 ;;; A note about in the inner loop: the secondary value of the hash function
1143 ;;; indicates whether an address was taken, which implies that we should use EQ
1144 ;;; as the comparator, but it is not an "if and only if" - other objects can be
1145 ;;; compared by EQ, for example symbols and fixnums.
1147 ;;; The code below could be further tweaked by doing a few things:
1148 ;;; - removing the probing limit check
1149 ;;; - skipping array bounds checks
1150 ;;; - eliminating some multiply-by-2 operations
1151 ;;; The first two are easy enough. The last means that we would
1152 ;;; rejigger the INDEX + NEXT vectors to contain physical elt indices.
1153 ;;; We could define safe and unsafe variants of each getter, and an "unsafe"
1154 ;;; variant of MAKE-HASH-TABLE that installs the unsafe getter.
1155 ;;; A source transform would select the variant of MAKE-HASH-TABLE by policy.
1157 (eval-when (:compile-toplevel :load-toplevel :execute)
1158 ;; macroexpander helper functions. These rely on a naming convention
1159 ;; to keep things simple so that we don't have to pass in the names
1160 ;; of local variables to bind. (Being unhygienic on purpose)
1162 (defun ht-hash-setup (hash-fun-name)
1163 (if hash-fun-name
1164 `(((hash address-based-p)
1165 ;; so many warnings about generic SXHASH - who cares
1166 (locally (declare (muffle-conditions compiler-note))
1167 (,hash-fun-name key))))
1168 '((hash (clip-hash (the fixnum
1169 (funcall (hash-table-hash-fun hash-table) key))))
1170 (address-based-p nil))))
1172 (defun ht-probe-setup (std-fn &optional more-bindings)
1173 `((index-vector (hash-table-index-vector hash-table))
1174 ;; BUCKET is the masked hash code which acts as the index into index-vector
1175 (bucket (mask-hash hash (1- (length index-vector))))
1176 ;; INDEX is the index into the pairs vector obtained from the index-vector
1177 (index (aref index-vector bucket))
1178 (next-vector (hash-table-next-vector hash-table))
1179 ;; Binding of HASH-VECTOR would be flushed for EQ and EQL tables
1180 ;; automatically, but we forcibly elide some code because "reasons"
1181 ;; so we need to avoid "unused variable warnings" by eliding this
1182 ;; binding as well.
1183 ,@(unless (member std-fn '(eq eql))
1184 '((hash-vector (truly-the
1185 (simple-array hash-table-index (*))
1186 (hash-table-hash-vector hash-table)))))
1187 ,@(when (member std-fn '(nil *))
1188 '((test-fun (hash-table-test-fun hash-table))))
1189 (probe-limit (length next-vector))
1190 ,@more-bindings))
1192 (defun ht-probing-should-use-eq (std-fn)
1193 (ecase std-fn ; try to strength-reduce the test for this key
1194 (eq 't) ; always use EQ
1195 (eql
1196 ;; EQL vs EQ only matters for numbers which aren't immediate.
1197 ;; Not worth the trouble to get single-float in here for 64-bit.
1198 '(or address-based-p (typep key '(or (not number) fixnum))))
1199 (equal
1200 ;; EQUAL and EQUALP hash function say that symbols are NOT address-sensitive
1201 ;; - which they aren't, as they use the SYMBOL-HASH slot, unlike EQ-HASH
1202 ;; which takes the address - but we want to compare symbols by EQ.
1203 ;; As to NON-NULL-SYMBOL, it's just slightly quicker than also testing for NIL,
1204 ;; because it's not an important case and SYMBOLP uses more instructions.
1205 ;; This is similar in philosophy to the EQL branch where I don't care whether
1206 ;; single float (on 64-bit) is or isn't compared by EQ.
1207 ;; A more thorough test of whether EQUALP strength-reduces to EQ
1208 ;; would be something like
1209 ;; (or (fixnump key)
1210 ;; (not (typep key '(or cons string pathname bit-vector number)))))
1211 ;; but it's unclear to me whether we should spend time up front deciding
1212 ;; to reduce everything to EQ that could be reduced. The test here
1213 ;; is about half as much code as the (not (typep ...)) expression.
1214 ;; There is diminishing payoff from listing other types.
1215 '(or address-based-p
1216 (fixnump key)
1217 (non-null-symbol-p key)
1218 (and (%instancep key)
1219 ;; Pathnames are descended into by EQUAL.
1220 (not (logtest (layout-flags (%instance-layout key))
1221 +pathname-layout-flag+)))))
1222 (equalp
1223 '(or address-based-p
1224 (non-null-symbol-p key)
1225 (and (%instancep key)
1226 ;; Structures incl. PATHNAME and HASH-TABLE are descended into.
1227 (not (logtest (layout-flags (%instance-layout key))
1228 +structure-layout-flag+)))))
1229 ((nil)
1230 ;; If the hash-function is nonstandard, it's nonetheless possible
1231 ;; to use EQ as the comparator.
1232 '(eq (hash-table-test hash-table) 'eq))))
1234 ;; Keyword args:
1235 ;; - ENDP-TEST when true says that the probing loop is unrolled, and a test
1236 ;; for the end of the chain is ORed into the key comparison.
1237 ;; At worst, we compare the key against the value 0 (in the 0th element
1238 ;; of the k/v vector) which is just a dummy value, since filled indices
1239 ;; begin at 1.
1240 ;; - HASH-TEST when :STRICT (the default) says that for tables with hash vectors,
1241 ;; we can use the computed hash as a guard before calling the predicate,
1242 ;; and (AREF HASH-VECTOR i) is definitely not +MAGIC-HASH-VECTOR-VALUE+
1243 ;; in that case.
1244 ;; If HASH-TEST is :PERMISSIVE, then the stored value might be the magic
1245 ;; value which is considered a match to anything.
1247 ;; GETHASH and PUTHASH always know whether to look in HASH-VECTOR or not,
1248 ;; because for any given key, either it does or does not have an address-based
1249 ;; hash. The probing loop is unswitched on that grounds. If the hash isn't an
1250 ;; address, then we compare hashes before calling a predicate. If the hash is
1251 ;; an address, then we devolve to EQ in the loop, and never compare hashes.
1252 ;; Hence, unswitching should result in a performance gain for EQUAL and EQUALP
1253 ;; that become like EQ, as well as eliding any expensive predicate call where
1254 ;; the result would be NIL.
1256 ;; The :PERMISSIVE hash check is needed in REMHASH, which performs one
1257 ;; key comparison prior to unswitching the remainder of the probing loop.
1258 ;; This is due to the first entry in a chain needing to be handled separately.
1259 ;; Consider it like destructively deleting the initial cons in a list - RPLACD
1260 ;; can't do that operation. So the first comparison might be on a key whose
1261 ;; stored hash is +MAGIC-HASH-VECTOR-VALUE+. Just ignore that stored hash.
1263 ;; Also, a minor exception to the above: EQL tables don't compare hashes
1264 ;; because no performance gain is obtained. The hash vector exists solely
1265 ;; to inform GC whether each key was hashed address-sensitively.
1266 (defun ht-key-compare (std-fn pair-index &key endp-test (hash-test :strict))
1267 (declare (type (member :strict :permissive) hash-test))
1268 ;; STD-FN = NIL says that's definitely a user-defined hash function,
1269 ;; and * says that it could be either standard or user-defined.
1270 (let* ((is-same-hash `(= hash (aref hash-vector ,pair-index)))
1271 (hashcompare
1272 (case std-fn
1273 ((equal equalp)
1274 (if (eq hash-test :strict)
1275 is-same-hash
1276 `(let ((stored-hash (aref hash-vector ,pair-index)))
1277 (or (= stored-hash hash)
1278 (= stored-hash +magic-hash-vector-value+)))))
1279 ;; We do not give users a way to have some keys be address-sensitive
1280 ;; when they define their own hash function. Therefore, _any_ user-defined
1281 ;; table has a hash-vector, even if comparison is done by EQ.
1282 ;; (You might want EQ comparison on "intelligent" hashes as opposed
1283 ;; to "opaque" hashes like an address or stable randomly-assigned value.)
1284 ;; Moreover, every hash-value in the vector is something other than
1285 ;; +MAGIC-HASH-VECTOR-VALUE+, because nothing is address-based.
1286 ;; The nuance of address-based versus EQ-based is subtle,
1287 ;; but hopefully the variable naming in the code is clear enough now.
1288 ((nil) is-same-hash)
1289 ((*)
1290 (error "Obsolete case - remove me?") ; was it for weak tables maybe?
1291 `(or (null hash-vector) ,is-same-hash))))
1292 (keycompare
1293 (case std-fn
1294 ;; Use the inline EQL function
1295 (eql `(%eql key (aref kv-vector (* 2 ,pair-index))))
1296 ((nil *) `(funcall test-fun key (aref kv-vector (* 2 ,pair-index))))
1297 (t `(,std-fn key (aref kv-vector (* 2 ,pair-index))))))
1298 (compare
1299 (if hashcompare `(and ,hashcompare ,keycompare) keycompare)))
1300 (cond ((not endp-test) compare)
1301 ;; For standard general predicates, compare the key before checking
1302 ;; whether probing must terminate (index = 0). For user predicates
1303 ;; that might accept only strings, for example, check index first.
1304 ;; This way, a hit on the first probe avoids one test for standard
1305 ;; tests. Index is post-checked to deem it a hit or miss.
1306 (std-fn `(or ,compare (eql ,pair-index 0)))
1307 (t `(or (eql ,pair-index 0) ,compare))))))
1309 ;;; CAUTION: I think this macro could falsely signal a corrupt chain.
1310 ;;; Consider what would happen if there is a reader (started first),
1311 ;;; and a rehasher. The reader didn't rehash, because if it thought it needed to,
1312 ;;; it would have. But as it's reading, a GC can occur, setting need-to-rehash.
1313 ;;; Then another reader comes along, seeing the flag, so it modifies the chains
1314 ;;; just as the first reader is following 'next' pointers.
1315 ;;; Could this cause the first reader to probe too much? Maybe.
1316 ;;; I think we should terminate probing after a number of tries determined
1317 ;;; by the length of the longest chain, which we can track in PUTHASH.
1318 ;;; If not found, examine the rehash-stamp and maybe restart.
1319 ;;; But don't draw an inference that the chains are bad.
1320 (defmacro check-excessive-probes (n-probes)
1321 `(when (minusp (decf (truly-the fixnum probe-limit) ,n-probes))
1322 (signal-corrupt-hash-table-bucket hash-table)))
1324 (defmacro ht-probe-advance (var)
1325 `(setq ,var (truly-the index/2 (aref next-vector ,var))))
1329 The 'stamp' in our k/v vector is an amalgamation of a fast-read-lock
1330 (almost like in 'frlock.lisp' but using a different implementation)
1331 plus a single-bit spinlock protecting the counter from multiple writers.
1332 As the comments in frlock file explain, it is not required to have a
1333 counter for before and after writing. You only need 1 counter, which
1334 the writer bumps up before mutation of the data guarded by the frlock.
1336 The lowest bit of the stamp is atomically set by GC if it moved a key,
1337 and atomically cleared by Lisp after refreshing the bucket chains.
1338 The bit at position 1 is the spinlock, which is also equivalent
1339 to "rehash in progress". (It can be assumed that as soon as the spinlock
1340 is locked, at least one bucket has been messed up)
1342 An interesting point about this spinlock is that it does not guard the k/v cells,
1343 it only guards the bucket chains. Waiters do not need to "spin" when they can't
1344 acquire the lock, because they can still read the k/v cells.
1346 00 = valid hashes
1347 01 = an address-sensitive key moved
1348 10 = rehashing in progress
1349 11 = rehashing + an address-sensitive key moved
1351 'nnnn' is the timestamp ("epoch"). If it changed to MMMM then we can't
1352 reason about the status bits, so restart from the top.
1354 Pre- Post- Miss
1355 loookup lookup Action
1356 ------- ------- ------
1357 nnnn 00 nnnn 0_ valid (KEY is pinned, so don't care if hashes became invalid)
1358 nnnn 00 nnnn 1_ linear scan (another thread is messsing up the bucket chains)
1359 nnnn 00 MMMM __ restart (chains are in an indeterminate state)
1361 nnnn 01 nnnn 01 valid if not address-sensitive, otherwise rehash and find
1362 nnnn 01 nnnn 1_ linear scan (another thread is messing up the bucket chains)
1363 nnnn 01 MMMM __ restart (chains are in an indeterminate state)
1365 nnnn 1_ any linear scan (don't try to read when rehash already in progress)
1368 (defmacro define-ht-getter (name std-fn hash-fun-name)
1369 ;; For synchronized GETHASH we've already acquired the lock,
1370 ;; so this KV-VECTOR is the most current one.
1371 `(defun ,name (key table default
1372 &aux (hash-table (truly-the hash-table table))
1373 (kv-vector (hash-table-pairs hash-table)))
1374 (declare (optimize speed (sb-c:verify-arg-count 0)
1375 (sb-c:insert-array-bounds-checks 0)))
1376 (let ((index (hash-table-cache hash-table)))
1377 ;; When INDEX is negative (implies that the hash table is
1378 ;; empty), we could return DEFAULT here, but that is an overall
1379 ;; performance loss. Maybe it's worth it to start with a
1380 ;; GETHASH/EMPTY getter. -- MG, 2023-10-12
1382 ;; First check the cache using EQ, not the test fun, for speed.
1383 (when (and (plusp index) (eq (aref kv-vector index) key))
1384 (return-from ,name (values (aref kv-vector (1+ index)) t))))
1385 (with-pinned-objects (key)
1386 (binding* (,@(ht-hash-setup hash-fun-name)
1387 (eq-test ,(ht-probing-should-use-eq std-fn)))
1388 (flet ((hash-search (&aux ,@(ht-probe-setup std-fn))
1389 (declare (index/2 index))
1390 ;; Search next-vector chain for a matching key.
1391 (if eq-test
1392 (macrolet ((probe ()
1393 '(if ,(ht-key-compare 'eq 'index :endp-test t)
1394 (return index)
1395 (ht-probe-advance index))))
1396 (loop (probe) (probe) (probe) (probe)
1397 ;; Optimistically assuming we hit the key, this check
1398 ;; never executes. The exact boundary case doesn't matter
1399 ;; (this might allow a few too many iterations),
1400 ;; but as long as we can detect circularity, it's fine.
1401 (check-excessive-probes 4)))
1402 ;; We get too many "unreachable code" notes for my liking,
1403 ;; if this branch is unconditionally left in.
1404 ,(unless (eq std-fn 'eq)
1405 `(macrolet ((probe ()
1406 '(if ,(ht-key-compare std-fn 'index :endp-test t)
1407 (return index)
1408 (ht-probe-advance index))))
1409 ;; In the case of EQL, we get most bang-for-buck (performance per
1410 ;; line of asm code) by inlining EQL, not by loop unrolling,
1411 ;; but we might as well unroll a little bit to lessen the impact
1412 ;; of check-for-overflow.
1413 ;; You can experiment with unrolling here easily enough.
1414 ,(if (eq std-fn 'eql)
1415 '(loop (probe) (probe) (check-excessive-probes 2))
1416 '(loop (probe) (check-excessive-probes 1))))))))
1417 (named-let retry ((initial-stamp (kv-vector-rehash-stamp kv-vector)))
1418 ;; Taking out either of these barriers will cause failure of
1419 ;; PARALLEL-READERS-EQUAL-TABLE on relaxed memory order CPUs.
1420 ;; The paired :WRITE barrier is either in the stop-the-world handler
1421 ;; (which is effectively a full barrier), or the CAS in the regression test
1422 ;; that mocks GC touching the need-to-rehash bit.
1423 ;; That's the best explanation I can give.
1424 (sb-thread:barrier (:read)) ; barrier 1
1425 (if (logtest initial-stamp kv-vector-rehashing)
1426 (truly-the (values t boolean &optional)
1427 (hash-table-lsearch hash-table eq-test key
1428 ,(if (eq std-fn 'eq)
1429 '(clip-hash hash)
1430 'hash)
1431 default))
1432 (let ((index (hash-search)))
1433 (if (not (eql index 0))
1434 (let ((key-index (* 2 (truly-the index/2 index))))
1435 (setf (hash-table-cache hash-table) key-index)
1436 (values (aref kv-vector (1+ key-index)) t))
1437 ;; the BARRIER macro sucks bigly, hence the PROGN
1438 (let ((stamp (progn (sb-thread:barrier (:read)) ; barrier 2
1439 (kv-vector-rehash-stamp kv-vector))))
1440 (cond ((and (evenp initial-stamp) ; valid hashes at start?
1441 (zerop (logandc2 (logxor stamp initial-stamp) 1)))
1442 ;; * address-based hashes were valid on entry
1443 ;; * disregarding the need-to-rehash bit, stamp is the same as on
1444 ;; entry (rehash did not occur)
1445 (values default nil))
1446 ((and (oddp initial-stamp) (= stamp initial-stamp))
1447 ;; * address-based hashes were NOT valid on entry
1448 ;; * rehash did not occur
1449 ;; Stably hashed (address-insensitive) keys are ok.
1450 (if (not address-based-p)
1451 (values default nil)
1452 (let ((key-index (%rehash-and-find hash-table stamp key)))
1453 (cond ((eql key-index 0) ; didn't find, again
1454 (values default nil))
1455 ((not (fixnump key-index))
1456 ;; conflicted with other thread trying to rehash
1457 (retry (kv-vector-rehash-stamp kv-vector)))
1459 (values (aref kv-vector (1+ key-index)) t))))))
1460 (t ; stamp changed
1461 #+hash-table-metrics (atomic-incf
1462 (hash-table-n-stamp-change table))
1463 (retry stamp)))))))))))))
1465 ;;;; Weak table variant.
1467 #-weak-vector-readbarrier (defmacro weak-kvv-ref (v i) `(svref ,v ,i))
1469 ;;; A single function acts as the core of all operations on weak tables.
1470 ;;; The advantage is that we could simulate lazy weak lists by removing smashed
1471 ;;; pairs while doing any table operation, with no GC support beyond the ability
1472 ;;; to change a cell from non-empty to smashed. Therefore if we could leverage a
1473 ;;; collector from some other language, it need not understand our weak
1474 ;;; hash-table representation in depth.
1476 ;;; TODO: it would be ideal if GETHASH/WEAK could share code with GETHASH/ANY
1477 ;;; (the general case of hash-function + predicate).
1478 ;;; The difficulty in doing so is that %REHASH-AND-FIND has trouble understanding
1479 ;;; how to treat keys that are +empty-ht-slot+ in a weak table - we don't know if
1480 ;;; a key was smashed by GC and the cell still exists in a bucket's chain,
1481 ;;; versus the cell being in the freelist. So the code diverges in at least that way.
1482 (defun findhash-weak (key hash-table hash address-based-p)
1483 (declare (hash-table hash-table) (optimize speed)
1484 (type clipped-hash hash))
1485 (let* ((kv-vector (hash-table-pairs hash-table))
1486 (initial-stamp (kv-vector-rehash-stamp kv-vector)))
1487 (flet ((hash-search ()
1488 (binding* #.(ht-probe-setup '* '((predecessor nil)))
1489 (declare (index/2 index))
1490 (macrolet
1491 ((probing-loop (comparison-expr)
1492 `(do ((next index (aref next-vector next)))
1493 ((zerop next) (values +empty-ht-slot+ 0 0 0))
1494 (declare (type index/2 next))
1495 ;; An unfortunate aspect of this code is that it will liven
1496 ;; passed over keys in the case of a probe miss. It should be
1497 ;; possible to come up with a way to _conditionally_ strengthen
1498 ;; the ref to the key, i.e. only when we actually have a hit.
1499 (let* ((physical-index (truly-the index (* next 2)))
1500 (probed-key (weak-kvv-ref kv-vector physical-index)))
1501 (when ,comparison-expr
1502 ;; Delay fetching the value until a key match. There's a race here
1503 ;; in a weak value table. If the key is reachable but the value is
1504 ;; otherwise unreachable, the GC might win and clear the value.
1505 ;; So GETHASH has to check for that anyway.
1506 (let ((probed-val (weak-kvv-ref kv-vector (1+ physical-index))))
1507 (return (values probed-val probed-key physical-index predecessor))))
1508 (check-excessive-probes 1)
1509 (setq predecessor next)))))
1510 (cond
1511 ((or (eq (hash-table-test hash-table) 'eq) address-based-p)
1512 ;; Everything in an EQ table is address-based - though this is subject
1513 ;; to change, as we could stably hash symbols, because why not -
1514 ;; but the hash fun's second value is NIL on immediate objects.
1515 (probing-loop (eq key probed-key)))
1516 ((eq (hash-table-test hash-table) 'eql)
1517 ;; similar to EQ except for the different comparator
1518 (probing-loop (%eql key probed-key)))
1520 ;; For any other test, we assume that it is not safe to pass the
1521 ;; unbound marker to the predicate (though EQUAL and EQUALP are
1522 ;; probably OK). Also, compare hashes first.
1523 (probing-loop (and (not (empty-ht-slot-p probed-key))
1524 (= hash (aref hash-vector next))
1525 (funcall test-fun key probed-key)))))))))
1526 ;; Weak tables disallow concurrent GETHASH therefore we can't
1527 ;; be in the midst of fixing up obsolete address-based hashes.
1528 (aver (not (logtest initial-stamp kv-vector-rehashing)))
1529 (multiple-value-bind (probed-val probed-key physical-index predecessor)
1530 (hash-search)
1531 (cond
1532 ((or (neq physical-index 0) ; found
1533 (not address-based-p) ; key was stably hashed
1534 (evenp initial-stamp)) ; not found, but address-based hashes were valid
1535 (values probed-val probed-key physical-index predecessor))
1536 (t ; invalid hashes at start, and key's hash was address-based
1537 (without-interrupts
1538 ;; set the stamp to rehashing. There should be no concurrent
1539 ;; access, but use CAS to be sure.
1540 (aver (eql (cas (svref kv-vector rehash-stamp-elt) initial-stamp
1541 (1+ initial-stamp)) initial-stamp))
1542 ;; Set vector hashing, remove weakness, keep address-sensitivity.
1543 (if (test-header-data-bit kv-vector
1544 (ash sb-vm:vector-addr-hashing-flag
1545 sb-vm:array-flags-data-position))
1546 (assign-vector-flags kv-vector
1547 (logior sb-vm:vector-hashing-flag
1548 sb-vm:vector-addr-hashing-flag))
1549 (assign-vector-flags kv-vector sb-vm:vector-hashing-flag))
1550 ;; We don't need to zero-fill the NEXT vector, just the INDEX vector.
1551 ;; Unless a key slot can be reached by a chain starting from the index
1552 ;; vector or the 'next' of a previous chain element, we don't read either
1553 ;; the key or its corresponding 'next'. So we only need to assign a
1554 ;; 'next' at the moment a slot is linked into a chain.
1555 (setf (hash-table-next-free-kv hash-table)
1556 (rehash kv-vector (hash-table-hash-vector hash-table)
1557 (fill (hash-table-index-vector hash-table) 0)
1558 (hash-table-next-vector hash-table)
1559 hash-table))
1560 ;; Empty cells will have been placed in the ordinary freelist,
1561 ;; so clear the list of GC-smashed cells.
1562 (setf (hash-table-smashed-cells hash-table) nil)
1563 ;; Re-enable weakness
1564 (logior-array-flags kv-vector sb-vm:vector-weak-flag)
1565 (done-rehashing hash-table kv-vector initial-stamp))
1566 ;; One more try gives the definitive answer even if the hashes are
1567 ;; obsolete again. KEY's hash can't have changed, and there
1568 ;; are no concurrent readers to potentially mess up the chains.
1569 (hash-search)))))))
1571 (defmacro with-weak-hash-table-entry (&body body)
1572 `(with-pinned-objects (key)
1573 (binding* (((hash0 address-sensitive-p)
1574 (funcall (hash-table-hash-fun hash-table) key))
1575 (address-sensitive-p
1576 (and address-sensitive-p
1577 (not (logtest (hash-table-flags hash-table) hash-table-userfun-flag))))
1578 (hash (clip-hash (the fixnum hash0))))
1579 (dx-flet ((body ()
1580 (binding* (((probed-value probed-key physical-index predecessor)
1581 (findhash-weak key hash-table hash address-sensitive-p))
1582 (kv-vector (hash-table-pairs hash-table)))
1583 (declare (index physical-index))
1584 ,@body)))
1585 ;; It would be ideal if we were consistent about all tables NOT having
1586 ;; synchronization unless created with ":SYNCHRONIZED T"
1587 ;; but it looks tricky to support concurrent gethash on weak tables,
1588 ;; so we default to locking.
1589 (if (hash-table-synchronized-p hash-table)
1590 ;; Use the private slot accessor for the lock because it's known
1591 ;; to have a mutex.
1592 (sb-thread::call-with-recursive-system-lock #'body (hash-table-%lock hash-table))
1593 (body))))))
1595 (defun gethash/weak (key hash-table default)
1596 (declare (type hash-table hash-table) (optimize speed))
1597 (truly-the (values t t &optional)
1598 (with-weak-hash-table-entry
1599 (declare (ignore probed-key physical-index predecessor kv-vector))
1600 ;; empty can occur in two cases: not found, or GC culled a pair even when
1601 ;; a key was found - consider a table with weakness kind :VALUE.
1602 ;; It's best that we be agnostic of the exact order that WITH-PAIR loads
1603 ;; the parts and the order in which GC writes the empty markers.
1604 (if (empty-ht-slot-p probed-value)
1605 (values default nil)
1606 (values probed-value t)))))
1608 (define-ht-getter gethash/eq eq eq-hash*)
1609 (define-ht-getter gethash/eql eql eql-hash)
1610 (define-ht-getter gethash/equal equal equal-hash)
1611 (define-ht-getter gethash/equalp equalp equalp-hash)
1612 (define-ht-getter gethash/any nil nil)
1614 ;;; In lieu of racing to rehash in multiple threads due to GC key movement,
1615 ;;; or blocking on a mutex to rehash, threads can perform just the FIND
1616 ;;; aspect of %REHASH-AND-FIND which is obviously less work than rehashing.
1617 ;;; It has the same computational complexity but fewer instructions,
1618 ;;; and allows forward progress in all threads.
1619 ;;; But unlike %REHASH-AND-FIND which will only be called when the key
1620 ;;; in question was hashed by its address, this search can be called for any
1621 ;;; key and hash-table-test whenever some thread is rehashing. If hash-based
1622 ;;; lookup uses EQ as the comparator for KEY, then linear search does too.
1623 (defun hash-table-lsearch (hash-table eq-test key hash default)
1624 (declare (optimize (sb-c:insert-array-bounds-checks 0)))
1625 (declare (type (and fixnum unsigned-byte) hash))
1626 #+hash-table-metrics (atomic-incf (hash-table-n-lsearch hash-table))
1627 (let* ((kv-vector (hash-table-pairs hash-table))
1628 (key-index
1629 (let ((hash-vector (hash-table-hash-vector hash-table))
1630 (hwm (the index/2 (kv-vector-high-water-mark kv-vector))))
1631 ;; EQ-TEST is an optimization which says that regardless of the table test,
1632 ;; for the particular key being sought, the comparator should be EQ.
1633 ;; This would be true of INSTANCE in an EQL or EQUAL table for example.
1634 (cond ((or eq-test (eq (hash-table-test hash-table) 'eq))
1635 (loop for i from (* hwm 2) downto 2 by 2
1636 when (eq key (aref kv-vector i)) return i))
1637 ((eq (hash-table-test hash-table) 'eql)
1638 (loop for i from (* hwm 2) downto 2 by 2
1639 when (%eql key (aref kv-vector i)) return i))
1641 ;; EQ and EQL are fine with unbound-marker as an argument,
1642 ;; but the general case checks the key for validity first.
1643 (let ((test-fun (hash-table-test-fun hash-table)))
1644 (aver (= (length (truly-the (not null) hash-vector))
1645 (ash (length kv-vector) -1)))
1646 (loop for i from hwm downto 1
1647 when (and (= hash (aref hash-vector i))
1648 (let ((pair-key (aref kv-vector (* 2 i))))
1649 (and (not (empty-ht-slot-p pair-key))
1650 (funcall test-fun key pair-key))))
1651 return (* 2 i))))))))
1652 (cond (key-index
1653 (setf (hash-table-cache hash-table) key-index)
1654 (values (aref kv-vector (1+ key-index)) t))
1656 (values default nil)))))
1658 (defun make-synchronized-table-methods (getter setter remover)
1659 (declare (optimize (safety 0)))
1660 ;; We might want to think about inlining the guts of
1661 ;; CALL-WITH-...LOCK into these methods.
1662 (values
1663 (lambda (key table default)
1664 (declare (optimize speed (sb-c:verify-arg-count 0)))
1665 (truly-the
1666 (values t t &optional)
1667 (let ((table (truly-the hash-table table)))
1668 (sb-thread::with-recursive-system-lock ((hash-table-%lock table))
1669 (funcall getter key table default)))))
1670 (lambda (key table value)
1671 (declare (optimize speed (sb-c:verify-arg-count 0)))
1672 (truly-the
1673 (values t &optional)
1674 (let ((table (truly-the hash-table table)))
1675 (sb-thread::with-recursive-system-lock ((hash-table-%lock table))
1676 (funcall setter key table value)))))
1677 (lambda (key table)
1678 (declare (optimize speed (sb-c:verify-arg-count 0)))
1679 (truly-the
1680 (values t &optional)
1681 (let ((table (truly-the hash-table table)))
1682 (sb-thread::with-recursive-system-lock ((hash-table-%lock table))
1683 (funcall remover key table)))))))
1685 (defmacro pick-table-methods-1 (synchronized getter setter remover)
1686 `(locally (declare (optimize (safety 0)))
1687 (if ,synchronized
1688 (make-synchronized-table-methods #',getter #',setter #',remover)
1689 (values #',getter #',setter #',remover))))
1691 (defun pick-table-methods (synchronized kind)
1692 (declare ((integer -1 3) kind))
1693 ;; test is specified as 0..3 for a standard fun or -1 for userfun
1694 (case kind
1695 (-1 (pick-table-methods-1 synchronized gethash/any puthash/any
1696 remhash/any))
1697 (0 (pick-table-methods-1 synchronized gethash/eq puthash/eq
1698 remhash/eq))
1699 (1 (pick-table-methods-1 synchronized gethash/eql puthash/eql
1700 remhash/eql))
1701 (2 (pick-table-methods-1 synchronized gethash/equal puthash/equal
1702 remhash/equal))
1703 (3 (pick-table-methods-1 synchronized gethash/equalp puthash/equalp
1704 remhash/equalp))))
1706 ;;; so people can call #'(SETF GETHASH)
1707 ;;; FIXME: this function is not mandated. Why do we have it?
1708 (defun (setf gethash) (new-value key table &optional default)
1709 (declare (ignore default))
1710 (%puthash key table new-value))
1712 (defun hash-table-next-smashed-kv (hash-table)
1713 ;; Entries culled by GC are linked into a plain old list of cons cells,
1714 ;; because we can atomically manipulate that. We can't atomically operate
1715 ;; on the array-qua-list representation, both because we don't support
1716 ;; numeric arrays in (CAS AREF) and lockfree deletion from interior nodes
1717 ;; of singly-linked lists is tricky (a concurrent insert can get lost).
1718 (when (hash-table-smashed-cells hash-table)
1719 (binding* ((data (atomic-pop (hash-table-smashed-cells hash-table)))
1720 ((kv-index bucket) (etypecase data
1721 (fixnum (values (ldb (byte 14 14) data)
1722 (ldb (byte 14 0) data)))
1723 (cons (values (car data) (cdr data)))))
1724 (index-vector (hash-table-index-vector hash-table))
1725 (next-vector (hash-table-next-vector hash-table))
1726 (this (aref index-vector bucket))
1727 (successor (aref next-vector this)))
1728 (if (= kv-index this)
1729 ;; This pair started a chain. Removing it is easy
1730 (setf (aref index-vector bucket) successor)
1731 ;; Else, find the kv-index in the chain and snap it out.
1732 (do ((predecessor this)
1733 (this successor))
1734 ((= this 0) (signal-corrupt-hash-table hash-table))
1735 (let ((successor (aref next-vector this)))
1736 (when (= kv-index this)
1737 (return (setf (aref next-vector predecessor) successor)))
1738 (setq predecessor this this successor))))
1739 ;; Set the 'next' at kv-index to the head of the ordinary freelist
1740 ;; so that when INSERT-AT pops the freelist, it stays correct.
1741 (setf (aref next-vector kv-index) (hash-table-next-free-kv hash-table))
1742 kv-index)))
1744 ;;; We don't need the looping and checking for GC activiy in PUTHASH
1745 ;;; because insertion can not co-occur with any other operation,
1746 ;;; unlike GETHASH which we allow to execute in multiple threads.
1747 (defmacro define-ht-setter (name std-fn hash-fun-name)
1748 `(defun ,name (key table value &aux (hash-table (truly-the hash-table table))
1749 (kv-vector (hash-table-pairs hash-table)))
1750 (declare (optimize speed (sb-c:verify-arg-count 0)
1751 (sb-c:insert-array-bounds-checks 0)))
1752 (block done
1753 (let ((index (hash-table-cache hash-table)))
1754 ;; Check the most-recently-used cell
1755 (when (and (plusp index) (eq (aref kv-vector index) key))
1756 (return-from done (setf (aref kv-vector (1+ index)) value))))
1757 (with-pinned-objects (key)
1758 ;; Read the 'rehash' bit as soon as possible after pinning KEY,
1759 ;; but not before. The closer in time we observe the bit vs pinning,
1760 ;; the more likely it is to reflect at most the moved status of KEY
1761 ;; and not also the moved status of keys moved after KEY got pinned.
1762 ;; To illustrate:
1764 ;; t0 .... t1 .... t2 .... t3 ....
1765 ;; ^ ^ ^ ^
1766 ;; | | | GC |
1767 ;; Pin Possible Actual
1768 ;; observation observation
1769 ;; of 'rehash' of 'rehash'
1771 ;; If GC causes the bit to become set, and we don't read the bit
1772 ;; until t3, we're forced to conclude that KEY's hash might have been wrong.
1773 ;; Granted that the bit might have been 1 at timestamp 't1',
1774 ;; but it's best to read it at t1 and not later.
1775 (binding* ((initial-stamp (kv-vector-rehash-stamp kv-vector))
1776 ,@(ht-hash-setup hash-fun-name)
1777 ,@(ht-probe-setup std-fn)
1778 (eq-test ,(ht-probing-should-use-eq std-fn)))
1779 (declare (index/2 index))
1780 ;; Search next-vector chain for a matching key.
1781 (if eq-test
1782 ;; Unrolling a few times like in %GETHASH doesn't seem
1783 ;; to affect even the tightest microbenchmarks.
1784 (do ((next index (aref next-vector next)))
1785 ((zerop next))
1786 (declare (type index/2 next))
1787 (let ((i (* 2 next)))
1788 (when (eq key (aref kv-vector i)) ; Found, just replace the value.
1789 (setf (hash-table-cache hash-table) i)
1790 (return-from done (setf (aref kv-vector (1+ i)) value))))
1791 (check-excessive-probes 1))
1792 ,(unless (eq std-fn 'eq)
1793 `(do ((next index (aref next-vector next)))
1794 ((zerop next))
1795 (declare (type index/2 next))
1796 (when ,(ht-key-compare std-fn 'next) ; Found, just replace the value.
1797 (let ((i (* 2 next)))
1798 (setf (hash-table-cache hash-table) i)
1799 (return-from done (setf (aref kv-vector (1+ i)) value))))
1800 (check-excessive-probes 1))))
1801 ;; Detect whether the failure to find was due to key movement.
1802 ;; Only the initial state of the 'rehash' bit is important.
1803 ;; If the bit changed from 0 to 1, then KEY's hash was good because
1804 ;; it was pinned at the time we observed the rehash status to be 0.
1805 (when (and address-based-p (oddp initial-stamp))
1806 ;; The current stamp must be the same as initial-stamp, because
1807 ;; PUTHASH is disallowed concurrently with any other operation,
1808 ;; and the 'rehash' bit can't be cleared except by rehashing
1809 ;; as part of such operation.
1810 (unless (eq (kv-vector-rehash-stamp kv-vector) initial-stamp)
1811 (signal-corrupt-hash-table hash-table))
1812 (let ((key-index (%rehash-and-find hash-table initial-stamp key)))
1813 ;; If we see NIL here, it means that some other operation is racing
1814 ;; to rehash. GETHASH can deal with that scenario, PUTHASH can't.
1815 (cond ((eql key-index 0)) ; fallthrough to insert
1816 ((not (fixnump key-index)) (signal-corrupt-hash-table hash-table))
1817 (t (return-from done (setf (aref kv-vector (1+ key-index)) value))))))
1818 ;; Pop a KV slot off the free list
1819 (insert-at (truly-the (and index/2 (unsigned-byte 32))
1820 (hash-table-next-free-kv hash-table))
1821 hash-table key
1822 ;; Clip the unclipped hash from EQ-HASH* or its
1823 ;; kind to be able to pass it to INSERT-AT
1824 ;; without consing.
1825 ,(if (eq std-fn 'eq) '(clip-hash hash) 'hash)
1826 address-based-p value))))))
1828 (flet ((insert-at (index hash-table key hash address-based-p value)
1829 (declare (optimize speed (sb-c:insert-array-bounds-checks 0))
1830 (type (and index/2 (unsigned-byte 32)) index)
1831 (type clipped-hash hash))
1832 (when (zerop index)
1833 (setq index (grow-hash-table hash-table))
1834 ;; Growing the table can not make the key become found when it was not
1835 ;; found before, so we can just proceed with insertion.
1836 (aver (not (zerop index))))
1837 ;; Grab the vectors AFTER possibly growing the table
1838 (let ((kv-vector (hash-table-pairs hash-table))
1839 (next-vector (hash-table-next-vector hash-table)))
1840 (setf (hash-table-next-free-kv hash-table)
1841 (let ((hwm (kv-vector-high-water-mark kv-vector))
1842 (cap (hash-table-pairs-capacity kv-vector)))
1843 (cond ((> index hwm) ; raise the high-water-mark
1844 (setf (kv-vector-high-water-mark kv-vector) index)
1845 ;; CPU must not buffer storing the new HWM versus the
1846 ;; stores of the K+V since they wouldn't be seen.
1847 (sb-thread:barrier (:write))
1848 (cond ((= index cap) 0)
1849 (t (1+ index))))
1850 (t ; don't raise
1851 (let ((next (aref next-vector index)))
1852 (cond ((/= next 0) next)
1853 ((= hwm cap) 0)
1854 (t (1+ hwm))))))))
1856 ;; We've potentially depended on the bits of the address of KEY
1857 ;; before informing GC that we've done so, but the key is pinned,
1858 ;; so as long as the table informs GC that it has the dependency
1859 ;; by the time the key is free to move, all is well.
1860 (when address-based-p
1861 (logior-array-flags kv-vector sb-vm:vector-addr-hashing-flag))
1863 ;; Store the hash unless an EQ table. Because the key is pinned, it is
1864 ;; OK that GC would not have seen +magic-hash-vector-value+ for this
1865 ;; key if applicable.
1866 (awhen (hash-table-hash-vector hash-table)
1867 (setf (aref it index)
1868 (if address-based-p +magic-hash-vector-value+ hash)))
1870 ;; Push this slot onto the front of the chain for its bucket.
1871 ;; A chain linked to an empty cell makes no difference, as any concurrent
1872 ;; operation on this same table would constitute user error.
1873 (let* ((index-vector (hash-table-index-vector hash-table))
1874 (bucket (mask-hash hash (1- (length index-vector)))))
1875 (setf (aref next-vector index) (aref index-vector bucket)
1876 (aref index-vector bucket) index))
1877 ;; Store the pair only *after* linking the cell in. This order of operations
1878 ;; allows GC to assert that every pair in kvv is findable in a bucket.
1879 ;; Setting the kvv elements first, before chaining, would temporarily result
1880 ;; in a non-findable key which we'd have to heuristically allow based on
1881 ;; implicit pinning.
1882 (let ((i (* 2 index)))
1883 (setf (aref kv-vector i) key
1884 (aref kv-vector (truly-the index (1+ i))) value
1885 (hash-table-cache hash-table) i)))
1886 (locally (declare (optimize (safety 0)))
1887 (incf (hash-table-%count hash-table)))
1888 value))
1890 (defun puthash/weak (key hash-table value)
1891 (declare (type hash-table hash-table) (optimize speed))
1892 (with-weak-hash-table-entry
1893 (declare (ignore predecessor))
1894 (cond ((= physical-index 0)
1895 ;; There are two kinds of freelists. Prefer a smashed cell
1896 ;; so that we might shorten the chain it belonged to.
1897 (insert-at (or (hash-table-next-smashed-kv hash-table)
1898 (hash-table-next-free-kv hash-table))
1899 hash-table key hash address-sensitive-p value))
1900 ((or (empty-ht-slot-p (cas (weak-kvv-ref kv-vector (1+ physical-index))
1901 probed-value value))
1902 (neq (weak-kvv-ref kv-vector physical-index) probed-key))
1903 (signal-corrupt-hash-table hash-table))
1904 (t value))))
1905 (define-ht-setter puthash/eq eq eq-hash*)
1906 (define-ht-setter puthash/eql eql eql-hash)
1907 (define-ht-setter puthash/equal equal equal-hash)
1908 (define-ht-setter puthash/equalp equalp equalp-hash)
1909 (define-ht-setter puthash/any nil nil))
1911 (defmacro define-remhash (name std-fn hash-fun-name)
1912 `(defun ,name (key table &aux (hash-table (truly-the hash-table table))
1913 (kv-vector (hash-table-pairs hash-table)))
1914 (declare (optimize speed (sb-c:verify-arg-count 0)
1915 (sb-c:insert-array-bounds-checks 0)))
1916 ;; The cache provides no benefit to REMHASH. A hit would just mean there is work
1917 ;; to do in removing the item from a chain, whereas a miss means we don't know
1918 ;; if there is work to do, so effectively there is work to do either way.
1919 (with-pinned-objects (key)
1920 ;; See comment in DEFINE-HT-SETTER about why to read initial-stamp
1921 ;; as soon as possible after pinning KEY.
1922 (binding* ((initial-stamp (kv-vector-rehash-stamp kv-vector))
1923 ,@(ht-hash-setup hash-fun-name)
1924 ,@(ht-probe-setup std-fn)
1925 (eq-test ,(ht-probing-should-use-eq std-fn)))
1926 (declare (index/2 index) (ignore probe-limit))
1927 (block done
1928 (cond ((zerop index)) ; bucket is empty
1929 (,(ht-key-compare std-fn 'index :hash-test :permissive)
1930 ;; Removing the key at the header of the chain is exceptional
1931 ;; because it has no predecessor,
1932 (setf (aref index-vector bucket) (aref next-vector index))
1933 (return-from done
1934 (clear-slot index hash-table kv-vector next-vector)))
1935 (eq-test
1936 (when (%remhash/eq key hash-table kv-vector next-vector index)
1937 (return-from done t)))
1938 ,@(unless (eq std-fn 'eq)
1939 `((t
1940 (do ((probe-limit (length next-vector))
1941 (predecessor index this)
1942 (this (aref next-vector index) (aref next-vector this)))
1943 ((zerop this) nil)
1944 (declare (type index/2 predecessor this))
1945 (when ,(ht-key-compare std-fn 'this)
1946 (setf (aref next-vector predecessor) (aref next-vector this))
1947 (return-from done
1948 (clear-slot this hash-table kv-vector next-vector)))
1949 (check-excessive-probes 1))))))
1950 ;; Detect whether the failure to find was due to key movement.
1951 ;; Only the initial state of the 'rehash' bit is important.
1952 ;; If the bit changed from 0 to 1, then KEY's hash was good because
1953 ;; it was pinned at the time we observed the rehash status to be 0.
1954 (when (and address-based-p (oddp initial-stamp))
1955 (remove-from-bucket key bucket hash-table initial-stamp)))))))
1957 (defun remhash/weak (key hash-table)
1958 (declare (type hash-table hash-table) (optimize speed))
1959 (with-weak-hash-table-entry
1960 (unless (eql physical-index 0)
1961 ;; Mark slot as empty.
1962 (if (or (empty-ht-slot-p (cas (weak-kvv-ref kv-vector (1+ physical-index))
1963 probed-value +empty-ht-slot+))
1964 (neq (cas (weak-kvv-ref kv-vector physical-index)
1965 probed-key +empty-ht-slot+)
1966 probed-key))
1967 (signal-corrupt-hash-table hash-table)
1968 (let* ((index (ash physical-index -1))
1969 (next-vector (hash-table-next-vector hash-table))
1970 (successor (aref next-vector index)))
1971 ;; Unlink from bucket's chain
1972 (if predecessor
1973 (setf (aref next-vector predecessor) successor)
1974 (let* ((iv (hash-table-index-vector hash-table))
1975 (bucket (mask-hash hash (1- (length iv)))))
1976 (setf (aref iv bucket) successor)))
1977 ;; Push onto free chain
1978 (setf (aref next-vector index) (hash-table-next-free-kv hash-table)
1979 (hash-table-next-free-kv hash-table) index)
1980 (decf (hash-table-%count hash-table))
1981 t)))))
1983 (labels ((clear-slot (index hash-table kv-vector next-vector)
1984 (declare (type index/2 index))
1985 ;; Mark slot as empty.
1986 (let ((physindex (* 2 index)))
1987 (setf (aref kv-vector physindex) +empty-ht-slot+
1988 (aref kv-vector (1+ physindex)) +empty-ht-slot+))
1989 ;; Push KV slot onto free chain.
1990 (setf (aref next-vector index) (hash-table-next-free-kv hash-table)
1991 (hash-table-next-free-kv hash-table) index)
1992 ;; On parallel accesses this may turn out to be a
1993 ;; type-error, so don't turn down the safety!
1994 (decf (hash-table-%count hash-table))
1996 (remove-from-bucket (key bucket hash-table initial-stamp
1997 &aux (kv-vector (hash-table-pairs hash-table)))
1998 ;; Remove KEY from BUCKET which is based on the current address
1999 ;; of key after pinning. When the key was not found initially,
2000 ;; the "problem" so to speak was that the bucket that was searched
2001 ;; did not hold the key, and not that search was done on the wrong
2002 ;; bucket. Rehashing will place the key into the expected bucket.
2004 ;; The current stamp must be the same as initial-stamp, because
2005 ;; REMHASH is disallowed concurrently with any other operation,
2006 ;; and the 'rehash' bit can't be cleared except by rehashing
2007 ;; as part of such operation.
2008 (unless (eq (kv-vector-rehash-stamp kv-vector) initial-stamp)
2009 (signal-corrupt-hash-table hash-table))
2010 (let ((key-index (%rehash-and-find hash-table initial-stamp key)))
2011 ;; If we see NIL here, it means that some other operation is racing
2012 ;; to rehash. GETHASH can deal with that scenario, REMHASH can't.
2013 (unless (fixnump key-index)
2014 (signal-corrupt-hash-table hash-table))
2015 (when (/= key-index 0) ; found
2016 (let* ((index-vector (hash-table-index-vector hash-table))
2017 (start (aref index-vector bucket))
2018 (next-vector (hash-table-next-vector hash-table))
2019 (next (aref next-vector start))
2020 (pair-index (ash key-index -1)))
2021 (if (if (= start pair-index) ; remove head of chain
2022 (setf (aref index-vector bucket) next)
2023 (do ((probe-limit (length next-vector))
2024 (predecessor start this)
2025 (this next (aref next-vector this)))
2026 ((zerop this))
2027 (declare (type index/2 predecessor this))
2028 (when (eql this pair-index)
2029 (return (setf (aref next-vector predecessor)
2030 (aref next-vector this))))
2031 (check-excessive-probes 1)))
2032 (clear-slot pair-index hash-table kv-vector next-vector)
2033 (signal-corrupt-hash-table hash-table))))))
2034 (%remhash/eq (key hash-table kv-vector next-vector start)
2035 (do ((probe-limit (length next-vector))
2036 (predecessor start this)
2037 (this (aref next-vector start) (aref next-vector this)))
2038 ((zerop this) nil)
2039 (declare (type index/2 predecessor this))
2040 (when (eq key (aref kv-vector (* 2 this)))
2041 (setf (aref next-vector predecessor) (aref next-vector this))
2042 (return (clear-slot this hash-table kv-vector next-vector)))
2043 (check-excessive-probes 1))))
2045 (define-remhash remhash/eq eq eq-hash*)
2046 (define-remhash remhash/eql eql eql-hash)
2047 (define-remhash remhash/equal equal equal-hash)
2048 (define-remhash remhash/equalp equalp equalp-hash)
2049 (define-remhash remhash/any nil nil))
2051 (defun remhash (key hash-table)
2052 "Remove the entry in HASH-TABLE associated with KEY. Return T if
2053 there was such an entry, or NIL if not."
2054 (funcall (hash-table-remhash-impl hash-table) key hash-table))
2056 (defun clrhash (hash-table)
2057 "This removes all the entries from HASH-TABLE and returns the hash
2058 table itself."
2059 (funcall (hash-table-clrhash-impl hash-table) hash-table))
2061 (defun clrhash-impl (hash-table)
2062 ;; This used to do nothing at all for tables that has a COUNT of 0,
2063 ;; but that wasn't quite right, because some steps below pertain to
2064 ;; getting the initial state back to that of a freshly made table.
2065 ;; In particular, the need-to-rehash flag should be cleared, and the freelist
2066 ;; should be reset so that we start to consume k/v cells leftmost first
2067 ;; instead of whatever random order they were left in.
2069 ;; It is probably not strictly necessary for vectors marked as valid-hashing to
2070 ;; be initialized with empty-ht-slot, because GC regards the portion of the vector
2071 ;; beyond the HWM as unused. Though for weak tables, some invariants can
2072 ;; be checked by having the empty markers but couldn't be without.
2073 ;; [Reusing those elements would be a two-step process: set them to 0,
2074 ;; bump the HWM, set them to desired values - because you can't let GC
2075 ;; observe junk, but you can't put good value at higher than the HWM]
2076 (when (plusp (kv-vector-high-water-mark (hash-table-pairs hash-table)))
2077 (dx-flet ((clear ()
2078 (let* ((kv-vector (hash-table-pairs hash-table))
2079 (high-water-mark (kv-vector-high-water-mark kv-vector)))
2080 (when (hash-table-weak-p hash-table)
2081 (aver (eq (kv-vector-supplement kv-vector) hash-table)))
2082 ;; Remove address-sensitivity.
2083 (reset-array-flags kv-vector sb-vm:vector-addr-hashing-flag)
2084 ;; Do this only after unsetting the address-sensitive bit,
2085 ;; otherwise GC might come along and touch this bit again.
2086 (setf (kv-vector-rehash-stamp kv-vector) 0)
2087 ;; We always deposit empty markers into k/v pairs that are REMHASHed,
2088 ;; so a count of 0 implies no clearing need be done.
2089 (when (plusp (hash-table-%count hash-table))
2090 (setf (hash-table-%count hash-table) 0)
2091 ;; Fill all slots with the empty marker.
2092 (fill kv-vector +empty-ht-slot+ :start 2 :end (* (1+ high-water-mark) 2))
2093 ;; Clear the index-vector.
2094 ;; Don't need to clear the hash-vector or the next-vector.
2095 (fill (hash-table-index-vector hash-table) 0))
2096 (when (typep hash-table 'general-hash-table)
2097 (setf (hash-table-smashed-cells hash-table) nil))
2098 (setf (hash-table-next-free-kv hash-table) 1
2099 (kv-vector-high-water-mark kv-vector) 0))))
2100 (if (hash-table-synchronized-p hash-table)
2101 (sb-thread::call-with-recursive-system-lock #'clear (hash-table-%lock hash-table))
2102 (clear))))
2103 hash-table)
2106 ;;;; methods on HASH-TABLE
2108 ;;; Return an association list representing the same data as HASH-TABLE.
2109 ;;; Iterate downward so that PUSH creates the result in insertion order.
2110 ;;; One the one hand, this should not to be construed as a guarantee about
2111 ;;; the order, but on the other, it is convenient to see key/values in the
2112 ;;; same order as insertion, and moreover, preserving that order makes
2113 ;;; %STUFF-HASH-TABLE produce the same k/v vector.
2114 (defun %hash-table-alist (hash-table)
2115 (let ((result nil))
2116 (let ((kvv (hash-table-pairs hash-table)))
2117 (do ((i (* 2 (kv-vector-high-water-mark kvv)) (- i 2)))
2118 ((= i 0))
2119 (let ((k (aref kvv i))
2120 (v (aref kvv (1+ i))))
2121 (unless (or (empty-ht-slot-p k) (empty-ht-slot-p v))
2122 (push (cons k v) result)))))
2123 result))
2125 ;;; Stuff an association list, or a vector, into HASH-TABLE. Return the hash table,
2126 ;;; so that we can use this for the *PRINT-READABLY* case in PRINT-OBJECT (HASH-TABLE T)
2127 ;;; without having to worry about LET forms and readable gensyms and stuff.
2128 (defun %stuff-hash-table (hash-table data &optional pure)
2129 (if (vectorp data)
2130 (dovector (x data) (setf (gethash (car x) hash-table) (cdr x)))
2131 (dolist (x data) (setf (gethash (car x) hash-table) (cdr x))))
2132 (when pure
2133 ;; Mark the index vector, next-vector, hash-vector (if present),
2134 ;; and even the key vector, as shareable, provided that no key is hashed
2135 ;; address-sensitively. As a first crack I'm just requiring keys to be
2136 ;; fixnum or character, but some table types would stably hash more things.
2137 (let ((stably-hashed
2138 (loop for k being each hash-key of hash-table
2139 always (typep k '(or fixnum character)))))
2140 (when stably-hashed
2141 (logically-readonlyize (hash-table-pairs hash-table))
2142 (logically-readonlyize (hash-table-index-vector hash-table))
2143 (logically-readonlyize (hash-table-next-vector hash-table))
2144 (awhen (hash-table-hash-vector hash-table) (logically-readonlyize it)))))
2145 hash-table)
2147 ;;; Return a list of keyword args and values to use for MAKE-HASH-TABLE
2148 ;;; when reconstructing HASH-TABLE.
2149 (flet ((%hash-table-ctor (hash-table &aux (test (hash-table-test hash-table)))
2150 (when (or (not (logtest (hash-table-flags hash-table) hash-table-userfun-flag))
2151 ;; If it has a named test function - it wasn't a lambda expression -
2152 ;; and the table's hash-function is identical to the hash function
2153 ;; dictated by *USER-HASH-TABLE-TESTS* for that test, we're OK.
2154 ;; And it's not worth the risk of trying to reverse-engineer the hash
2155 ;; function if all we have is a name.
2156 (and test (eq (third (assoc test *user-hash-table-tests*))
2157 (hash-table-hash-fun hash-table))))
2158 `(make-hash-table
2159 ,@(loop for (key accessor default)
2161 (load-time-value
2162 `((:test ,#'hash-table-test eql)
2163 (:size ,#'hash-table-size ,+min-hash-table-size+)
2164 (:rehash-size ,#'hash-table-rehash-size ,default-rehash-size)
2165 (:rehash-threshold ,#'hash-table-rehash-threshold 1.0)
2166 (:synchronized ,#'hash-table-synchronized-p nil)
2167 (:weakness ,#'hash-table-weakness nil)))
2168 for value = (funcall accessor hash-table)
2169 unless (eql value default)
2170 collect key
2172 collect (if (self-evaluating-p value)
2173 value
2174 `',value))))))
2176 (defmethod print-object ((hash-table hash-table) stream)
2177 (declare (type stream stream))
2178 (let ((ctor (and *print-readably* *read-eval* (%hash-table-ctor hash-table))))
2179 (cond
2180 ((not ctor)
2181 ;; Perhaps we should add :SYNCHRONIZED to the string?
2182 (print-unreadable-object (hash-table stream :type t :identity t)
2183 (format stream
2184 ":TEST ~S~@[ :HASH-FUNCTION ~S~] :COUNT ~S~@[ :WEAKNESS ~S~]"
2185 (or (hash-table-test hash-table) (hash-table-test-fun hash-table))
2186 (when (logtest (hash-table-flags hash-table) hash-table-userfun-flag)
2187 (hash-table-hash-fun hash-table))
2188 (hash-table-count hash-table)
2189 (hash-table-weakness hash-table))))
2191 (write-string "#." stream)
2192 (let ((alist (%hash-table-alist hash-table)))
2193 (write (if alist
2194 `(%stuff-hash-table ,ctor ',alist)
2195 ctor)
2196 :stream stream))))))
2198 (defmethod make-load-form ((hash-table hash-table) &optional environment)
2199 (declare (ignore environment))
2200 (let ((ctor (%hash-table-ctor hash-table)))
2201 (if ctor
2202 (values ctor
2203 ;; This uses a separate initform in case the hash table contains itself
2204 ;; as either a key or value.
2205 ;; FIXME: k/v pairs would take less space as a vector, not an alist.
2206 (unless (zerop (hash-table-count hash-table))
2207 `(%stuff-hash-table ,hash-table ',(%hash-table-alist hash-table))))
2208 (error "~S is not externalizable" hash-table))))
2211 ;;; This assignment has to occur some time after the defstruct.
2212 ;;; We don't call EQUALP on hash-table, so as late as possible is fine.
2213 ;;; It can't go in src/code/pred whose forms execute *before* the defstruct,
2214 ;;; so its effect would just get clobbered by the defstruct.
2215 (sb-kernel::assign-equalp-impl 'hash-table #'hash-table-equalp)
2217 (!defun-from-collected-cold-init-forms !hash-table-cold-init)
2220 (defun memusage (x)
2221 (+ (sb-vm::primitive-object-size (hash-table-pairs x))
2222 (acond ((hash-table-hash-vector x) (sb-vm::primitive-object-size it)) (t 0))
2223 (sb-vm::primitive-object-size (hash-table-index-vector x))
2224 (sb-vm::primitive-object-size (hash-table-next-vector x))))
2226 (defun show-address-sensitivity (&optional tbl)
2227 (flet ((show1 (tbl)
2228 (let ((kv (hash-table-pairs tbl))
2229 (hashes (hash-table-hash-vector tbl))
2230 (address-sensitive 0))
2231 (loop for i from 2 below (length kv) by 2
2233 (unless (unbound-marker-p (aref kv i))
2234 (when (eq (aref hashes (ash i -1)) +magic-hash-vector-value+)
2235 (incf address-sensitive))))
2236 (when (plusp address-sensitive)
2237 (format t "~3d ~s~%" address-sensitive tbl)))))
2238 (if tbl
2239 (show1 tbl)
2240 (dolist (tbl (sb-vm::list-allocated-objects :all :test #'hash-table-p))
2241 (when (and (plusp (hash-table-count tbl)) (hash-table-hash-vector tbl))
2242 (show-address-sensitivity tbl))))))
2244 (defun hash-table-chain (tbl pair-index)
2245 (when (plusp pair-index)
2246 (nconc (list pair-index)
2247 (hash-table-chain tbl (aref (hash-table-next-vector tbl) pair-index)))))
2249 (defun hash-table-freelist (tbl)
2250 (hash-table-chain tbl (hash-table-next-free-kv tbl)))
2252 (defun show-chains (tbl &aux (nv (hash-table-next-vector tbl))
2253 (tot-len 0) (max-len 0) (n-chains 0))
2254 (flet ((show-chain (label next &aux (len 0))
2255 (unless (eql next 0)
2256 (write-string label)
2257 (loop (format t " ~d" next)
2258 (incf len)
2259 (when (zerop (setq next (aref nv next))) (return)))
2260 (terpri))
2261 len))
2262 (loop for x across (hash-table-index-vector tbl)
2263 for i from 0
2264 do (let ((len (show-chain (format nil "Bucket ~d:" i) x)))
2265 (when (plusp len)
2266 (incf tot-len len)
2267 (setf max-len (max len max-len))
2268 (incf n-chains))))
2269 (format t "maxlen=~d avglen=~f~%" max-len (/ tot-len n-chains))
2270 (show-chain "Freelist:" (hash-table-next-free-kv tbl))
2271 (awhen (and (typep tbl 'general-hash-table) (hash-table-smashed-cells tbl))
2272 (format t "smashed=~d~%"
2273 (mapcar (lambda (x)
2274 (if (fixnump x)
2275 (cons (ldb (byte 14 14) x) (ldb (byte 14 0) x))
2277 it)))))
2279 (defun show-load-factors ()
2280 (let ((list (sort (sb-vm::list-allocated-objects
2281 :all :test #'hash-table-p)
2283 :key #'hash-table-count)))
2284 (dolist (ht list)
2285 (format t "~,4f ~7d ~s~%"
2286 (/ (hash-table-count ht) (length (hash-table-index-vector ht)))
2287 (hash-table-mem-used ht)
2288 ht))))
2290 (defun hash-table-mem-used (ht)
2291 (+ (primitive-object-size (hash-table-pairs ht))
2292 (primitive-object-size (hash-table-index-vector ht))
2293 (primitive-object-size (hash-table-next-vector ht))
2294 (acond ((hash-table-hash-vector ht) (primitive-object-size it))
2295 (t 0))))
2297 (defun show-growth (&optional (factor 1.5))
2298 (flet ((memused-str (x)
2299 (cond ((>= x (expt 1024 4)) (format nil "~dG" (ceiling (/ x (expt 1024 3)))))
2300 ((>= x (expt 1024 3)) (format nil "~dM" (ceiling (/ x (expt 1024 2)))))
2301 ((>= x (expt 1024 2)) (format nil "~dK" (ceiling (/ x 1024))))
2302 (t x)))
2303 (compute-memused (n-buckets n-cells) ; approximately right,
2304 ;; disregarding overhead cells and padding words
2305 (+ (* n-cells (* 2 sb-vm:n-word-bytes)) ; 2 words per cell
2306 (* n-buckets 4) ; INDEX-VECTOR = one 32-bit int per bucket
2307 (* n-cells 4) ; NEXT-VECTOR = one 32-bit int per cell
2308 (* n-cells 4))) ; HASH-VECTOR = one 32-bit int per cell
2309 (log2-buckets (n-buckets)
2310 (integer-length (1- n-buckets))))
2311 (let* ((size 7)
2312 (n-buckets (power-of-two-ceiling size))
2313 (memused (compute-memused n-buckets size)))
2314 (format t " size bits LF mem~%")
2315 (format t "~12d ~6d ~9,4f ~13d~%" size
2316 (log2-buckets n-buckets) (/ size n-buckets) memused)
2317 (loop
2318 (let* ((new-size (truncate (* size factor)))
2319 (new-n-buckets (power-of-two-ceiling new-size))
2320 (full-LF (/ new-size new-n-buckets)))
2321 (when (> (log2-buckets new-n-buckets) 31) (return))
2322 ;; try to keep the load factor at full load within a certain range
2323 (cond ((> full-lf .9)
2324 (setq new-size (floor (* new-n-buckets 85/100))))
2325 ((< full-lf .55)
2326 (setq new-size (floor (* new-n-buckets 65/100)))))
2327 (let ((new-memused (compute-memused new-n-buckets new-size)))
2328 (format t "~12d ~6d ~9,4f ~13@a (* ~f)~%"
2329 new-size (log2-buckets new-n-buckets)
2330 (/ new-size new-n-buckets)
2331 (memused-str new-memused) (/ new-memused memused))
2332 (setq size new-size memused new-memused)))))))
2334 ;;; You can't attain an arbitrary rehash size using power-of-2 tables
2335 ;;; because all you can do is double the number of buckets.
2336 ;;; However, by doubling the count only on alternate resizings, we can
2337 ;;; approximate growing at rate slower than doubling in terms of space used.
2338 ;;; This table shows that using the default resize factor of 1.5x we see
2339 ;;; a fairly smooth increase in memory consumed at each resizing
2340 ;;; (about 1.3x to 1.6x the usage at the old size) while bounding the LF
2341 ;;; to between .6 and .85 if every k/v cell is in use at the new size.
2343 size bits LF mem
2344 7 3 0.8750 200
2345 10 4 0.6250 304 (* 1.52)
2346 13 4 0.8125 376 (* 1.2368422)
2347 19 5 0.5938 584 (* 1.5531915)
2348 28 5 0.8750 800 (* 1.369863)
2349 42 6 0.6563 1264 (* 1.58)
2350 54 6 0.8438 1552 (* 1.227848)
2351 81 7 0.6328 2456 (* 1.5824742)
2352 108 7 0.8438 3104 (* 1.2638437)
2353 162 8 0.6328 4912 (* 1.5824742)
2354 217 8 0.8477 6232 (* 1.2687297)
2355 325 9 0.6348 9848 (* 1.5802311)
2356 435 9 0.8496 12488 (* 1.2680748)
2357 652 10 0.6367 19744 (* 1.5810378)
2358 870 10 0.8496 24976 (* 1.2649919)
2359 1305 11 0.6372 39512 (* 1.5819987)
2360 1740 11 0.8496 49952 (* 1.2642236)
2361 2610 12 0.6372 79024 (* 1.5819987)
2362 3481 12 0.8499 99928 (* 1.2645272)
2363 5221 13 0.6373 158072 (* 1.581859)
2364 6963 13 0.8500 199880 (* 1.264487)
2365 10444 14 0.6375 316192 (* 1.5819092)
2366 13926 14 0.8500 399760 (* 1.2642951)
2367 20889 15 0.6375 632408 (* 1.5819691)
2368 27852 15 0.8500 799520 (* 1.2642472)
2369 41778 16 0.6375 1236K (* 1.5819691)
2370 55705 16 0.8500 1562K (* 1.2642661)
2371 83557 17 0.6375 2471K (* 1.5819604)
2372 111411 17 0.8500 3124K (* 1.2642636)
2373 167116 18 0.6375 4941K (* 1.5819635)
2374 222822 18 0.8500 6247K (* 1.2642516)
2375 334233 19 0.6375 9882K (* 1.5819674)
2376 445644 19 0.8500 12493K (* 1.2642486)
2377 668466 20 0.6375 19764K (* 1.5819674)
2378 891289 20 0.8500 24986K (* 1.2642498)
2379 1336933 21 0.6375 39527K (* 1.5819668)
2380 1782579 21 0.8500 49972K (* 1.2642497)
2381 2673868 22 0.6375 79053K (* 1.581967)
2382 3565158 22 0.8500 99943K (* 1.2642488)
2383 5347737 23 0.6375 158106K (* 1.5819672)
2384 7130316 23 0.8500 199885K (* 1.2642487)
2385 10695474 24 0.6375 316212K (* 1.5819672)
2386 14260633 24 0.8500 399770K (* 1.2642487)
2387 21390950 25 0.6375 632423K (* 1.5819672)
2388 28521267 25 0.8500 799540K (* 1.2642487)
2389 42781904 26 0.6375 1236M (* 1.5819674)
2390 57042534 26 0.8500 1562M (* 1.2642486)
2391 85563808 27 0.6375 2471M (* 1.5819674)
2392 114085068 27 0.8500 3124M (* 1.2642486)
2393 171127616 28 0.6375 4941M (* 1.5819674)
2394 228170137 28 0.8500 6247M (* 1.2642486)
2395 342255232 29 0.6375 9882M (* 1.5819674)
2396 456340275 29 0.8500 12493M (* 1.2642486)
2397 684510464 30 0.6375 19764M (* 1.5819674)
2398 912680550 30 0.8500 24986M (* 1.2642486)
2399 1369020928 31 0.6375 39527M (* 1.5819674)
2400 1825361100 31 0.8500 49972M (* 1.2642486)