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

Contents of /src/code/hash.lisp

Parent Directory Parent Directory | Revision Log Revision Log


Revision 1.29.2.3 - (hide annotations)
Sun Jul 9 14:03:00 2000 UTC (13 years, 9 months ago) by dtc
Branch: RELENG_18
CVS Tags: RELEASE_18d, RELEASE_18c
Changes since 1.29.2.2: +4 -3 lines
Reworking of the values-type system to overcome a number of inconsistencies
causing problems:

o Redefine coerce-to-values to convert a single value type into (values type),
  rather than the former definition (values type &rest t). A single value
  type such as fixnum is now equivalent to (values fixnum).

o Now when the compiler makes assertions for the first value of
  continuations that may be generating multiple values it asserts the
  type as (values type &rest t), or as (value &optional type &rest t) if
  it is not sure that the continuation does generate a value.

o Enhance the type check generation to better handle the now common
  values types with optional and rest arguments. Add the new function
  Values-types-asserted which converts asserted optional and rest
  arguments to required arguments that have been proven to be delivered,
  Thus an assertion such as (values &optional fixnum &rest t) will
  generate a fixnum type check if the proven type if (values t).

o The compiler is now far more likely to pickup attempts to use an
  assertion to select a subset of values. For example
  (the (values fixnum) (values x y)) will generated a compiler warning.

o Update single values type assertions where appropriate to clarify that
  the received values may be optional or that multiple values may be
  received. For example, a macro argument which had been asserted to be
  a list via (the list ,...) would now be asserted to be
  (the (values &optional list &rest t)) etc.

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

  ViewVC Help
Powered by ViewVC 1.1.5