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

Contents of /src/code/hash.lisp

Parent Directory Parent Directory | Revision Log Revision Log


Revision 1.44.14.1 - (hide annotations)
Thu Feb 25 20:34:49 2010 UTC (4 years, 1 month ago) by rtoy
Branch: intl-2-branch
Changes since 1.44: +3 -1 lines
Restart internalization work.  This new branch starts with code from
the intl-branch on date 2010-02-12 18:00:00+0500.  This version works
and

LANG=en@piglatin bin/lisp

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

  ViewVC Help
Powered by ViewVC 1.1.5