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

Contents of /src/code/hash.lisp

Parent Directory Parent Directory | Revision Log Revision Log


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

  ViewVC Help
Powered by ViewVC 1.1.5