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

Contents of /src/code/hash.lisp

Parent Directory Parent Directory | Revision Log Revision Log


Revision 1.37 - (show annotations)
Thu Jul 6 04:34:03 2000 UTC (13 years, 9 months ago) by dtc
Branch: MAIN
Changes since 1.36: +2 -2 lines
Clarify an assertion on the result of round, firstly receiving the
only the first value.
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.lisp,v 1.37 2000/07/06 04:34:03 dtc Exp $")
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 ;;; Equalp hashing by William Newman, Cadabra Inc, and Douglas Crosher, 2000.
16 ;;;
17 (in-package :common-lisp)
18
19 (export '(hash-table hash-table-p make-hash-table
20 gethash remhash maphash clrhash
21 hash-table-count with-hash-table-iterator
22 hash-table-rehash-size hash-table-rehash-threshold
23 hash-table-size hash-table-test sxhash))
24
25 (in-package :ext)
26 (export '(define-hash-table-test))
27
28 (in-package :common-lisp)
29
30
31 ;;;; The hash-table structures.
32
33 ;;; HASH-TABLE -- defstruct.
34 ;;;
35 (defstruct (hash-table
36 (:constructor %make-hash-table)
37 (:print-function %print-hash-table)
38 (:make-load-form-fun make-hash-table-load-form))
39 "Structure used to implement hash tables."
40 ;;
41 ;; The type of hash table this is. Only used for printing and as part of
42 ;; the exported interface.
43 (test (required-argument) :type symbol :read-only t)
44 ;;
45 ;; The function used to compare two keys. Returns T if they are the same
46 ;; and NIL if not.
47 (test-fun (required-argument) :type function :read-only t)
48 ;;
49 ;; The function used to compute the hashing of a key. Returns two values:
50 ;; the index hashing and T if that might change with the next GC.
51 (hash-fun (required-argument) :type function :read-only t)
52 ;;
53 ;; How much to grow the hash table by when it fills up. If an index, then
54 ;; add that amount. If a floating point number, then multiple it by that.
55 (rehash-size (required-argument) :type (or index (single-float (1.0)))
56 :read-only t)
57 ;;
58 ;; How full the hash table has to get before we rehash.
59 (rehash-threshold (required-argument) :type (single-float (0.0) 1.0)
60 :read-only t)
61 ;;
62 ;; (* rehash-threshold (length table)), saved here so we don't have to keep
63 ;; recomputing it.
64 (rehash-trigger (required-argument) :type index)
65 ;;
66 ;; The current number of entries in the table.
67 (number-entries 0 :type index)
68 ;;
69 ;; Vector of ht-buckets.
70 (table (required-argument) :type simple-vector)
71 ;;
72 ;; True if this is a weak hash table, meaning that key->value mappings will
73 ;; disappear if there are no other references to the key. Note: this only
74 ;; matters if the hash function indicates that the hashing is EQ based.
75 (weak-p nil :type (member t nil))
76 ;;
77 #+gengc
78 ;; Chain of buckets that need to be rehashed because their hashing is EQ
79 ;; based and the key has been moved by the garbage collector.
80 (needing-rehash nil :type (or null hash-table-bucket)))
81 ;;;
82 (defun %print-hash-table (ht stream depth)
83 (declare (ignore depth) (stream stream))
84 (print-unreadable-object (ht stream :identity t)
85 (format stream "~A hash table, ~D entr~@:P"
86 (symbol-name (hash-table-test ht))
87 (hash-table-number-entries ht))))
88
89 (defconstant max-hash most-positive-fixnum)
90
91 (deftype hash ()
92 `(integer 0 ,max-hash))
93
94
95 (defstruct (hash-table-bucket
96 (:print-function %print-hash-table-bucket))
97 ;;
98 ;; The hashing associated with key, kept around so we don't have to recompute
99 ;; it each time. In the non-gengc system, if this is NIL it means that the
100 ;; hashing is EQ based, so use the address of the value. If the gengc
101 ;; system, we use the presence of the scavhook to tell that.
102 #-gengc (hash nil :type (or hash null))
103 #+gengc (hash 0 :type hash)
104 ;;
105 ;; The key and value, originally supplied by the user. If the hash table
106 ;; is weak, and this is eq based, then the key is really a weak pointer to
107 ;; the key.
108 (key nil :type t)
109 (value nil :type t)
110 ;;
111 ;; The next bucket, or NIL if there are no more.
112 (next nil :type (or hash-table-bucket null)))
113 ;;;
114 (defun %print-hash-table-bucket (bucket stream depth)
115 (declare (ignore depth))
116 (print-unreadable-object (bucket stream :type t)
117 (format stream "for ~S->~S~@[ ~D~]"
118 (hash-table-bucket-key bucket)
119 (hash-table-bucket-value bucket)
120 (hash-table-bucket-hash bucket))))
121
122 #+gengc
123 (defstruct (hash-table-eq-bucket
124 (:include hash-table-bucket))
125 ;;
126 ;; The scavenger-hook object used to detect when the EQ hashing of key will
127 ;; change. Only NIL during creation.
128 (scavhook nil :type (or null scavenger-hook))
129 ;;
130 ;; True iff this bucket is still linked into the corresponding hash table's
131 ;; vector.
132 (linked nil :type (member t nil)))
133
134 #|
135
136 ;;; SCAN-STATE -- defstruct.
137 ;;;
138 ;;; Holds the state of a MAPHASH or WITH-HASH-TABLE-ITERATOR.
139 ;;;
140 (defstruct (scan-state)
141 ;;
142 ;; The index into the hash-table-table.
143 (index 0 :type index)
144 ;;
145 ;; The current bucket in that chain.
146 (bucket nil :type (or null hash-table-bucket))
147 ;;
148 )
149
150 ;;; Non-gengc:
151 ;;;
152 ;;; %puthash: if there are any active scans, then make sure the current bucket
153 ;;; for each scan holds the key we are trying to puthash, and flame out of it
154 ;;; isn't. Given that we have our hands directly on the correct bucket, just
155 ;;; go for it.
156 ;;;
157 ;;; remhash: make the same check as with %puthash. If it checks out, then
158 ;;; just scan down the correct bucket chain and yank it.
159 ;;;
160 ;;; rehash: because of the above two tests, rehash will only be called by
161 ;;; gethash. And we need to do the rehash in order to look anything up. So
162 ;;; make a list of all the remaining buckets, and stick them in the scan-state.
163 ;;;
164 ;;; Gengc:
165 ;;;
166 ;;; %puthash & remhash: same as above.
167 ;;;
168 ;;; rehash: is only ever called by puthash, so doesn't need anything special to
169 ;;; account for active scans.
170 ;;;
171 ;;; flush-needing-rehash: will only be called by gethash for the same reason
172 ;;; rehash is only called by gethash in the non-gengc system. And basically
173 ;;; needs to do the same thing rehash does in the non-gengc system.
174 ;;;
175 ;;; hash-table-scavenger-hook: needs to check to see if the bucket being
176 ;;; unlinked is after the current bucket in any of the active scans. If so,
177 ;;; it needs to add it to a list of buckets that will be processed after all
178 ;;; the buckets visable in the hash-table-table have been delt with.
179
180 |#
181
182
183 ;;;; Utility functions.
184
185 (declaim (inline pointer-hash))
186 (defun pointer-hash (key)
187 (declare (values hash))
188 (truly-the hash (%primitive make-fixnum key)))
189
190 (declaim (inline eq-hash))
191 (defun eq-hash (key)
192 (declare (values hash (member t nil)))
193 (values (pointer-hash key)
194 (oddp (get-lisp-obj-address key))))
195
196 (declaim (inline eql-hash))
197 (defun eql-hash (key)
198 (declare (values hash (member t nil)))
199 (if (numberp key)
200 (equal-hash key)
201 (eq-hash key)))
202
203 (declaim (inline equal-hash))
204 (defun equal-hash (key)
205 (declare (values hash (member t nil)))
206 (values (sxhash key) nil))
207
208 (defun equalp-hash (key)
209 (declare (values hash (member t nil)))
210 (values (internal-equalp-hash key 0) nil))
211
212
213 (defun almost-primify (num)
214 (declare (type index num))
215 "Almost-Primify returns an almost prime number greater than or equal
216 to NUM."
217 (if (= (rem num 2) 0)
218 (setq num (+ 1 num)))
219 (if (= (rem num 3) 0)
220 (setq num (+ 2 num)))
221 (if (= (rem num 7) 0)
222 (setq num (+ 4 num)))
223 num)
224
225
226
227 ;;;; User defined hash table tests.
228
229 ;;; *HASH-TABLE-TESTS* -- Internal.
230 ;;;
231 (defvar *hash-table-tests* nil)
232
233 ;;; DEFINE-HASH-TABLE-TEST -- Public.
234 ;;;
235 (defun define-hash-table-test (name test-fun hash-fun)
236 "Define a new kind of hash table test."
237 (declare (type symbol name)
238 (type function test-fun hash-fun))
239 (setf *hash-table-tests*
240 (cons (list name test-fun hash-fun)
241 (remove name *hash-table-tests* :test #'eq :key #'car)))
242 name)
243
244
245 ;;;; Construction and simple accessors.
246
247 ;;; MAKE-HASH-TABLE -- public.
248 ;;;
249 (defun make-hash-table (&key (test 'eql) (size 65) (rehash-size 1.5)
250 (rehash-threshold 1) (weak-p nil))
251 "Creates and returns a new hash table. The keywords are as follows:
252 :TEST -- Indicates what kind of test to use. Only EQ, EQL, EQUAL,
253 and EQUALP are currently supported.
254 :SIZE -- A hint as to how many elements will be put in this hash
255 table.
256 :REHASH-SIZE -- Indicates how to expand the table when it fills up.
257 If an integer, add space for that many elements. If a floating
258 point number (which must be greater than 1.0), multiple the size
259 by that amount.
260 :REHASH-THRESHOLD -- Indicates how dense the table can become before
261 forcing a rehash. Can be any positive number <= to 1, with density
262 approaching zero as the threshold approaches 0. Density 1 means an
263 average of one entry per bucket.
264 CMUCL Extension:
265 :WEAK-P -- If T, don't keep entries if the key would otherwise be
266 garbage."
267 (declare (type (or function symbol) test)
268 (type index size) (type (member t nil) weak-p))
269 (let ((rehash-size (if (integerp rehash-size)
270 rehash-size
271 (float rehash-size 1.0)))
272 (rehash-threshold (float rehash-threshold 1.0)))
273 (multiple-value-bind
274 (test test-fun hash-fun)
275 (cond ((or (eq test #'eq) (eq test 'eq))
276 (values 'eq #'eq #'eq-hash))
277 ((or (eq test #'eql) (eq test 'eql))
278 (values 'eql #'eql #'eql-hash))
279 ((or (eq test #'equal) (eq test 'equal))
280 (values 'equal #'equal #'equal-hash))
281 ((or (eq test #'equalp) (eq test 'equalp))
282 (values 'equalp #'equalp #'equalp-hash))
283 (t
284 (dolist (info *hash-table-tests*
285 (error "Unknown :TEST for MAKE-HASH-TABLE: ~S"
286 test))
287 (destructuring-bind
288 (test-name test-fun hash-fun)
289 info
290 (when (or (eq test test-name) (eq test test-fun))
291 (return (values test-name test-fun hash-fun)))))))
292 (let* ((scaled-size (round (/ (float size) rehash-threshold)))
293 (length (if (<= scaled-size 37) 37 (almost-primify scaled-size)))
294 (vector (make-array length :initial-element nil)))
295 (declare (type index scaled-size length)
296 (type simple-vector vector))
297 (%make-hash-table
298 :test test
299 :test-fun test-fun
300 :hash-fun hash-fun
301 :rehash-size rehash-size
302 :rehash-threshold rehash-threshold
303 :rehash-trigger (round (* (float length) rehash-threshold))
304 :table vector
305 :weak-p weak-p)))))
306
307 (declaim (inline hash-table-count))
308 (defun hash-table-count (hash-table)
309 "Returns the number of entries in the given HASH-TABLE."
310 (declare (type hash-table hash-table)
311 (values index))
312 (hash-table-number-entries hash-table))
313
314 (setf (documentation 'hash-table-rehash-size 'function)
315 "Return the rehash-size HASH-TABLE was created with.")
316
317 (setf (documentation 'hash-table-rehash-threshold 'function)
318 "Return the rehash-threshold HASH-TABLE was created with.")
319
320 (declaim (inline hash-table-size))
321 (defun hash-table-size (hash-table)
322 "Return a size that can be used with MAKE-HASH-TABLE to create a hash
323 table that can hold however many entries HASH-TABLE can hold without
324 having to be grown."
325 (hash-table-rehash-trigger hash-table))
326
327 (setf (documentation 'hash-table-test 'function)
328 "Return the test HASH-TABLE was created with.")
329
330 (setf (documentation 'hash-table-weak-p 'function)
331 "Return T if HASH-TABLE will not keep entries for keys that would
332 otherwise be garbage, and NIL if it will.")
333
334
335 ;;;; Accessing functions.
336
337 ;;; REHASH -- internal.
338 ;;;
339 ;;; Make a new vector for TABLE. If GROW is NIL, use the same size as before,
340 ;;; otherwise extend the table based on the rehash-size.
341 ;;;
342 (defun rehash (table grow)
343 (declare (type hash-table table))
344 (let* ((old-vector (hash-table-table table))
345 (old-length (length old-vector))
346 (new-length
347 (if grow
348 (let ((rehash-size (hash-table-rehash-size table)))
349 (etypecase rehash-size
350 (fixnum
351 (+ rehash-size old-length))
352 (float
353 (the index (values (round (* rehash-size old-length)))))))
354 old-length))
355 (new-vector (make-array new-length :initial-element nil))
356 #-gengc (weak-p (hash-table-weak-p table)))
357 (declare (type index new-length))
358 (dotimes (i old-length)
359 (declare (type index i))
360 (do ((bucket (svref old-vector i) next)
361 (next nil))
362 ((null bucket))
363 (setf next (hash-table-bucket-next bucket))
364 (block deal-with-one-bucket
365 (let* ((hashing
366 #-gengc
367 (or (hash-table-bucket-hash bucket)
368 (let ((key (hash-table-bucket-key bucket)))
369 (set-header-data new-vector
370 vm:vector-valid-hashing-subtype)
371 (if weak-p
372 (multiple-value-bind
373 (real-key valid)
374 (weak-pointer-value key)
375 (cond (valid
376 (pointer-hash real-key))
377 (t
378 (decf (hash-table-number-entries table))
379 (return-from deal-with-one-bucket nil))))
380 (pointer-hash key))))
381 #+gengc (hash-table-bucket-hash bucket))
382 (index (rem hashing new-length)))
383 (declare (type index hashing index))
384 (setf (hash-table-bucket-next bucket) (svref new-vector index))
385 (setf (svref new-vector index) bucket))))
386 ;; We clobber the old vector contents so that if it is living in
387 ;; static space it won't keep ahold of pointers into dynamic space.
388 (setf (svref old-vector i) nil))
389 (setf (hash-table-table table) new-vector)
390 (unless (= new-length old-length)
391 (setf (hash-table-rehash-trigger table)
392 (round (* (hash-table-rehash-threshold table)
393 (float new-length))))))
394 (undefined-value))
395
396 #+gengc
397 (defun flush-needing-rehash (table)
398 (let* ((weak-p (hash-table-weak-p table))
399 (vector (hash-table-table table))
400 (length (length vector)))
401 (do ((bucket (hash-table-needing-rehash table) next)
402 (next nil))
403 ((null bucket))
404 (setf next (hash-table-bucket-next bucket))
405 (flet ((relink-bucket (key)
406 (let* ((hashing (pointer-hash key))
407 (index (rem hashing length)))
408 (setf (hash-table-bucket-hash bucket) hashing)
409 (setf (hash-table-bucket-next bucket) (svref vector index))
410 (setf (svref vector index) bucket)
411 (setf (hash-table-eq-bucket-linked bucket) t))))
412 (let ((key (hash-table-bucket-key bucket)))
413 (if weak-p
414 (multiple-value-bind
415 (real-key valid)
416 (weak-pointer-value key)
417 (if valid
418 (relink-bucket real-key)
419 (decf (hash-table-number-entries table))))
420 (relink-bucket key))))))
421 (setf (hash-table-needing-rehash table) nil)
422 (undefined-value))
423
424 ;;; GETHASH -- Public.
425 ;;;
426 (defun gethash (key hash-table &optional default)
427 "Finds the entry in HASH-TABLE whose key is KEY and returns the associated
428 value and T as multiple values, or returns DEFAULT and NIL if there is no
429 such entry. Entries can be added using SETF."
430 (declare (type hash-table hash-table)
431 (values t (member t nil)))
432 (without-gcing
433 #-gengc
434 (when (= (get-header-data (hash-table-table hash-table))
435 vm:vector-must-rehash-subtype)
436 (rehash hash-table nil))
437 #+gengc
438 (when (hash-table-needing-rehash hash-table)
439 (flush-needing-rehash hash-table))
440 (multiple-value-bind
441 (hashing eq-based)
442 (funcall (hash-table-hash-fun hash-table) key)
443 (let* ((vector (hash-table-table hash-table))
444 (length (length vector))
445 (index (rem hashing length)))
446 (declare (type index hashing))
447 (if eq-based
448 (if (hash-table-weak-p hash-table)
449 (do ((bucket (svref vector index)
450 (hash-table-bucket-next bucket)))
451 ((null bucket) (values default nil))
452 (when #+gengc (hash-table-eq-bucket-p bucket)
453 #-gengc (null (hash-table-bucket-hash bucket))
454 (multiple-value-bind
455 (bucket-key valid)
456 (weak-pointer-value (hash-table-bucket-key bucket))
457 (assert valid)
458 (when (eq key bucket-key)
459 (return (values (hash-table-bucket-value bucket)
460 t))))))
461 (do ((bucket (svref vector index)
462 (hash-table-bucket-next bucket)))
463 ((null bucket) (values default nil))
464 (when (eq key (hash-table-bucket-key bucket))
465 (return (values (hash-table-bucket-value bucket) t)))))
466 (do ((test-fun (hash-table-test-fun hash-table))
467 (bucket (svref vector index) (hash-table-bucket-next bucket)))
468 ((null bucket) (values default nil))
469 (let ((bucket-hashing (hash-table-bucket-hash bucket)))
470 (when (and #-gengc bucket-hashing
471 (= bucket-hashing hashing)
472 #+gengc (not (hash-table-eq-bucket-p bucket))
473 (funcall test-fun key
474 (hash-table-bucket-key bucket)))
475 (return (values (hash-table-bucket-value bucket) t))))))))))
476
477
478 #+gengc
479 (defun get-hash-table-scavenger-hook (hash-table bucket)
480 (declare (type hash-table hash-table)
481 (type hash-table-eq-bucket bucket))
482 (flet ((hash-table-scavenger-hook ()
483 (when (hash-table-eq-bucket-linked bucket)
484 (let* ((vector (hash-table-table hash-table))
485 (length (length vector))
486 (index (rem (hash-table-eq-bucket-hash bucket) length)))
487 (declare (type index index))
488 (do ((prev nil next)
489 (next (svref vector index) (hash-table-bucket-next next)))
490 ((null next)
491 (warn "Couldn't find where ~S was linked inside ~S"
492 bucket hash-table))
493 (when (eq next bucket)
494 (if prev
495 (setf (hash-table-bucket-next prev)
496 (hash-table-bucket-next bucket))
497 (setf (svref vector index)
498 (hash-table-bucket-next bucket)))
499 (setf (hash-table-eq-bucket-linked bucket) nil)
500 (return)))
501 (if (and (hash-table-weak-p hash-table)
502 (not (nth-value 1
503 (weak-pointer-value
504 (hash-table-bucket-key bucket)))))
505 (decf (hash-table-number-entries hash-table))
506 (setf (hash-table-bucket-next bucket)
507 (hash-table-needing-rehash hash-table)
508 (hash-table-needing-rehash hash-table)
509 bucket))))))
510 #'hash-table-scavenger-hook))
511
512 ;;; So people can call #'(setf gethash).
513 ;;;
514 (defun (setf gethash) (new-value key table &optional default)
515 (declare (ignore default))
516 (%puthash key table new-value))
517
518 ;;; %PUTHASH -- public setf method.
519 ;;;
520 (defun %puthash (key hash-table value)
521 (declare (type hash-table hash-table))
522 (without-gcing
523 (let ((entries (1+ (hash-table-number-entries hash-table))))
524 (setf (hash-table-number-entries hash-table) entries)
525 (cond ((> entries (hash-table-rehash-trigger hash-table))
526 (rehash hash-table t))
527 #-gengc
528 ((= (get-header-data (hash-table-table hash-table))
529 vm:vector-must-rehash-subtype)
530 (rehash hash-table nil))))
531 #+gengc
532 (when (hash-table-needing-rehash hash-table)
533 (flush-needing-rehash hash-table))
534 (multiple-value-bind
535 (hashing eq-based)
536 (funcall (hash-table-hash-fun hash-table) key)
537 (declare (type hash hashing))
538 (let* ((vector (hash-table-table hash-table))
539 (length (length vector))
540 (index (rem hashing length))
541 (first-bucket (svref vector index)))
542 (declare (type index index))
543 (block scan
544 (if eq-based
545 (if (hash-table-weak-p hash-table)
546 (do ((bucket first-bucket (hash-table-bucket-next bucket)))
547 ((null bucket))
548 (when #+gengc (hash-table-eq-bucket-p bucket)
549 #-gengc (null (hash-table-bucket-hash bucket))
550 (multiple-value-bind
551 (bucket-key valid)
552 (weak-pointer-value (hash-table-bucket-key bucket))
553 (assert valid)
554 (when (eq key bucket-key)
555 (setf (hash-table-bucket-value bucket) value)
556 (decf (hash-table-number-entries hash-table))
557 (return-from scan nil)))))
558 (do ((bucket first-bucket (hash-table-bucket-next bucket)))
559 ((null bucket))
560 (when (eq key (hash-table-bucket-key bucket))
561 (setf (hash-table-bucket-value bucket) value)
562 (decf (hash-table-number-entries hash-table))
563 (return-from scan nil))))
564 (do ((test-fun (hash-table-test-fun hash-table))
565 (bucket first-bucket (hash-table-bucket-next bucket)))
566 ((null bucket))
567 (let ((bucket-hashing (hash-table-bucket-hash bucket)))
568 (when (and #-gengc bucket-hashing
569 (= bucket-hashing hashing)
570 #+gengc (not (hash-table-eq-bucket-p bucket))
571 (funcall test-fun
572 key
573 (hash-table-bucket-key bucket)))
574 (setf (hash-table-bucket-value bucket) value)
575 (decf (hash-table-number-entries hash-table))
576 (return-from scan nil)))))
577 #-gengc
578 (when eq-based
579 (set-header-data vector vm:vector-valid-hashing-subtype))
580 (setf (svref vector index)
581 #-gengc
582 (if eq-based
583 (make-hash-table-bucket
584 :hash nil
585 :key (if (hash-table-weak-p hash-table)
586 (make-weak-pointer key)
587 key)
588 :value value
589 :next first-bucket)
590 (make-hash-table-bucket
591 :hash hashing
592 :key key
593 :value value
594 :next first-bucket))
595 #+gengc
596 (if eq-based
597 (let ((bucket (make-hash-table-eq-bucket
598 :hash hashing
599 :key (if (hash-table-weak-p hash-table)
600 (make-weak-pointer key)
601 key)
602 :value value
603 :next first-bucket
604 :linked t)))
605 (setf (hash-table-eq-bucket-scavhook bucket)
606 (make-scavenger-hook
607 :value key
608 :function (get-hash-table-scavenger-hook
609 hash-table bucket)))
610 bucket)
611 (make-hash-table-bucket
612 :hash hashing
613 :key key
614 :value value
615 :next first-bucket)))))))
616 value)
617
618 ;;; REMHASH -- public.
619 ;;;
620 (defun remhash (key hash-table)
621 "Remove the entry in HASH-TABLE associated with KEY. Returns T if there
622 was such an entry, and NIL if not."
623 (declare (type hash-table hash-table)
624 (values (member t nil)))
625 (without-gcing
626 #-gengc
627 (when (= (get-header-data (hash-table-table hash-table))
628 vm:vector-must-rehash-subtype)
629 (rehash hash-table nil))
630 #+gengc
631 (when (hash-table-needing-rehash hash-table)
632 (flush-needing-rehash hash-table))
633 (multiple-value-bind
634 (hashing eq-based)
635 (funcall (hash-table-hash-fun hash-table) key)
636 (let* ((vector (hash-table-table hash-table))
637 (length (length vector))
638 (index (rem hashing length)))
639 (declare (type index hashing index))
640 (if eq-based
641 (if (hash-table-weak-p hash-table)
642 (do ((prev nil bucket)
643 (bucket (svref vector index)
644 (hash-table-bucket-next bucket)))
645 ((null bucket) nil)
646 (when #+gengc (hash-table-eq-bucket-p bucket)
647 #-gengc (null (hash-table-bucket-hash bucket))
648 (multiple-value-bind
649 (bucket-key valid)
650 (weak-pointer-value (hash-table-bucket-key bucket))
651 (assert valid)
652 (when (eq key bucket-key)
653 #+gengc
654 (setf (hash-table-eq-bucket-linked bucket) nil)
655 (if prev
656 (setf (hash-table-bucket-next prev)
657 (hash-table-bucket-next bucket))
658 (setf (svref vector index)
659 (hash-table-bucket-next bucket)))
660 (decf (hash-table-number-entries hash-table))
661 (return t)))))
662 (do ((prev nil bucket)
663 (bucket (svref vector index)
664 (hash-table-bucket-next bucket)))
665 ((null bucket) nil)
666 (when (eq key (hash-table-bucket-key bucket))
667 #+gengc
668 (setf (hash-table-eq-bucket-linked bucket) nil)
669 (if prev
670 (setf (hash-table-bucket-next prev)
671 (hash-table-bucket-next bucket))
672 (setf (svref vector index)
673 (hash-table-bucket-next bucket)))
674 (decf (hash-table-number-entries hash-table))
675 (return t))))
676 (do ((test-fun (hash-table-test-fun hash-table))
677 (prev nil bucket)
678 (bucket (svref vector index)
679 (hash-table-bucket-next bucket)))
680 ((null bucket) nil)
681 (let ((bucket-hashing (hash-table-bucket-hash bucket)))
682 (when (and #-gengc bucket-hashing
683 (= bucket-hashing hashing)
684 #+gengc (not (hash-table-eq-bucket-p bucket))
685 (funcall test-fun key
686 (hash-table-bucket-key bucket)))
687 (if prev
688 (setf (hash-table-bucket-next prev)
689 (hash-table-bucket-next bucket))
690 (setf (svref vector index)
691 (hash-table-bucket-next bucket)))
692 (decf (hash-table-number-entries hash-table))
693 (return t)))))))))
694
695
696 ;;; CLRHASH -- public.
697 ;;;
698 (defun clrhash (hash-table)
699 "This removes all the entries from HASH-TABLE and returns the hash table
700 itself."
701 (let ((vector (hash-table-table hash-table)))
702 (dotimes (i (length vector))
703 #+gengc
704 (do ((bucket (aref vector i) (hash-table-bucket-next bucket)))
705 ((null bucket))
706 (when (hash-table-eq-bucket-p bucket)
707 (setf (hash-table-eq-bucket-linked bucket) nil)))
708 (setf (aref vector i) nil))
709 (setf (hash-table-number-entries hash-table) 0)
710 #-gengc
711 (set-header-data vector vm:vector-normal-subtype))
712 hash-table)
713
714
715
716 ;;;; MAPHASH and WITH-HASH-TABLE-ITERATOR
717
718 (declaim (maybe-inline maphash))
719 (defun maphash (map-function hash-table)
720 "For each entry in HASH-TABLE, calls MAP-FUNCTION on the key and value
721 of the entry; returns NIL."
722 (declare (type (or function symbol) map-function)
723 (type hash-table hash-table))
724 (let ((fun (etypecase map-function
725 (function
726 map-function)
727 (symbol
728 (symbol-function map-function))))
729 (vector (hash-table-table hash-table)))
730 (declare (type function fun))
731 (if (hash-table-weak-p hash-table)
732 (dotimes (i (length vector))
733 (declare (type index i))
734 (do ((bucket (svref vector i) (hash-table-bucket-next bucket)))
735 ((null bucket))
736 (if #-gengc (null (hash-table-bucket-hash bucket))
737 #+gengc (hash-table-eq-bucket-p bucket)
738 (let ((weak-pointer (hash-table-bucket-key bucket)))
739 (multiple-value-bind
740 (key valid)
741 (weak-pointer-value weak-pointer)
742 (when valid
743 (funcall fun key (hash-table-bucket-value bucket)))))
744 (funcall fun
745 (hash-table-bucket-key bucket)
746 (hash-table-bucket-value bucket)))))
747 (dotimes (i (length vector))
748 (declare (type index i))
749 (do ((bucket (svref vector i) (hash-table-bucket-next bucket)))
750 ((null bucket))
751 (funcall fun
752 (hash-table-bucket-key bucket)
753 (hash-table-bucket-value bucket)))))))
754
755
756 (defmacro with-hash-table-iterator ((function hash-table) &body body)
757 "WITH-HASH-TABLE-ITERATOR ((function hash-table) &body body)
758 provides a method of manually looping over the elements of a hash-table.
759 function is bound to a generator-macro that, withing the scope of the
760 invocation, returns three values. First, whether there are any more objects
761 in the hash-table, second, the key, and third, the value."
762 (let ((n-function (gensym "WITH-HASH-TABLE-ITERRATOR-")))
763 `(let ((,n-function
764 (let* ((table ,hash-table)
765 (weak-p (hash-table-weak-p ,hash-table))
766 (vector (hash-table-table table))
767 (length (length vector))
768 (index 0)
769 (bucket (svref vector 0)))
770 (labels
771 ((,function ()
772 (cond
773 (bucket
774 (let ((orig bucket))
775 (setf bucket (hash-table-bucket-next orig))
776 (if (and weak-p
777 #-gengc (null (hash-table-bucket-hash orig))
778 #+gengc (hash-table-eq-bucket-p orig))
779 (multiple-value-bind
780 (key valid)
781 (weak-pointer-value
782 (hash-table-bucket-key orig))
783 (if valid
784 (values t
785 key
786 (hash-table-bucket-value orig))
787 (,function)))
788 (values t
789 (hash-table-bucket-key orig)
790 (hash-table-bucket-value orig)))))
791 ((= (incf index) length)
792 (values nil))
793 (t
794 (setf bucket (svref vector index))
795 (,function)))))
796 #',function))))
797 (macrolet ((,function () '(funcall ,n-function)))
798 ,@body))))
799
800
801
802 ;;;; SXHASH and support functions
803
804 ;;; The maximum length and depth to which we hash lists.
805 (defconstant sxhash-max-len 7)
806 (defconstant sxhash-max-depth 3)
807
808 (eval-when (compile eval)
809
810 (defconstant sxhash-bits-byte (byte 29 0))
811 (defconstant sxmash-total-bits 29)
812 (defconstant sxmash-rotate-bits 9)
813
814 (defmacro sxmash (place with)
815 `(setf ,place
816 (logxor (truly-the hash
817 (ash ,place
818 ,(- sxmash-rotate-bits sxmash-total-bits)))
819 (truly-the hash
820 (ash (logand
821 ,place
822 ,(1- (ash 1
823 (- sxmash-total-bits
824 sxmash-rotate-bits))))
825 ,sxmash-rotate-bits))
826 (truly-the hash ,with))))
827
828 (defmacro sxhash-simple-string (sequence)
829 `(%sxhash-simple-string ,sequence))
830
831 (defmacro sxhash-string (sequence)
832 (let ((data (gensym))
833 (start (gensym))
834 (end (gensym)))
835 `(with-array-data ((,data (the string ,sequence))
836 (,start)
837 (,end))
838 (if (zerop ,start)
839 (%sxhash-simple-substring ,data ,end)
840 (sxhash-simple-string (coerce (the string ,sequence)
841 'simple-string))))))
842
843 (defmacro sxhash-list (sequence depth &key (equalp nil))
844 `(if (= ,depth sxhash-max-depth)
845 0
846 (do ((sequence ,sequence (cdr (the list sequence)))
847 (index 0 (1+ index))
848 (hash 2)
849 (,depth (1+ ,depth)))
850 ((or (atom sequence) (= index sxhash-max-len)) hash)
851 (declare (fixnum hash index))
852 (sxmash hash (,(if equalp 'internal-equalp-hash 'internal-sxhash)
853 (car sequence) ,depth)))))
854
855 (defmacro sxhash-bit-vector (vector)
856 `(let* ((length (length ,vector))
857 (hash length))
858 (declare (type index length) (type hash hash))
859 (dotimes (index (min length sxhash-max-len) hash)
860 (declare (type index index))
861 (sxmash hash (bit ,vector index)))))
862
863 ); eval-when (compile eval)
864
865
866 (defun internal-sxhash (s-expr depth)
867 (declare (type index depth) (values hash))
868 (typecase s-expr
869 ;; The pointers and immediate types.
870 (list (sxhash-list s-expr depth))
871 (fixnum (ldb sxhash-bits-byte s-expr))
872 (character (char-code (char-upcase s-expr)))
873 (instance
874 (if (typep s-expr 'structure-object)
875 (internal-sxhash (class-name (layout-class (%instance-layout s-expr)))
876 depth)
877 42))
878 ;; Other-pointer types.
879 (simple-string (sxhash-simple-string s-expr))
880 (symbol (sxhash-simple-string (symbol-name s-expr)))
881 (number
882 (etypecase s-expr
883 (integer (ldb sxhash-bits-byte s-expr))
884 (single-float
885 (let ((bits (single-float-bits s-expr)))
886 (ldb sxhash-bits-byte
887 (logxor (ash bits (- sxmash-rotate-bits)) bits))))
888 (double-float
889 (let ((lo (double-float-low-bits s-expr))
890 (hi (double-float-high-bits s-expr)))
891 (ldb sxhash-bits-byte
892 (logxor (ash lo (- sxmash-rotate-bits)) lo
893 (ldb sxhash-bits-byte
894 (logxor (ash hi (- sxmash-rotate-bits)) hi))))))
895 #+long-float
896 (long-float
897 (let ((lo (long-float-low-bits s-expr))
898 #+sparc (mid (long-float-mid-bits s-expr))
899 (hi (long-float-high-bits s-expr))
900 (exp (long-float-exp-bits s-expr)))
901 (ldb sxhash-bits-byte
902 (logxor (ash lo (- sxmash-rotate-bits)) lo
903 #+sparc (ash mid (- sxmash-rotate-bits)) #+sparc mid
904 (ash hi (- sxmash-rotate-bits)) hi
905 (ldb sxhash-bits-byte
906 (logxor (ash exp (- sxmash-rotate-bits)) exp))))))
907 (ratio (logxor (internal-sxhash (numerator s-expr) 0)
908 (internal-sxhash (denominator s-expr) 0)))
909 (complex (logxor (internal-sxhash (realpart s-expr) 0)
910 (internal-sxhash (imagpart s-expr) 0)))))
911 (array
912 (typecase s-expr
913 (string (sxhash-string s-expr))
914 (simple-bit-vector (sxhash-bit-vector
915 (truly-the simple-bit-vector s-expr)))
916 (bit-vector (sxhash-bit-vector (truly-the bit-vector s-expr)))
917 (t (array-rank s-expr))))
918 ;; Everything else.
919 (t 42)))
920
921 (defun sxhash (s-expr)
922 "Computes a hash code for S-EXPR and returns it as an integer."
923 (internal-sxhash s-expr 0))
924
925
926 ;;;; Equalp hash.
927
928 (eval-when (compile eval)
929
930 (defmacro hash-table-equalp-hash (table)
931 `(let ((hash (hash-table-count ,table)))
932 (declare (type hash hash))
933 (sxmash hash (sxhash (hash-table-test ,table)))
934 hash))
935
936 (defmacro structure-equalp-hash (structure depth)
937 `(if (= ,depth sxhash-max-depth)
938 0
939 (let* ((layout (%instance-layout ,structure))
940 (length (min (1- (layout-length layout)) sxhash-max-len))
941 (hash (internal-sxhash (class-name (layout-class layout))
942 depth))
943 (,depth (+ ,depth 1)))
944 (declare (type index length) (type hash hash))
945 (do ((index 1 (1+ index)))
946 ((= index length) hash)
947 (declare (type index index))
948 (sxmash hash (internal-equalp-hash
949 (%instance-ref ,structure index) ,depth))))))
950
951 (defmacro vector-equalp-hash (vector depth)
952 `(if (= ,depth sxhash-max-depth)
953 0
954 (let* ((length (length ,vector))
955 (hash length)
956 (,depth (+ ,depth 1)))
957 (declare (type index length) (type hash hash))
958 (dotimes (index (min length sxhash-max-len) hash)
959 (declare (type index index))
960 (sxmash hash (internal-equalp-hash (aref ,vector index) ,depth))))))
961
962 (defmacro array-equalp-hash (array depth)
963 `(if (= ,depth sxhash-max-depth)
964 0
965 (let* ((size (array-total-size ,array))
966 (hash size)
967 (,depth (+ ,depth 1)))
968 (declare (type hash hash))
969 (dotimes (index (min sxhash-max-len size) hash)
970 (sxmash hash (internal-equalp-hash
971 (row-major-aref ,array index) ,depth))))))
972
973 ); eval-when (compile eval)
974
975
976 (defun internal-equalp-hash (s-expr depth)
977 (declare (type index depth) (values hash))
978 (typecase s-expr
979 ;; The pointers and immediate types.
980 (list (sxhash-list s-expr depth :equalp t))
981 (fixnum (ldb sxhash-bits-byte s-expr))
982 (character (char-code (char-upcase s-expr)))
983 (instance
984 (typecase s-expr
985 (hash-table (hash-table-equalp-hash s-expr))
986 (structure-object (structure-equalp-hash s-expr depth))
987 (t 42)))
988 ;; Other-pointer types.
989 (simple-string (vector-equalp-hash (truly-the simple-string s-expr) depth))
990 (symbol (sxhash-simple-string (symbol-name s-expr)))
991 (number
992 (etypecase s-expr
993 (integer (sxhash s-expr))
994 (float
995 (macrolet ((frob (val type)
996 (let ((lo (coerce most-negative-fixnum type))
997 (hi (coerce most-positive-fixnum type)))
998 `(if (<= ,lo ,val ,hi)
999 (multiple-value-bind (q r)
1000 (truncate ,val)
1001 (if (zerop r)
1002 (sxhash q)
1003 (sxhash (coerce ,val 'long-float))))
1004 (multiple-value-bind (q r)
1005 (truncate ,val)
1006 (if (zerop r)
1007 (sxhash q)
1008 (sxhash (coerce ,val 'long-float))))))))
1009 (etypecase s-expr
1010 (single-float (frob s-expr single-float))
1011 (double-float (frob s-expr double-float))
1012 #+long-float (long-float (frob s-expr long-float)))))
1013 (ratio
1014 (let ((float (coerce s-expr 'long-float)))
1015 (if (= float s-expr)
1016 (sxhash float)
1017 (sxhash s-expr))))
1018 (complex (if (zerop (imagpart s-expr))
1019 (internal-equalp-hash (realpart s-expr) 0)
1020 (logxor (internal-equalp-hash (realpart s-expr) 0)
1021 (internal-equalp-hash (realpart s-expr) 0))))))
1022 (array
1023 (typecase s-expr
1024 (simple-vector (vector-equalp-hash (truly-the simple-vector s-expr) depth))
1025 (vector (vector-equalp-hash s-expr depth))
1026 (t (array-equalp-hash s-expr depth))))
1027 ;; Everything else.
1028 (t 42)))
1029
1030
1031 ;;;; Dumping one as a constant.
1032
1033 (defun make-hash-table-load-form (table)
1034 (values
1035 `(make-hash-table
1036 :test ',(hash-table-test table) :size ',(hash-table-size table)
1037 :rehash-size ',(hash-table-rehash-size table)
1038 :rehash-threshold ',(hash-table-rehash-threshold table))
1039 (let ((values nil))
1040 (declare (inline maphash))
1041 (maphash #'(lambda (key value)
1042 (push (cons key value) values))
1043 table)
1044 (if values
1045 `(stuff-hash-table ,table ',values)
1046 nil))))
1047
1048 (defun stuff-hash-table (table alist)
1049 (dolist (x alist)
1050 (setf (gethash (car x) table) (cdr x))))

  ViewVC Help
Powered by ViewVC 1.1.5