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

Contents of /src/code/hash.lisp

Parent Directory Parent Directory | Revision Log Revision Log


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

  ViewVC Help
Powered by ViewVC 1.1.5