/[cmucl]/src/code/hash-new.lisp
ViewVC logotype

Contents of /src/code/hash-new.lisp

Parent Directory Parent Directory | Revision Log Revision Log


Revision 1.55 - (show annotations)
Wed Aug 11 17:40:09 2010 UTC (3 years, 8 months ago) by rtoy
Branch: MAIN
CVS Tags: GIT-CONVERSION, cross-sol-x86-merged, cross-sol-x86-base, snapshot-2010-12, snapshot-2010-11, snapshot-2011-09, snapshot-2011-06, snapshot-2011-07, snapshot-2011-04, snapshot-2011-02, snapshot-2011-03, snapshot-2011-01, cross-sol-x86-2010-12-20, cross-sparc-branch-base, HEAD
Branch point for: cross-sparc-branch, cross-sol-x86-branch
Changes since 1.54: +10 -4 lines
Trying to has a NaN causes an error.  Don't add zero if it's a NaN.
1 ;;; -*- Package: CL -*-
2 ;;;
3 ;;; **********************************************************************
4 ;;; This code was written as part of the CMU Common Lisp project at
5 ;;; Carnegie Mellon University, and has been placed in the public domain.
6 ;;;
7 (ext:file-comment
8 "$Header: /tiger/var/lib/cvsroots/cmucl/src/code/hash-new.lisp,v 1.55 2010/08/11 17:40:09 rtoy Rel $")
9 ;;;
10 ;;; **********************************************************************
11 ;;;
12 ;;; Hashing and hash table functions for Spice Lisp.
13 ;;; Originally written by Skef Wholey.
14 ;;; Everything except SXHASH rewritten by William Lott.
15 ;;; Hash table functions rewritten by Douglas Crosher, 1997.
16 ;;; Equalp hashing by William Newman, Cadabra Inc, and Douglas Crosher, 2000.
17 ;;;
18 (in-package :lisp)
19
20 (intl:textdomain "cmucl")
21
22 (export '(hash-table hash-table-p make-hash-table
23 gethash remhash maphash clrhash
24 hash-table-count with-hash-table-iterator
25 hash-table-rehash-size hash-table-rehash-threshold
26 hash-table-size hash-table-test sxhash))
27
28 (in-package :ext)
29 (export '(define-hash-table-test))
30
31 (in-package :lisp)
32
33 (register-lisp-runtime-feature :hash-new)
34
35
36 ;;;; The hash-table structures.
37
38 ;;; HASH-TABLE -- defstruct.
39 ;;;
40 (defstruct (hash-table
41 (:constructor %make-hash-table)
42 (:print-function %print-hash-table)
43 (:make-load-form-fun make-hash-table-load-form))
44 _N"Structure used to implement hash tables."
45 ;;
46 ;; The type of hash table this is. Only used for printing and as part of
47 ;; the exported interface.
48 (test (required-argument) :type symbol :read-only t)
49 ;;
50 ;; The function used to compare two keys. Returns T if they are the same
51 ;; and NIL if not.
52 (test-fun (required-argument) :type function :read-only t)
53 ;;
54 ;; The function used to compute the hashing of a key. Returns two values:
55 ;; the index hashing and T if that might change with the next GC.
56 (hash-fun (required-argument) :type function :read-only t)
57 ;;
58 ;; How much to grow the hash table by when it fills up. If an index, then
59 ;; add that amount. If a floating point number, then multiply it by that.
60 (rehash-size (required-argument) :type (or index (single-float (1.0)))
61 :read-only t)
62 ;;
63 ;; How full the hash table has to get before we rehash.
64 (rehash-threshold (required-argument) :type (single-float (0.0) 1.0)
65 :read-only t)
66 ;;
67 ;; The number of entries before a rehash, just the one less than the
68 ;; size of the next-vector, hash-vector, and half the size of the
69 ;; kv-vector.
70 (rehash-trigger (required-argument) :type index)
71 ;;
72 ;; The current number of entries in the table.
73 (number-entries 0 :type index)
74 ;;
75 ;; The Key-Value pair vector.
76 (table (required-argument) :type simple-vector)
77 ;;
78 ;; Non-nil if this is a weak hash table. Four separate types of
79 ;; weakness are supported: :key, :value, :key-and-value,
80 ;; :key-or-value. The entry in the table is retained if the key,
81 ;; (respectively, value, key and value, key or value) is alive
82 ;; because it is referenced elsewhere. If the condition does not
83 ;; hold, the entry is removed. For tables with a weak key, EQL or
84 ;; EQ must be used as the test.
85 (weak-p nil :type (member nil
86 :key
87 :value
88 :key-and-value
89 :key-or-value))
90 ;;
91 ;; Index into the next-vector, chaining together buckets that need
92 ;; to be rehashed because their hashing is EQ based and the key has
93 ;; been moved by the garbage collector.
94 (needing-rehash 0 :type index)
95 ;;
96 ;; Index into the Next vector chaining together free slots in the KV
97 ;; vector.
98 (next-free-kv 0 :type index)
99 ;;
100 ;; The index vector. This may be larger than the hash size to help
101 ;; reduce collisions.
102 (index-vector (required-argument)
103 :type (simple-array (unsigned-byte 32) (*)))
104 ;;
105 ;; This table parallels the KV vector, and is used to chain together
106 ;; the hash buckets, the free list, and the values needing rehash, a
107 ;; slot will only ever be in one of these lists.
108 (next-vector (required-argument) :type (simple-array (unsigned-byte 32) (*)))
109 ;;
110 ;; This table parallels the KV table, and can be used to store the
111 ;; hash associated with the key, saving recalculation. Could be
112 ;; useful for EQL, and EQUAL hash tables. This table is not needed
113 ;; for EQ hash tables (and is NIL in that case), and when present the
114 ;; value of #x8000000 represents EQ-based hashing on the respective
115 ;; Key.
116 (hash-vector nil :type (or null (simple-array (unsigned-byte 32) (*))))
117 ;;
118 ;; This is used by GC to chain the list of weak hash tables
119 ;; together. It should otherwise always be NIL.
120 (next-weak-table nil :type (or null hash-table)))
121
122 ;;;
123 (defun %print-hash-table (ht stream depth)
124 (declare (ignore depth) (stream stream))
125 (print-unreadable-object (ht stream :type t :identity t)
126 (format stream "~S ~S ~S ~S ~S ~D"
127 :test
128 (hash-table-test ht)
129 :weak-p
130 (hash-table-weak-p ht)
131 :count
132 (hash-table-number-entries ht))))
133
134 (defconstant max-hash most-positive-fixnum)
135
136 (deftype hash ()
137 `(integer 0 ,max-hash))
138
139 ;; This value in the hash-vector indicates the the key uses EQ-based
140 ;; hashing (i.e., either EQ or EQL).
141 (defconstant +eq-based-hash-value+ #x80000000)
142
143
144 ;;;; Utility functions.
145
146 (declaim (inline pointer-hash))
147 (defun pointer-hash (key)
148 (declare (values hash))
149 (truly-the hash (%primitive make-fixnum key)))
150
151 (declaim (inline eq-hash))
152 (defun eq-hash (key)
153 (declare (values hash (member t nil)))
154 (values (pointer-hash key)
155 (oddp (get-lisp-obj-address key))))
156
157 (declaim (inline eql-hash))
158 (defun eql-hash (key)
159 (declare (values hash (member t nil)))
160 (if (numberp key)
161 (equal-hash key)
162 (eq-hash key)))
163
164 (declaim (inline equal-hash))
165 (defun equal-hash (key)
166 (declare (values hash (member t nil)))
167 (values (sxhash key) nil))
168
169 (defun equalp-hash (key)
170 (declare (values hash (member t nil)))
171 (values (internal-equalp-hash key 0) nil))
172
173
174 (defun almost-primify (num)
175 (declare (type index num))
176 "Almost-Primify returns an almost prime number greater than or equal
177 to NUM."
178 (if (= (rem num 2) 0)
179 (setq num (+ 1 num)))
180 (if (= (rem num 3) 0)
181 (setq num (+ 2 num)))
182 (if (= (rem num 7) 0)
183 (setq num (+ 4 num)))
184 num)
185
186
187
188 ;;;; User defined hash table tests.
189
190 ;;; *HASH-TABLE-TESTS* -- Internal.
191 ;;;
192 (defvar *hash-table-tests* nil)
193
194 ;;; DEFINE-HASH-TABLE-TEST -- Public.
195 ;;;
196 (defun define-hash-table-test (name test-fun hash-fun)
197 "Define a new kind of hash table test."
198 (declare (type symbol name)
199 (type function test-fun hash-fun))
200 (setf *hash-table-tests*
201 (cons (list name test-fun hash-fun)
202 (remove name *hash-table-tests* :test #'eq :key #'car)))
203 name)
204
205
206 ;;;; Construction and simple accessors.
207
208 ;;; MAKE-HASH-TABLE -- public.
209 ;;;
210 (defun make-hash-table (&key (test 'eql) (size 65) (rehash-size 1.5)
211 (rehash-threshold 1.0) (weak-p nil))
212 "Creates and returns a new hash table. The keywords are as follows:
213 :TEST -- Indicates what kind of test to use. Only EQ, EQL, EQUAL,
214 and EQUALP are currently supported.
215 :SIZE -- A hint as to how many elements will be put in this hash
216 table.
217 :REHASH-SIZE -- Indicates how to expand the table when it fills up.
218 If an integer, add space for that many elements. If a floating
219 point number (which must be greater than 1.0), multiple the size
220 by that amount.
221 :REHASH-THRESHOLD -- Indicates how dense the table can become before
222 forcing a rehash. Can be any positive number <= to 1, with density
223 approaching zero as the threshold approaches 0. Density 1 means an
224 average of one entry per bucket.
225 CMUCL Extension:
226 :WEAK-P -- Weak hash table. Can only be used when the key is 'eq or 'eql.
227 An entry in the table is remains if the condition holds:
228
229 :KEY -- key is referenced elsewhere
230 :VALUE -- value is referenced elsewhere
231 :KEY-AND-VALUE -- key and value are referenced elsewhere
232 :KEY-OR-VALUE -- key or value is referenced elsewhere
233
234 If the condition does not hold, the entry is removed. For
235 backward compatibility, a value of T is the same as :KEY."
236 (declare (type (or function symbol) test)
237 (type index size)
238 (type (member t nil :key :value :key-and-value :key-or-value) weak-p))
239 (let ((rehash-size (if (integerp rehash-size)
240 rehash-size
241 (float rehash-size 1.0))))
242 (when (eq weak-p t)
243 (setf weak-p :key))
244 (multiple-value-bind
245 (test test-fun hash-fun)
246 (cond ((or (eq test #'eq) (eq test 'eq))
247 (values 'eq #'eq #'eq-hash))
248 ((or (eq test #'eql) (eq test 'eql))
249 (values 'eql #'eql #'eql-hash))
250 ((or (eq test #'equal) (eq test 'equal))
251 (values 'equal #'equal #'equal-hash))
252 ((or (eq test #'equalp) (eq test 'equalp))
253 (values 'equalp #'equalp #'equalp-hash))
254 (t
255 (dolist (info *hash-table-tests*
256 (error 'simple-program-error
257 :format-control (intl:gettext "Unknown :TEST for MAKE-HASH-TABLE: ~S")
258 :format-arguments (list test)))
259 (destructuring-bind
260 (test-name test-fun hash-fun)
261 info
262 (when (or (eq test test-name) (eq test test-fun))
263 (return (values test-name test-fun hash-fun)))))))
264 (let* ((size (max 36 size)) ; Needs to be at least 1, say 36.
265 (size+1 (1+ size)) ; The first element is not usable.
266 ;; Don't let rehash-threshold get too small to cause
267 ;; overflows or division by zero. It's a hint, not a
268 ;; requirement, anyway.
269 (rehash-threshold (float (max 0.1 rehash-threshold) 1.0))
270 (scaled-size (round (/ (float size+1) rehash-threshold)))
271 (length (if (<= scaled-size 37) 37 (almost-primify scaled-size))))
272 (declare (type index size+1 scaled-size length))
273 #-gencgc
274 (when weak-p
275 (format *debug-io* (intl:gettext ";; Creating unsupported weak-p hash table~%")))
276 #+gencgc
277 (when (and (member weak-p '(t :key :key-and-value :key-or-value))
278 (not (member test '(eq eql))))
279 ;; I (rtoy) think the current GENCGC code really expects the
280 ;; test to be EQ, but doesn't enforce it in any way. Let's
281 ;; warn about it for now.
282 ;;
283 ;; XXX: Either fix GC to work with other tests, or change
284 ;; this warning into an error.
285 (error (intl:gettext "Cannot make a weak ~A hashtable with test: ~S") weak-p test))
286 (let* ((index-vector
287 (make-array length :element-type '(unsigned-byte 32)
288 :initial-element 0))
289 ;; Needs to be the same length as the KV vector
290 (next-vector
291 (make-array size+1 :element-type '(unsigned-byte 32)))
292 (kv-vector (make-array (* 2 size+1) :initial-element 'empty-hash-entry))
293 (table
294 (%make-hash-table
295 :test test
296 :test-fun test-fun
297 :hash-fun hash-fun
298 :rehash-size rehash-size
299 :rehash-threshold rehash-threshold
300 :rehash-trigger size
301 :table kv-vector
302 :weak-p weak-p
303 :index-vector index-vector
304 :next-vector next-vector
305 :hash-vector (unless (eq test 'eq)
306 (make-array size+1
307 :element-type '(unsigned-byte 32)
308 :initial-element +eq-based-hash-value+)))))
309 ;; Setup the free list, all free. These lists are 0
310 ;; terminated.
311 (do ((i 1 (1+ i)))
312 ((>= i size))
313 (setf (aref next-vector i) (1+ i)))
314 (setf (aref next-vector size) 0)
315 (setf (hash-table-next-free-kv table) 1)
316 (setf (hash-table-needing-rehash table) 0)
317 (setf (aref kv-vector 0) table)
318 table)))))
319
320
321 (declaim (inline hash-table-count))
322 (defun hash-table-count (hash-table)
323 "Returns the number of entries in the given HASH-TABLE."
324 (declare (type hash-table hash-table)
325 (values index))
326 (hash-table-number-entries hash-table))
327
328 (setf (documentation 'hash-table-rehash-size 'function)
329 _N"Return the rehash-size HASH-TABLE was created with.")
330
331 (setf (documentation 'hash-table-rehash-threshold 'function)
332 _N"Return the rehash-threshold HASH-TABLE was created with.")
333
334 (declaim (inline hash-table-size))
335 (defun hash-table-size (hash-table)
336 "Return a size that can be used with MAKE-HASH-TABLE to create a hash
337 table that can hold however many entries HASH-TABLE can hold without
338 having to be grown."
339 (hash-table-rehash-trigger hash-table))
340
341 (setf (documentation 'hash-table-test 'function)
342 _N"Return the test HASH-TABLE was created with.")
343
344 (setf (documentation 'hash-table-weak-p 'function)
345 _N"Return T if HASH-TABLE will not keep entries for keys that would
346 otherwise be garbage, and NIL if it will.")
347
348
349 ;;;; Accessing functions.
350
351 ;;; REHASH -- internal.
352 ;;;
353 ;;; Make new vectors for the table, extending the table based on the
354 ;;; rehash-size.
355 ;;;
356 (defun rehash (table)
357 (declare (type hash-table table))
358 (let* ((old-kv-vector (hash-table-table table))
359 (old-next-vector (hash-table-next-vector table))
360 (old-hash-vector (hash-table-hash-vector table))
361 (old-size (length old-next-vector))
362 (new-size
363 (let ((rehash-size (hash-table-rehash-size table)))
364 (etypecase rehash-size
365 (fixnum
366 (+ rehash-size old-size))
367 (float
368 (the (values index t) (round (* rehash-size old-size)))))))
369 (new-kv-vector (make-array (* 2 new-size) :initial-element 'empty-hash-entry))
370 (new-next-vector (make-array new-size
371 :element-type '(unsigned-byte 32)
372 :initial-element 0))
373 (new-hash-vector (when old-hash-vector
374 (make-array new-size
375 :element-type '(unsigned-byte 32)
376 :initial-element +eq-based-hash-value+)))
377 (old-index-vector (hash-table-index-vector table))
378 (new-length (almost-primify
379 (round (/ (float new-size)
380 (hash-table-rehash-threshold table)))))
381 (new-index-vector (make-array new-length
382 :element-type '(unsigned-byte 32)
383 :initial-element 0)))
384 (declare (type index new-size new-length old-size))
385
386 ;; Disable GC tricks on the old-kv-vector.
387 (set-header-data old-kv-vector vm:vector-normal-subtype)
388
389 ;; Copy over the kv-vector, the element positions should not move
390 ;; in case there are active scans.
391 (dotimes (i (* old-size 2))
392 (declare (type index i))
393 (setf (aref new-kv-vector i) (aref old-kv-vector i)))
394
395 ;; Copy over the hash-vector.
396 (when old-hash-vector
397 (dotimes (i old-size)
398 (setf (aref new-hash-vector i) (aref old-hash-vector i))))
399
400 (setf (hash-table-next-free-kv table) 0)
401 (setf (hash-table-needing-rehash table) 0)
402 ;; Rehash all the entries; last to first so that after the pushes
403 ;; the chains are first to last.
404 (do ((i (1- new-size) (1- i))
405 (empty (aref new-kv-vector 1)))
406 ((zerop i))
407 (let ((key (aref new-kv-vector (* 2 i)))
408 (value (aref new-kv-vector (1+ (* 2 i)))))
409 ;; A slot is empty if both the key and the value are "empty",
410 ;; which is indicated by the value of kv_vector[1].
411 (cond ((and (eq key empty) (eq value empty))
412 ;; Push this slot onto the free list.
413 (setf (aref new-next-vector i)
414 (hash-table-next-free-kv table))
415 (setf (hash-table-next-free-kv table) i))
416 ((and new-hash-vector
417 (not (= (aref new-hash-vector i) +eq-based-hash-value+)))
418 ;; Can use the existing hash value (not EQ based)
419 (let* ((hashing (aref new-hash-vector i))
420 (index (rem hashing new-length))
421 (next (aref new-index-vector index)))
422 (declare (type index index)
423 (type hash hashing))
424 ;; Push this slot into the next chain.
425 (setf (aref new-next-vector i) next)
426 (setf (aref new-index-vector index) i)))
427 (t
428 ;; EQ base hash.
429 ;; Enable GC tricks.
430 (set-header-data new-kv-vector vm:vector-valid-hashing-subtype)
431 (let* ((hashing (pointer-hash key))
432 (index (rem hashing new-length))
433 (next (aref new-index-vector index)))
434 (declare (type index index)
435 (type hash hashing))
436 ;; Push this slot onto the next chain.
437 (setf (aref new-next-vector i) next)
438 (setf (aref new-index-vector index) i))))))
439 (setf (hash-table-table table) new-kv-vector)
440 (setf (hash-table-index-vector table) new-index-vector)
441 (setf (hash-table-next-vector table) new-next-vector)
442 (setf (hash-table-hash-vector table) new-hash-vector)
443 ;; Shrink the old vectors to 0 size to help the conservative GC.
444 (setf old-kv-vector (shrink-vector old-kv-vector 0))
445 (setf old-index-vector (shrink-vector old-index-vector 0))
446 (setf old-next-vector (shrink-vector old-next-vector 0))
447 (when old-hash-vector
448 (setf old-hash-vector (shrink-vector old-hash-vector 0)))
449 (setf (hash-table-rehash-trigger table) new-size))
450 (undefined-value))
451
452 ;;; REHASH-WITHOUT-GROWING -- internal.
453 ;;;
454 ;;; Use the same size as before, re-using the vectors.
455 ;;;
456 (defun rehash-without-growing (table)
457 (declare (type hash-table table))
458 (let* ((kv-vector (hash-table-table table))
459 (next-vector (hash-table-next-vector table))
460 (hash-vector (hash-table-hash-vector table))
461 (size (length next-vector))
462 (index-vector (hash-table-index-vector table))
463 (length (length index-vector)))
464 (declare (type index size length)
465 (type (simple-array (unsigned-byte 32) (*))))
466
467 ;; Disable GC tricks, they will be re-enabled during the re-hash
468 ;; if necesary.
469 (set-header-data kv-vector vm:vector-normal-subtype)
470
471 ;; Rehash all the entries.
472 (setf (hash-table-next-free-kv table) 0)
473 (setf (hash-table-needing-rehash table) 0)
474 (dotimes (i size)
475 (setf (aref next-vector i) 0))
476 (dotimes (i length)
477 (setf (aref index-vector i) 0))
478 (do ((i (1- size) (1- i))
479 (empty (aref kv-vector 1)))
480 ((zerop i))
481 (let ((key (aref kv-vector (* 2 i)))
482 (value (aref kv-vector (1+ (* 2 i)))))
483 ;; A slot is empty if both the key and the value are "empty",
484 ;; which is indicated by the value of kv_vector[1].
485 (cond ((and (eq key empty) (eq value empty))
486 ;; Push this slot onto the free list.
487 (setf (aref next-vector i) (hash-table-next-free-kv table))
488 (setf (hash-table-next-free-kv table) i))
489 ((and hash-vector (not (= (aref hash-vector i) +eq-based-hash-value+)))
490 ;; Can use the existing hash value (not EQ based)
491 (let* ((hashing (aref hash-vector i))
492 (index (rem hashing length))
493 (next (aref index-vector index)))
494 (declare (type index index))
495 ;; Push this slot into the next chain.
496 (setf (aref next-vector i) next)
497 (setf (aref index-vector index) i)))
498 (t
499 ;; EQ base hash.
500 ;; Enable GC tricks.
501 (set-header-data kv-vector vm:vector-valid-hashing-subtype)
502 (let* ((hashing (pointer-hash key))
503 (index (rem hashing length))
504 (next (aref index-vector index)))
505 (declare (type index index)
506 (type hash hashing))
507 ;; Push this slot into the next chain.
508 (setf (aref next-vector i) next)
509 (setf (aref index-vector index) i)))))))
510 (undefined-value))
511
512 (defun flush-needing-rehash (table)
513 (let* ((kv-vector (hash-table-table table))
514 (index-vector (hash-table-index-vector table))
515 (next-vector (hash-table-next-vector table))
516 (length (length index-vector)))
517 (do ((next (hash-table-needing-rehash table)))
518 ((zerop next))
519 (declare (type index next))
520 (let* ((key (aref kv-vector (* 2 next)))
521 (hashing (pointer-hash key))
522 (index (rem hashing length))
523 (temp (aref next-vector next)))
524 (setf (aref next-vector next) (aref index-vector index))
525 (setf (aref index-vector index) next)
526 (setf next temp))))
527 (setf (hash-table-needing-rehash table) 0)
528 (undefined-value))
529
530 ;;; GETHASH -- Public.
531 ;;;
532 (defun gethash (key hash-table &optional default)
533 "Finds the entry in HASH-TABLE whose key is KEY and returns the associated
534 value and T as multiple values, or returns DEFAULT and NIL if there is no
535 such entry. Entries can be added using SETF."
536 (declare (type hash-table hash-table)
537 (values t (member t nil)))
538 (without-gcing
539 (cond ((= (get-header-data (hash-table-table hash-table))
540 vm:vector-must-rehash-subtype)
541 (rehash-without-growing hash-table))
542 ((not (zerop (hash-table-needing-rehash hash-table)))
543 (flush-needing-rehash hash-table)))
544 ;; Search for key in the hash table.
545 (multiple-value-bind
546 (hashing eq-based)
547 (funcall (hash-table-hash-fun hash-table) key)
548 (declare (type hash hashing))
549 (let* ((index-vector (hash-table-index-vector hash-table))
550 (length (length index-vector))
551 (index (rem hashing length))
552 (next (aref index-vector index))
553 (table (hash-table-table hash-table))
554 (next-vector (hash-table-next-vector hash-table))
555 (hash-vector (hash-table-hash-vector hash-table))
556 (test-fun (hash-table-test-fun hash-table)))
557 (declare (type index index))
558 ;; Search next-vector chain for a matching key.
559 (if (or eq-based (not hash-vector))
560 (do ((next next (aref next-vector next)))
561 ((zerop next) (values default nil))
562 (declare (type index next))
563 (when (eq key (aref table (* 2 next)))
564 (return (values (aref table (1+ (* 2 next))) t))))
565 (do ((next next (aref next-vector next)))
566 ((zerop next) (values default nil))
567 (declare (type index next))
568 (when (and (= hashing (aref hash-vector next))
569 (funcall test-fun key (aref table (* 2 next))))
570 ;; Found.
571 (return (values (aref table (1+ (* 2 next))) t)))))))))
572
573 ;;; So people can call #'(setf gethash).
574 ;;;
575 (defun (setf gethash) (new-value key table &optional default)
576 (declare (ignore default))
577 (%puthash key table new-value))
578
579 ;;; %PUTHASH -- public setf method.
580 ;;;
581 (defun %puthash (key hash-table value)
582 (declare (type hash-table hash-table))
583 (assert (hash-table-index-vector hash-table))
584 (without-gcing
585 ;; Need to rehash here so that a current key can be found if it
586 ;; exists. Check that there is room for one more entry. May not be
587 ;; needed if the key is already present.
588 (cond ((zerop (hash-table-next-free-kv hash-table))
589 (rehash hash-table))
590 ((= (get-header-data (hash-table-table hash-table))
591 vm:vector-must-rehash-subtype)
592 (rehash-without-growing hash-table))
593 ((not (zerop (hash-table-needing-rehash hash-table)))
594 (flush-needing-rehash hash-table)))
595
596 ;; Search for key in the hash table.
597 (multiple-value-bind
598 (hashing eq-based)
599 (funcall (hash-table-hash-fun hash-table) key)
600 (declare (type hash hashing))
601 (let* ((index-vector (hash-table-index-vector hash-table))
602 (length (length index-vector))
603 (index (rem hashing length))
604 (next (aref index-vector index))
605 (kv-vector (hash-table-table hash-table))
606 (next-vector (hash-table-next-vector hash-table))
607 (hash-vector (hash-table-hash-vector hash-table))
608 (test-fun (hash-table-test-fun hash-table)))
609 (declare (type index index))
610
611 (cond ((or eq-based (not hash-vector))
612 (when eq-based
613 (set-header-data kv-vector vm:vector-valid-hashing-subtype))
614
615 ;; Search next-vector chain for a matching key.
616 (do ((next next (aref next-vector next)))
617 ((zerop next))
618 (declare (type index next))
619 (when (eq key (aref kv-vector (* 2 next)))
620 ;; Found, just replace the value.
621 (setf (aref kv-vector (1+ (* 2 next))) value)
622 (return-from %puthash value))))
623 (t
624 ;; Search next-vector chain for a matching key.
625 (do ((next next (aref next-vector next)))
626 ((zerop next))
627 (declare (type index next))
628 (when (and (= hashing (aref hash-vector next))
629 (funcall test-fun key
630 (aref kv-vector (* 2 next))))
631 ;; Found, just replace the value.
632 (setf (aref kv-vector (1+ (* 2 next))) value)
633 (return-from %puthash value)))))
634
635 ;; Pop a KV slot off the free list
636 (let ((free-kv-slot (hash-table-next-free-kv hash-table)))
637 ;; Double-check for overflow.
638 (assert (not (zerop free-kv-slot)))
639 (setf (hash-table-next-free-kv hash-table)
640 (aref next-vector free-kv-slot))
641 (incf (hash-table-number-entries hash-table))
642
643 (setf (aref kv-vector (* 2 free-kv-slot)) key)
644 (setf (aref kv-vector (1+ (* 2 free-kv-slot))) value)
645
646 ;; Setup the hash-vector if necessary.
647 (when hash-vector
648 (if (not eq-based)
649 (setf (aref hash-vector free-kv-slot) hashing)
650 (assert (= (aref hash-vector free-kv-slot) +eq-based-hash-value+))))
651
652 ;; Push this slot into the next chain.
653 (setf (aref next-vector free-kv-slot) next)
654 (setf (aref index-vector index) free-kv-slot)))))
655 value)
656
657 ;;; REMHASH -- public.
658 ;;;
659 (defun remhash (key hash-table)
660 "Remove the entry in HASH-TABLE associated with KEY. Returns T if there
661 was such an entry, and NIL if not."
662 (declare (type hash-table hash-table)
663 (values (member t nil)))
664 (without-gcing
665 ;; Need to rehash here so that a current key can be found if it
666 ;; exists.
667 (cond ((= (get-header-data (hash-table-table hash-table))
668 vm:vector-must-rehash-subtype)
669 (rehash-without-growing hash-table))
670 ((not (zerop (hash-table-needing-rehash hash-table)))
671 (flush-needing-rehash hash-table)))
672
673 ;; Search for key in the hash table.
674 (multiple-value-bind (hashing eq-based)
675 (funcall (hash-table-hash-fun hash-table) key)
676 (declare (type hash hashing))
677 (let* ((index-vector (hash-table-index-vector hash-table))
678 (length (length index-vector))
679 (index (rem hashing length))
680 (next (aref index-vector index))
681 (table (hash-table-table hash-table))
682 (next-vector (hash-table-next-vector hash-table))
683 (hash-vector (hash-table-hash-vector hash-table))
684 (test-fun (hash-table-test-fun hash-table))
685 (empty (aref table 1)))
686 (declare (type index index next))
687 (cond ((zerop next)
688 nil)
689 ((if (or eq-based (not hash-vector))
690 (eq key (aref table (* 2 next)))
691 (and (= hashing (aref hash-vector next))
692 (funcall test-fun key (aref table (* 2 next)))))
693 ;; Empty out Key and Value, by using the empty value in
694 ;; kv-vector[1].
695 (setf (aref table (* 2 next)) empty)
696 (setf (aref table (1+ (* 2 next))) empty)
697 ;; Update the index-vector pointer.
698 (setf (aref index-vector index) (aref next-vector next))
699 ;; Push KV slot onto free chain.
700 (setf (aref next-vector next)
701 (hash-table-next-free-kv hash-table))
702 (setf (hash-table-next-free-kv hash-table) next)
703 (when hash-vector
704 (setf (aref hash-vector next) +eq-based-hash-value+))
705 (decf (hash-table-number-entries hash-table))
706 t)
707 ;; Search next-vector chain for a matching key.
708 ((or eq-based (not hash-vector))
709 ;; EQ based.
710 (do ((prior next next)
711 (next (aref next-vector next) (aref next-vector next)))
712 ((zerop next) nil)
713 (declare (type index next))
714 (when (eq key (aref table (* 2 next)))
715 ;; Empty out Key and Value by using the empty value
716 ;; in kv_vector[1].
717 (setf (aref table (* 2 next)) empty)
718 (setf (aref table (1+ (* 2 next))) empty)
719 ;; Update the prior pointer in the chain to skip this.
720 (setf (aref next-vector prior) (aref next-vector next))
721 ;; Push KV slot onto free chain.
722 (setf (aref next-vector next)
723 (hash-table-next-free-kv hash-table))
724 (setf (hash-table-next-free-kv hash-table) next)
725 (when hash-vector
726 (setf (aref hash-vector next) +eq-based-hash-value+))
727 (decf (hash-table-number-entries hash-table))
728 (return t))))
729 (t
730 ;; Not EQ based
731 (do ((prior next next)
732 (next (aref next-vector next) (aref next-vector next)))
733 ((zerop next) nil)
734 (declare (type index next))
735 (when (and (= hashing (aref hash-vector next))
736 (funcall test-fun key (aref table (* 2 next))))
737 ;; Empty out Key and Value by using the empty value
738 ;; in kv_vector[1].
739 (setf (aref table (* 2 next)) empty)
740 (setf (aref table (1+ (* 2 next))) empty)
741 ;; Update the prior pointer in the chain to skip this.
742 (setf (aref next-vector prior) (aref next-vector next))
743 ;; Push KV slot onto free chain.
744 (setf (aref next-vector next)
745 (hash-table-next-free-kv hash-table))
746 (setf (hash-table-next-free-kv hash-table) next)
747 (when hash-vector
748 (setf (aref hash-vector next) +eq-based-hash-value+))
749 (decf (hash-table-number-entries hash-table))
750 (return t)))))))))
751
752 ;;; CLRHASH -- public.
753 ;;;
754 (defun clrhash (hash-table)
755 "This removes all the entries from HASH-TABLE and returns the hash table
756 itself."
757 (let* ((kv-vector (hash-table-table hash-table))
758 (kv-length (length kv-vector))
759 (next-vector (hash-table-next-vector hash-table))
760 (hash-vector (hash-table-hash-vector hash-table))
761 (size (length next-vector))
762 (index-vector (hash-table-index-vector hash-table))
763 (length (length index-vector)))
764 ;; Disable GC tricks.
765 (set-header-data kv-vector vm:vector-normal-subtype)
766 ;; Empty out the Keys and Values by using the empty value in
767 ;; kv_vector[1].
768 (do ((i 2 (1+ i))
769 (empty (aref kv-vector 1)))
770 ((>= i kv-length))
771 (setf (aref kv-vector i) empty))
772 (assert (eq (aref kv-vector 0) hash-table))
773 ;; Setup the free list, all free.
774 (do ((i 1 (1+ i)))
775 ((>= i (1- size)))
776 (setf (aref next-vector i) (1+ i)))
777 (setf (aref next-vector (1- size)) 0)
778 (setf (hash-table-next-free-kv hash-table) 1)
779 (setf (hash-table-needing-rehash hash-table) 0)
780 ;; Clear the index-vector
781 (dotimes (i length)
782 (setf (aref index-vector i) 0))
783 ;; Clear the hash-vector
784 (when hash-vector
785 (dotimes (i size)
786 (setf (aref hash-vector i) +eq-based-hash-value+))))
787 (setf (hash-table-number-entries hash-table) 0)
788 hash-table)
789
790 ;;; CLOBBER-HASH -- public.
791 ;;;
792 (defun clobber-hash (hash-table)
793 "This removes all the entries from HASH-TABLE and returns the hash table
794 itself, shrinking the size to free memory."
795 (let* ((old-kv-vector (hash-table-table hash-table))
796 (old-index-vector (hash-table-index-vector hash-table))
797 (old-next-vector (hash-table-next-vector hash-table))
798 (old-hash-vector (hash-table-hash-vector hash-table))
799 (new-size 37)
800 (new-kv-vector (make-array (* 2 new-size) :initial-element 'empty-hash-entry))
801 (new-next-vector (make-array new-size
802 :element-type '(unsigned-byte 32)
803 :initial-element 0))
804 (new-hash-vector
805 (when old-hash-vector
806 (make-array new-size :element-type '(unsigned-byte 32)
807 :initial-element +eq-based-hash-value+)))
808 (new-length 37)
809 (new-index-vector (make-array new-length
810 :element-type '(unsigned-byte 32)
811 :initial-element 0)))
812 (declare (type index new-size new-length))
813 ;; Disable GC tricks.
814 (set-header-data old-kv-vector vm:vector-normal-subtype)
815 ;; Setup the free list, all free.
816 (do ((i 1 (1+ i)))
817 ((>= i (1- new-size)))
818 (setf (aref new-next-vector i) (1+ i)))
819 (setf (aref new-next-vector (1- new-size)) 0)
820 (setf (hash-table-rehash-trigger hash-table) new-size)
821 (setf (hash-table-next-free-kv hash-table) 1)
822 (setf (hash-table-needing-rehash hash-table) 0)
823 (setf (hash-table-number-entries hash-table) 0)
824 (setf (hash-table-table hash-table) new-kv-vector)
825 (setf (hash-table-index-vector hash-table) new-index-vector)
826 (setf (hash-table-next-vector hash-table) new-next-vector)
827 (setf (hash-table-hash-vector hash-table) new-hash-vector)
828 ;; Shrink the old vectors to 0 size to help the conservative GC.
829 (setf old-kv-vector (shrink-vector old-kv-vector 0))
830 (setf old-index-vector (shrink-vector old-index-vector 0))
831 (setf old-next-vector (shrink-vector old-next-vector 0))
832 (when old-hash-vector
833 (setf old-hash-vector (shrink-vector old-hash-vector 0))))
834 hash-table)
835
836
837 ;;;; MAPHASH and WITH-HASH-TABLE-ITERATOR
838
839 (declaim (maybe-inline maphash))
840 (defun maphash (map-function hash-table)
841 "For each entry in HASH-TABLE, calls MAP-FUNCTION on the key and value
842 of the entry; returns NIL."
843 (declare (type (or function symbol) map-function)
844 (type hash-table hash-table))
845 (let ((fun (etypecase map-function
846 (function
847 map-function)
848 (symbol
849 (symbol-function map-function))))
850 (size (length (hash-table-next-vector hash-table))))
851 (declare (type function fun))
852 (do ((i 1 (1+ i))
853 (empty (aref (hash-table-table hash-table) 1)))
854 ((>= i size))
855 (declare (type index i))
856 ;; Need to grab the kv-vector on each iteration in case it was
857 ;; rehashed by a PUTHASH
858 (let* ((kv-vector (hash-table-table hash-table))
859 (key (aref kv-vector (* 2 i)))
860 (value (aref kv-vector (1+ (* 2 i)))))
861 (unless (and (eq key empty) (eq value empty))
862 (funcall fun key value))))))
863
864 (defmacro with-hash-table-iterator ((function hash-table) &body body)
865 "WITH-HASH-TABLE-ITERATOR ((function hash-table) &body body)
866 provides a method of manually looping over the elements of a hash-table.
867 FUNCTION is bound to a generator-macro that, within the scope of the
868 invocation, returns one or three values. The first value tells whether
869 any objects remain in the hash table. When the first value is non-NIL,
870 the second and third values are the key and the value of the next object."
871 (let ((n-function (gensym "WITH-HASH-TABLE-ITERRATOR-")))
872 `(let ((,n-function
873 (let* ((table ,hash-table)
874 (length (length (hash-table-next-vector table)))
875 (index 1))
876 (declare (type (integer 0 #.(1- (floor most-positive-fixnum 2))) index))
877 (labels
878 ((,function ()
879 ;; Grab the table again on each iteration just
880 ;; in case it was rehashed by a PUTHASH.
881 (let ((kv-vector (hash-table-table table)))
882 (do ((empty (aref kv-vector 1)))
883 ((>= index length) (values nil))
884 (let ((key (aref kv-vector (* 2 index)))
885 (value (aref kv-vector (1+ (* 2 index)))))
886 (incf index)
887 (unless (and (eq key empty) (eq value empty))
888 (return (values t key value))))))))
889 #',function))))
890 (macrolet ((,function () '(funcall ,n-function)))
891 ,@body))))
892
893
894
895 ;;;; SXHASH and support functions
896
897 ;;; The maximum length and depth to which we hash lists.
898 (defconstant sxhash-max-len 7)
899 (defconstant sxhash-max-depth 3)
900
901 (eval-when (compile eval)
902
903 (defconstant sxhash-bits-byte (byte 29 0))
904 (defconstant sxmash-total-bits 29)
905 (defconstant sxmash-rotate-bits 9)
906
907 (defmacro sxmash (place with)
908 `(setf ,place
909 (logxor (truly-the hash
910 (ash ,place
911 ,(- sxmash-rotate-bits sxmash-total-bits)))
912 (truly-the hash
913 (ash (logand
914 ,place
915 ,(1- (ash 1
916 (- sxmash-total-bits
917 sxmash-rotate-bits))))
918 ,sxmash-rotate-bits))
919 (truly-the hash ,with))))
920
921 (defmacro sxhash-simple-string (sequence)
922 `(%sxhash-simple-string ,sequence))
923
924 (defmacro sxhash-string (sequence)
925 (let ((data (gensym))
926 (start (gensym))
927 (end (gensym))
928 (fill-end (gensym)))
929 (once-only ((n-sequence sequence))
930 `(let ((,fill-end (if (array-has-fill-pointer-p ,n-sequence)
931 (fill-pointer ,n-sequence)
932 nil)))
933 (with-array-data ((,data (the (values string &rest t) ,n-sequence))
934 (,start)
935 (,end ,fill-end))
936 (if (zerop ,start)
937 (%sxhash-simple-substring ,data ,end)
938 (sxhash-simple-string (coerce (the (values string &rest t)
939 ,n-sequence)
940 'simple-string))))))))
941
942
943 (defmacro sxhash-list (sequence depth &key (equalp nil))
944 `(if (= ,depth sxhash-max-depth)
945 0
946 (do ((sequence ,sequence (cdr (the list sequence)))
947 (index 0 (1+ index))
948 (hash 2)
949 (,depth (1+ ,depth)))
950 ((or (atom sequence) (= index sxhash-max-len)) hash)
951 (declare (fixnum hash index))
952 (sxmash hash (,(if equalp 'internal-equalp-hash 'internal-sxhash)
953 (car sequence) ,depth)))))
954
955 (defmacro sxhash-bit-vector (vector)
956 `(let* ((length (length ,vector))
957 (hash length))
958 (declare (type index length) (type hash hash))
959 (dotimes (index (min length sxhash-max-len) hash)
960 (declare (type index index))
961 (sxmash hash (bit ,vector index)))))
962
963 ); eval-when (compile eval)
964
965 ;; Taken from pcl/low.lisp, and manually macroexpanded. This needs to
966 ;; be here so we can cross-compile. (Due to tracing using an equal
967 ;; table now.)
968
969 (defun sxhash-instance (instance)
970 (cond ((%instancep instance)
971 (%instance-ref instance 2))
972 ((funcallable-instance-p instance)
973 (%funcallable-instance-info instance 2))
974 (t
975 (error (intl:gettext "What kind of instance is this?")))))
976
977 ;; End pcl/low.lisp
978
979 (defun internal-sxhash (s-expr depth)
980 (declare (type index depth) (values hash))
981 (typecase s-expr
982 ;; The pointers and immediate types.
983 (cons (sxhash-list s-expr depth))
984 (fixnum (ldb sxhash-bits-byte s-expr))
985 (character (char-code s-expr))
986 (pathname
987 ;; Pathnames are EQUAL if all the components are EQUAL, so we
988 ;; hash all of the components of a pathname together.
989 (let ((hash (internal-sxhash (%pathname-host s-expr) depth)))
990 (sxmash hash (internal-sxhash (%pathname-device s-expr) depth))
991 (sxmash hash (internal-sxhash (%pathname-directory s-expr) depth))
992 (sxmash hash (internal-sxhash (%pathname-name s-expr) depth))
993 (sxmash hash (internal-sxhash (%pathname-type s-expr) depth))
994 ;; Hash :newest the same as NIL because EQUAL for pathnames
995 ;; assumes that :newest and nil are equal.
996 (let ((version (%pathname-version s-expr)))
997 (sxmash hash (internal-sxhash (if (eql version :newest) nil version) depth)))))
998 (instance
999 (if (or (typep s-expr 'structure-object)
1000 (typep s-expr 'condition))
1001 (internal-sxhash (%class-name (layout-class (%instance-layout s-expr)))
1002 depth)
1003 (sxhash-instance s-expr)))
1004 (funcallable-instance
1005 (if (eval:interpreted-function-p s-expr)
1006 (internal-sxhash (eval:interpreted-function-lambda-expression s-expr)
1007 depth)
1008 (sxhash-instance s-expr)))
1009 ;; Other-pointer types.
1010 (simple-string (sxhash-simple-string s-expr))
1011 (symbol #-(or sparc x86 ppc) (sxhash-simple-string (symbol-name s-expr))
1012 #+(or sparc x86 ppc) (sxhash s-expr))
1013 (number
1014 (etypecase s-expr
1015 (integer (ldb sxhash-bits-byte s-expr))
1016 (single-float
1017 ;; CLHS says sxhash must return the same thing for +0.0 and
1018 ;; -0.0. We get the desired result by adding +0.0, which
1019 ;; converts -0.0 to 0.0. But if s-expr is NaN, we don't want
1020 ;; to signal an error from adding 0, so don't do it since it
1021 ;; we don't need to anyway.
1022 (let* ((x (if (float-nan-p s-expr)
1023 s-expr
1024 (+ s-expr 0f0)))
1025 (bits (single-float-bits x)))
1026 (ldb sxhash-bits-byte
1027 (logxor (ash bits (- sxmash-rotate-bits)) bits))))
1028 (double-float
1029 (let* ((x (if (float-nan-p s-expr)
1030 s-expr
1031 (+ s-expr 0d0)))
1032 (lo (double-float-low-bits x))
1033 (hi (double-float-high-bits x)))
1034 (ldb sxhash-bits-byte
1035 (logxor (ash lo (- sxmash-rotate-bits)) lo
1036 (ldb sxhash-bits-byte
1037 (logxor (ash hi (- sxmash-rotate-bits)) hi))))))
1038 #+long-float
1039 (long-float
1040 (let ((lo (long-float-low-bits s-expr))
1041 #+sparc (mid (long-float-mid-bits s-expr))
1042 (hi (long-float-high-bits s-expr))
1043 (exp (long-float-exp-bits s-expr)))
1044 (ldb sxhash-bits-byte
1045 (logxor (ash lo (- sxmash-rotate-bits)) lo
1046 #+sparc (ash mid (- sxmash-rotate-bits)) #+sparc mid
1047 (ash hi (- sxmash-rotate-bits)) hi
1048 (ldb sxhash-bits-byte
1049 (logxor (ash exp (- sxmash-rotate-bits)) exp))))))
1050 #+double-double
1051 (double-double-float
1052 ;; Is this good enough?
1053 (logxor (internal-sxhash (kernel:double-double-hi s-expr) depth)
1054 (internal-sxhash (kernel:double-double-lo s-expr) depth)))
1055 (ratio (logxor (internal-sxhash (numerator s-expr) 0)
1056 (internal-sxhash (denominator s-expr) 0)))
1057 (complex (logxor (internal-sxhash (realpart s-expr) 0)
1058 (internal-sxhash (imagpart s-expr) 0)))))
1059 (array
1060 (typecase s-expr
1061 (string (sxhash-string s-expr))
1062 (simple-bit-vector (sxhash-bit-vector
1063 (truly-the simple-bit-vector s-expr)))
1064 (bit-vector (sxhash-bit-vector (truly-the bit-vector s-expr)))
1065 (t (array-rank s-expr))))
1066 ;; Everything else.
1067 (t 42)))
1068
1069 (defun sxhash (s-expr)
1070 "Computes a hash code for S-EXPR and returns it as an integer."
1071 (internal-sxhash s-expr 0))
1072
1073
1074 ;;;; Equalp hash.
1075
1076 (eval-when (compile eval)
1077
1078 (defmacro hash-table-equalp-hash (table)
1079 `(let ((hash (hash-table-count ,table)))
1080 (declare (type hash hash))
1081 (sxmash hash (sxhash (hash-table-test ,table)))
1082 hash))
1083
1084 (defmacro structure-equalp-hash (structure depth)
1085 `(if (= ,depth sxhash-max-depth)
1086 0
1087 (let* ((layout (%instance-layout ,structure))
1088 (length (min (1- (layout-length layout)) sxhash-max-len))
1089 (hash (internal-sxhash (%class-name (layout-class layout))
1090 depth))
1091 (,depth (+ ,depth 1)))
1092 (declare (type index length) (type hash hash))
1093 (do ((index 1 (1+ index)))
1094 ((= index length) hash)
1095 (declare (type index index))
1096 (sxmash hash (internal-equalp-hash
1097 (%instance-ref ,structure index) ,depth))))))
1098
1099 (defmacro vector-equalp-hash (vector depth)
1100 `(if (= ,depth sxhash-max-depth)
1101 0
1102 (let* ((length (length ,vector))
1103 (hash length)
1104 (,depth (+ ,depth 1)))
1105 (declare (type index length) (type hash hash))
1106 (dotimes (index (min length sxhash-max-len) hash)
1107 (declare (type index index))
1108 (sxmash hash (internal-equalp-hash (aref ,vector index) ,depth))))))
1109
1110 (defmacro array-equalp-hash (array depth)
1111 `(if (= ,depth sxhash-max-depth)
1112 0
1113 (let* ((size (array-total-size ,array))
1114 (hash size)
1115 (,depth (+ ,depth 1)))
1116 (declare (type hash hash))
1117 (dotimes (index (min sxhash-max-len size) hash)
1118 (sxmash hash (internal-equalp-hash
1119 (row-major-aref ,array index) ,depth))))))
1120
1121 ); eval-when (compile eval)
1122
1123
1124 (defun internal-equalp-hash (s-expr depth)
1125 (declare (type index depth) (values hash))
1126 (typecase s-expr
1127 ;; The pointers and immediate types.
1128 (cons (sxhash-list s-expr depth :equalp t))
1129 (fixnum (ldb sxhash-bits-byte s-expr))
1130 (character (char-code (char-upcase s-expr)))
1131 (instance
1132 (typecase s-expr
1133 (hash-table (hash-table-equalp-hash s-expr))
1134 (structure-object (structure-equalp-hash s-expr depth))
1135 (t 42)))
1136 ;; Other-pointer types.
1137 (simple-string (vector-equalp-hash (truly-the simple-string s-expr) depth))
1138 (symbol (sxhash-simple-string (symbol-name s-expr)))
1139 (number
1140 (etypecase s-expr
1141 (integer (sxhash s-expr))
1142 (float
1143 (macrolet ((frob (val type)
1144 (let ((lo (coerce most-negative-fixnum type))
1145 (hi (coerce most-positive-fixnum type)))
1146 `(if (<= ,lo ,val ,hi)
1147 (multiple-value-bind (q r)
1148 (truncate ,val)
1149 (if (zerop r)
1150 (sxhash q)
1151 (sxhash (coerce ,val 'long-float))))
1152 (multiple-value-bind (q r)
1153 (truncate ,val)
1154 (if (zerop r)
1155 (sxhash q)
1156 (sxhash (coerce ,val 'long-float))))))))
1157 (etypecase s-expr
1158 (single-float (frob s-expr single-float))
1159 (double-float (frob s-expr double-float))
1160 #+long-float (long-float (frob s-expr long-float)))))
1161 (ratio
1162 (let ((float (coerce s-expr 'long-float)))
1163 (if (= float s-expr)
1164 (sxhash float)
1165 (sxhash s-expr))))
1166 (complex (if (zerop (imagpart s-expr))
1167 (internal-equalp-hash (realpart s-expr) 0)
1168 (logxor (internal-equalp-hash (realpart s-expr) 0)
1169 (internal-equalp-hash (realpart s-expr) 0))))))
1170 (array
1171 (typecase s-expr
1172 (simple-vector (vector-equalp-hash (truly-the simple-vector s-expr) depth))
1173 (vector (vector-equalp-hash s-expr depth))
1174 (t (array-equalp-hash s-expr depth))))
1175 ;; Everything else.
1176 (t 42)))
1177
1178
1179 ;;;; Dumping one as a constant.
1180
1181 (defun make-hash-table-load-form (table)
1182 (values
1183 `(make-hash-table
1184 :test ',(hash-table-test table) :size ',(hash-table-size table)
1185 :rehash-size ',(hash-table-rehash-size table)
1186 :rehash-threshold ',(hash-table-rehash-threshold table)
1187 :weak-p ,(hash-table-weak-p table))
1188 (let ((values nil))
1189 (declare (inline maphash))
1190 (maphash #'(lambda (key value)
1191 (push (cons key value) values))
1192 table)
1193 (if values
1194 `(stuff-hash-table ,table ',values)
1195 nil))))
1196
1197 (defun stuff-hash-table (table alist)
1198 (dolist (x alist)
1199 (setf (gethash (car x) table) (cdr x))))

  ViewVC Help
Powered by ViewVC 1.1.5