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

Contents of /src/code/hash.lisp

Parent Directory Parent Directory | Revision Log Revision Log


Revision 1.43 - (show annotations)
Wed Jun 18 09:23:11 2003 UTC (10 years, 10 months ago) by gerd
Branch: MAIN
CVS Tags: double-double-array-base, release-19b-pre1, release-19b-pre2, double-double-init-sparc-2, unicode-utf16-extfmt-2009-03-27, double-double-base, snapshot-2007-09, snapshot-2007-08, snapshot-2008-08, snapshot-2008-09, ppc_gencgc_snap_2006-01-06, sse2-packed-2008-11-12, snapshot-2008-05, snapshot-2008-06, snapshot-2008-07, snapshot-2007-05, snapshot-2008-01, snapshot-2008-02, snapshot-2008-03, snapshot-2006-11, snapshot-2006-10, double-double-init-sparc, snapshot-2006-12, sse2-base, sse2-packed-base, snapshot-2003-10, snapshot-2004-10, release-19f-pre1, snapshot-2008-12, snapshot-2008-11, snapshot-2004-08, snapshot-2004-09, snapshot-2007-01, snapshot-2007-02, snapshot-2004-05, snapshot-2004-06, snapshot-2004-07, release-19e, release-19d, double-double-init-ppc, release-19c, dynamic-extent-base, unicode-utf16-sync-2008-12, release-19c-base, label-2009-03-16, release-19f-base, merge-sse2-packed, mod-arith-base, sparc_gencgc_merge, merge-with-19f, snapshot-2004-12, snapshot-2004-11, unicode-snapshot-2009-05, amd64-merge-start, ppc_gencgc_snap_2005-12-17, double-double-init-%make-sparc, unicode-utf16-sync-2008-07, unicode-utf16-sync-2008-09, unicode-utf16-extfmts-sync-2008-12, prm-before-macosx-merge-tag, snapshot-2008-04, snapshot-2003-11, snapshot-2005-07, unicode-utf16-sync-label-2009-03-16, RELEASE_19f, snapshot-2007-03, unicode-utf16-char-support-2009-03-26, unicode-utf16-char-support-2009-03-25, release-19a-base, unicode-utf16-extfmts-pre-sync-2008-11, snapshot-2008-10, sparc_gencgc, snapshot-2007-04, unicode-utf16-sync-2008-11, snapshot-2007-07, snapshot-2007-06, snapshot-2003-12, release-19a-pre1, release-19a-pre3, release-19a-pre2, release-19a, double-double-array-checkpoint, double-double-reader-checkpoint-1, release-19d-base, release-19e-pre1, double-double-irrat-end, release-19e-pre2, release-19d-pre2, release-19d-pre1, double-double-init-checkpoint-1, double-double-reader-base, label-2009-03-25, snapshot-2005-03, release-19b-base, double-double-init-x86, sse2-checkpoint-2008-10-01, snapshot-2005-11, double-double-sparc-checkpoint-1, snapshot-2004-04, sse2-merge-with-2008-11, sse2-merge-with-2008-10, snapshot-2005-10, snapshot-2005-12, snapshot-2005-01, unicode-utf16-string-support, release-19c-pre1, release-19e-base, double-double-irrat-start, snapshot-2005-06, snapshot-2005-05, snapshot-2005-04, ppc_gencgc_snap_2005-05-14, snapshot-2005-02, unicode-utf16-base, snapshot-2005-09, snapshot-2005-08, lisp-executable-base, snapshot-2007-12, snapshot-2007-10, snapshot-2007-11, snapshot-2009-02, snapshot-2009-01, snapshot-2009-05, snapshot-2009-04, snapshot-2006-02, snapshot-2006-03, snapshot-2006-01, snapshot-2006-06, snapshot-2006-07, snapshot-2006-04, snapshot-2006-05, pre-telent-clx, snapshot-2006-08, snapshot-2006-09
Branch point for: release-19b-branch, double-double-reader-branch, double-double-array-branch, mod-arith-branch, RELEASE-19F-BRANCH, sparc_gencgc_branch, dynamic-extent, release-19d-branch, ppc_gencgc_branch, sse2-packed-branch, lisp-executable, double-double-branch, unicode-utf16-branch, release-19e-branch, sse2-branch, release-19a-branch, release-19c-branch, unicode-utf16-extfmt-branch
Changes since 1.42: +3 -3 lines
	Remove package nicknames USER from COMMON-LISP-USER.  Add a new
	package COMMON-LISP which LISP uses, so that COMMON-LISP no longer
	has the non-ANSI nickname LISP.

	To bootstrap, use boot13.lisp as target:bootstrap.lisp with pmai's
	build scripts, and do a full compile.

	* src/bootfiles/18e/boot13.lisp: Change for all the package
	changes.

	* src/code/exports.lisp: New package common-lisp,
	which lisp uses.

	* src/tools/worldload.lisp:
	* src/tools/setup.lisp: Use cl-user instead of user.
	Use lisp:: instead of cl::.

	* src/tools/worldcom.lisp:
	* src/tools/snapshot-update.lisp:
	* src/tools/pclcom.lisp:
	* src/tools/mk-lisp:
	* src/tools/hemcom.lisp:
	* src/tools/config.lisp:
	* src/tools/comcom.lisp:
	* src/tools/clxcom.lisp:
	* src/tools/clmcom.lisp:
	* src/pcl/defsys.lisp:
	* src/motif/lisp/initial.lisp:
	* src/interface/initial.lisp:
	* src/hemlock/lispmode.lisp (setup-lisp-mode):
	Use cl-user instead of user.

	* src/code/save.lisp (assert-user-package):
	* src/code/print.lisp (%with-standard-io-syntax): Find
	cl-user package instead of user.

	* src/code/package.lisp (package-locks-init): Add lisp.
	(package-init): Don't add user nickname to cl-user.

	* src/code/ntrace.lisp (*trace-encapsulate-package-names*):
	Add common-lisp.

	* src/code/hash.lisp (toplevel):
	* src/code/hash-new.lisp (toplevel): Use in-package :lisp
	instead of :common-lisp.

	* src/code/float-trap.lisp (sigfpe-handler): Don't
	qualify floating-point-inexact with ext:.

	* src/pcl/simple-streams/strategy.lisp (sc):
	* src/pcl/simple-streams/null.lisp (null-read-char):
	* src/pcl/simple-streams/internal.lisp (allocate-buffer)
	(free-buffer):
	* src/pcl/simple-streams/impl.lisp (%check, %read-line)
	(%peek-char, %read-byte):
	* src/pcl/simple-streams/file.lisp (open-file-stream)
	(device-close):
	* src/pcl/simple-streams/classes.lisp (simple-stream)
	(device-close):
	* src/pcl/macros.lisp (toplevel):
	* src/pcl/braid.lisp (lisp::sxhash-instance):
	* src/pcl/env.lisp (toplevel):
	* src/compiler/generic/objdef.lisp (symbol-hash):
	* src/code/stream.lisp (read-sequence, write-sequence):
	* src/code/macros.lisp (defmacro, deftype):
	* src/code/eval.lisp (interpreted-function):
	* src/code/defstruct.lisp (defstruct):
	* src/code/debug.lisp (debug-eval-print): Use lisp:: instead
	of cl::.
1 ;;; -*- Package: CL -*-
2 ;;;
3 ;;; **********************************************************************
4 ;;; This code was written as part of the CMU Common Lisp project at
5 ;;; Carnegie Mellon University, and has been placed in the public domain.
6 ;;;
7 (ext:file-comment
8 "$Header: /tiger/var/lib/cvsroots/cmucl/src/code/hash.lisp,v 1.43 2003/06/18 09:23:11 gerd Exp $")
9 ;;;
10 ;;; **********************************************************************
11 ;;;
12 ;;; Hashing and hash table functions for Spice Lisp.
13 ;;; Originally written by Skef Wholey.
14 ;;; Everything except SXHASH rewritten by William Lott.
15 ;;; Equalp hashing by William Newman, Cadabra Inc, and Douglas Crosher, 2000.
16 ;;;
17 (in-package :lisp)
18
19 (export '(hash-table hash-table-p make-hash-table
20 gethash remhash maphash clrhash
21 hash-table-count with-hash-table-iterator
22 hash-table-rehash-size hash-table-rehash-threshold
23 hash-table-size hash-table-test sxhash))
24
25 (in-package :ext)
26 (export '(define-hash-table-test))
27
28 (in-package :lisp)
29
30
31 ;;;; The hash-table structures.
32
33 ;;; HASH-TABLE -- defstruct.
34 ;;;
35 (defstruct (hash-table
36 (:constructor %make-hash-table)
37 (:print-function %print-hash-table)
38 (:make-load-form-fun make-hash-table-load-form))
39 "Structure used to implement hash tables."
40 ;;
41 ;; The type of hash table this is. Only used for printing and as part of
42 ;; the exported interface.
43 (test (required-argument) :type symbol :read-only t)
44 ;;
45 ;; The function used to compare two keys. Returns T if they are the same
46 ;; and NIL if not.
47 (test-fun (required-argument) :type function :read-only t)
48 ;;
49 ;; The function used to compute the hashing of a key. Returns two values:
50 ;; the index hashing and T if that might change with the next GC.
51 (hash-fun (required-argument) :type function :read-only t)
52 ;;
53 ;; How much to grow the hash table by when it fills up. If an index, then
54 ;; add that amount. If a floating point number, then multiple it by that.
55 (rehash-size (required-argument) :type (or index (single-float (1.0)))
56 :read-only t)
57 ;;
58 ;; How full the hash table has to get before we rehash.
59 (rehash-threshold (required-argument) :type (single-float (0.0) 1.0)
60 :read-only t)
61 ;;
62 ;; (* rehash-threshold (length table)), saved here so we don't have to keep
63 ;; recomputing it.
64 (rehash-trigger (required-argument) :type index)
65 ;;
66 ;; The current number of entries in the table.
67 (number-entries 0 :type index)
68 ;;
69 ;; Vector of ht-buckets.
70 (table (required-argument) :type simple-vector)
71 ;;
72 ;; True if this is a weak hash table, meaning that key->value mappings will
73 ;; disappear if there are no other references to the key. Note: this only
74 ;; matters if the hash function indicates that the hashing is EQ based.
75 (weak-p nil :type (member t nil))
76 ;;
77 #+gengc
78 ;; Chain of buckets that need to be rehashed because their hashing is EQ
79 ;; based and the key has been moved by the garbage collector.
80 (needing-rehash nil :type (or null hash-table-bucket)))
81 ;;;
82 (defun %print-hash-table (ht stream depth)
83 (declare (ignore depth) (stream stream))
84 (print-unreadable-object (ht stream :identity t)
85 (format stream "~A hash table, ~D entr~@:P"
86 (symbol-name (hash-table-test ht))
87 (hash-table-number-entries ht))))
88
89 (defconstant max-hash most-positive-fixnum)
90
91 (deftype hash ()
92 `(integer 0 ,max-hash))
93
94
95 (defstruct (hash-table-bucket
96 (:print-function %print-hash-table-bucket))
97 ;;
98 ;; The hashing associated with key, kept around so we don't have to recompute
99 ;; it each time. In the non-gengc system, if this is NIL it means that the
100 ;; hashing is EQ based, so use the address of the value. If the gengc
101 ;; system, we use the presence of the scavhook to tell that.
102 #-gengc (hash nil :type (or hash null))
103 #+gengc (hash 0 :type hash)
104 ;;
105 ;; The key and value, originally supplied by the user. If the hash table
106 ;; is weak, and this is eq based, then the key is really a weak pointer to
107 ;; the key.
108 (key nil :type t)
109 (value nil :type t)
110 ;;
111 ;; The next bucket, or NIL if there are no more.
112 (next nil :type (or hash-table-bucket null)))
113 ;;;
114 (defun %print-hash-table-bucket (bucket stream depth)
115 (declare (ignore depth))
116 (print-unreadable-object (bucket stream :type t)
117 (format stream "for ~S->~S~@[ ~D~]"
118 (hash-table-bucket-key bucket)
119 (hash-table-bucket-value bucket)
120 (hash-table-bucket-hash bucket))))
121
122 #+gengc
123 (defstruct (hash-table-eq-bucket
124 (:include hash-table-bucket))
125 ;;
126 ;; The scavenger-hook object used to detect when the EQ hashing of key will
127 ;; change. Only NIL during creation.
128 (scavhook nil :type (or null scavenger-hook))
129 ;;
130 ;; True iff this bucket is still linked into the corresponding hash table's
131 ;; vector.
132 (linked nil :type (member t nil)))
133
134 #|
135
136 ;;; SCAN-STATE -- defstruct.
137 ;;;
138 ;;; Holds the state of a MAPHASH or WITH-HASH-TABLE-ITERATOR.
139 ;;;
140 (defstruct (scan-state)
141 ;;
142 ;; The index into the hash-table-table.
143 (index 0 :type index)
144 ;;
145 ;; The current bucket in that chain.
146 (bucket nil :type (or null hash-table-bucket))
147 ;;
148 )
149
150 ;;; Non-gengc:
151 ;;;
152 ;;; %puthash: if there are any active scans, then make sure the current bucket
153 ;;; for each scan holds the key we are trying to puthash, and flame out of it
154 ;;; isn't. Given that we have our hands directly on the correct bucket, just
155 ;;; go for it.
156 ;;;
157 ;;; remhash: make the same check as with %puthash. If it checks out, then
158 ;;; just scan down the correct bucket chain and yank it.
159 ;;;
160 ;;; rehash: because of the above two tests, rehash will only be called by
161 ;;; gethash. And we need to do the rehash in order to look anything up. So
162 ;;; make a list of all the remaining buckets, and stick them in the scan-state.
163 ;;;
164 ;;; Gengc:
165 ;;;
166 ;;; %puthash & remhash: same as above.
167 ;;;
168 ;;; rehash: is only ever called by puthash, so doesn't need anything special to
169 ;;; account for active scans.
170 ;;;
171 ;;; flush-needing-rehash: will only be called by gethash for the same reason
172 ;;; rehash is only called by gethash in the non-gengc system. And basically
173 ;;; needs to do the same thing rehash does in the non-gengc system.
174 ;;;
175 ;;; hash-table-scavenger-hook: needs to check to see if the bucket being
176 ;;; unlinked is after the current bucket in any of the active scans. If so,
177 ;;; it needs to add it to a list of buckets that will be processed after all
178 ;;; the buckets visable in the hash-table-table have been delt with.
179
180 |#
181
182
183 ;;;; Utility functions.
184
185 (declaim (inline pointer-hash))
186 (defun pointer-hash (key)
187 (declare (values hash))
188 (truly-the hash (%primitive make-fixnum key)))
189
190 (declaim (inline eq-hash))
191 (defun eq-hash (key)
192 (declare (values hash (member t nil)))
193 (values (pointer-hash key)
194 (oddp (get-lisp-obj-address key))))
195
196 (declaim (inline eql-hash))
197 (defun eql-hash (key)
198 (declare (values hash (member t nil)))
199 (if (numberp key)
200 (equal-hash key)
201 (eq-hash key)))
202
203 (declaim (inline equal-hash))
204 (defun equal-hash (key)
205 (declare (values hash (member t nil)))
206 (values (sxhash key) nil))
207
208 (defun equalp-hash (key)
209 (declare (values hash (member t nil)))
210 (values (internal-equalp-hash key 0) nil))
211
212
213 (defun almost-primify (num)
214 (declare (type index num))
215 "Almost-Primify returns an almost prime number greater than or equal
216 to NUM."
217 (if (= (rem num 2) 0)
218 (setq num (+ 1 num)))
219 (if (= (rem num 3) 0)
220 (setq num (+ 2 num)))
221 (if (= (rem num 7) 0)
222 (setq num (+ 4 num)))
223 num)
224
225
226
227 ;;;; User defined hash table tests.
228
229 ;;; *HASH-TABLE-TESTS* -- Internal.
230 ;;;
231 (defvar *hash-table-tests* nil)
232
233 ;;; DEFINE-HASH-TABLE-TEST -- Public.
234 ;;;
235 (defun define-hash-table-test (name test-fun hash-fun)
236 "Define a new kind of hash table test."
237 (declare (type symbol name)
238 (type function test-fun hash-fun))
239 (setf *hash-table-tests*
240 (cons (list name test-fun hash-fun)
241 (remove name *hash-table-tests* :test #'eq :key #'car)))
242 name)
243
244
245 ;;;; Construction and simple accessors.
246
247 ;;; MAKE-HASH-TABLE -- public.
248 ;;;
249 (defun make-hash-table (&key (test 'eql) (size 65) (rehash-size 1.5)
250 (rehash-threshold 1) (weak-p nil))
251 "Creates and returns a new hash table. The keywords are as follows:
252 :TEST -- Indicates what kind of test to use. Only EQ, EQL, EQUAL,
253 and EQUALP are currently supported.
254 :SIZE -- A hint as to how many elements will be put in this hash
255 table.
256 :REHASH-SIZE -- Indicates how to expand the table when it fills up.
257 If an integer, add space for that many elements. If a floating
258 point number (which must be greater than 1.0), multiple the size
259 by that amount.
260 :REHASH-THRESHOLD -- Indicates how dense the table can become before
261 forcing a rehash. Can be any positive number <= to 1, with density
262 approaching zero as the threshold approaches 0. Density 1 means an
263 average of one entry per bucket.
264 CMUCL Extension:
265 :WEAK-P -- If T, don't keep entries if the key would otherwise be
266 garbage."
267 (declare (type (or function symbol) test)
268 (type index size) (type (member t nil) weak-p))
269 (let ((rehash-size (if (integerp rehash-size)
270 rehash-size
271 (float rehash-size 1.0)))
272 (rehash-threshold (float rehash-threshold 1.0)))
273 (multiple-value-bind
274 (test test-fun hash-fun)
275 (cond ((or (eq test #'eq) (eq test 'eq))
276 (values 'eq #'eq #'eq-hash))
277 ((or (eq test #'eql) (eq test 'eql))
278 (values 'eql #'eql #'eql-hash))
279 ((or (eq test #'equal) (eq test 'equal))
280 (values 'equal #'equal #'equal-hash))
281 ((or (eq test #'equalp) (eq test 'equalp))
282 (values 'equalp #'equalp #'equalp-hash))
283 (t
284 (dolist (info *hash-table-tests*
285 (error "Unknown :TEST for MAKE-HASH-TABLE: ~S"
286 test))
287 (destructuring-bind
288 (test-name test-fun hash-fun)
289 info
290 (when (or (eq test test-name) (eq test test-fun))
291 (return (values test-name test-fun hash-fun)))))))
292 (let* ((scaled-size (round (/ (float size) rehash-threshold)))
293 (length (if (<= scaled-size 37) 37 (almost-primify scaled-size)))
294 (vector (make-array length :initial-element nil)))
295 (declare (type index scaled-size length)
296 (type simple-vector vector))
297 (%make-hash-table
298 :test test
299 :test-fun test-fun
300 :hash-fun hash-fun
301 :rehash-size rehash-size
302 :rehash-threshold rehash-threshold
303 :rehash-trigger (round (* (float length) rehash-threshold))
304 :table vector
305 :weak-p weak-p)))))
306
307 (declaim (inline hash-table-count))
308 (defun hash-table-count (hash-table)
309 "Returns the number of entries in the given HASH-TABLE."
310 (declare (type hash-table hash-table)
311 (values index))
312 (hash-table-number-entries hash-table))
313
314 (setf (documentation 'hash-table-rehash-size 'function)
315 "Return the rehash-size HASH-TABLE was created with.")
316
317 (setf (documentation 'hash-table-rehash-threshold 'function)
318 "Return the rehash-threshold HASH-TABLE was created with.")
319
320 (declaim (inline hash-table-size))
321 (defun hash-table-size (hash-table)
322 "Return a size that can be used with MAKE-HASH-TABLE to create a hash
323 table that can hold however many entries HASH-TABLE can hold without
324 having to be grown."
325 (hash-table-rehash-trigger hash-table))
326
327 (setf (documentation 'hash-table-test 'function)
328 "Return the test HASH-TABLE was created with.")
329
330 (setf (documentation 'hash-table-weak-p 'function)
331 "Return T if HASH-TABLE will not keep entries for keys that would
332 otherwise be garbage, and NIL if it will.")
333
334
335 ;;;; Accessing functions.
336
337 ;;; REHASH -- internal.
338 ;;;
339 ;;; Make a new vector for TABLE. If GROW is NIL, use the same size as before,
340 ;;; otherwise extend the table based on the rehash-size.
341 ;;;
342 (defun rehash (table grow)
343 (declare (type hash-table table))
344 (let* ((old-vector (hash-table-table table))
345 (old-length (length old-vector))
346 (new-length
347 (if grow
348 (let ((rehash-size (hash-table-rehash-size table)))
349 (etypecase rehash-size
350 (fixnum
351 (+ rehash-size old-length))
352 (float
353 (the (values index t) (round (* rehash-size old-length))))))
354 old-length))
355 (new-vector (make-array new-length :initial-element nil))
356 #-gengc (weak-p (hash-table-weak-p table)))
357 (declare (type index new-length))
358 (dotimes (i old-length)
359 (declare (type index i))
360 (do ((bucket (svref old-vector i) next)
361 (next nil))
362 ((null bucket))
363 (setf next (hash-table-bucket-next bucket))
364 (block deal-with-one-bucket
365 (let* ((hashing
366 #-gengc
367 (or (hash-table-bucket-hash bucket)
368 (let ((key (hash-table-bucket-key bucket)))
369 (set-header-data new-vector
370 vm:vector-valid-hashing-subtype)
371 (if weak-p
372 (multiple-value-bind
373 (real-key valid)
374 (weak-pointer-value key)
375 (cond (valid
376 (pointer-hash real-key))
377 (t
378 (decf (hash-table-number-entries table))
379 (return-from deal-with-one-bucket nil))))
380 (pointer-hash key))))
381 #+gengc (hash-table-bucket-hash bucket))
382 (index (rem hashing new-length)))
383 (declare (type index hashing index))
384 (setf (hash-table-bucket-next bucket) (svref new-vector index))
385 (setf (svref new-vector index) bucket))))
386 ;; We clobber the old vector contents so that if it is living in
387 ;; static space it won't keep ahold of pointers into dynamic space.
388 (setf (svref old-vector i) nil))
389 (setf (hash-table-table table) new-vector)
390 (unless (= new-length old-length)
391 (setf (hash-table-rehash-trigger table)
392 (round (* (hash-table-rehash-threshold table)
393 (float new-length))))))
394 (undefined-value))
395
396 #+gengc
397 (defun flush-needing-rehash (table)
398 (let* ((weak-p (hash-table-weak-p table))
399 (vector (hash-table-table table))
400 (length (length vector)))
401 (do ((bucket (hash-table-needing-rehash table) next)
402 (next nil))
403 ((null bucket))
404 (setf next (hash-table-bucket-next bucket))
405 (flet ((relink-bucket (key)
406 (let* ((hashing (pointer-hash key))
407 (index (rem hashing length)))
408 (setf (hash-table-bucket-hash bucket) hashing)
409 (setf (hash-table-bucket-next bucket) (svref vector index))
410 (setf (svref vector index) bucket)
411 (setf (hash-table-eq-bucket-linked bucket) t))))
412 (let ((key (hash-table-bucket-key bucket)))
413 (if weak-p
414 (multiple-value-bind
415 (real-key valid)
416 (weak-pointer-value key)
417 (if valid
418 (relink-bucket real-key)
419 (decf (hash-table-number-entries table))))
420 (relink-bucket key))))))
421 (setf (hash-table-needing-rehash table) nil)
422 (undefined-value))
423
424 ;;; GETHASH -- Public.
425 ;;;
426 (defun gethash (key hash-table &optional default)
427 "Finds the entry in HASH-TABLE whose key is KEY and returns the associated
428 value and T as multiple values, or returns DEFAULT and NIL if there is no
429 such entry. Entries can be added using SETF."
430 (declare (type hash-table hash-table)
431 (values t (member t nil)))
432 (without-gcing
433 #-gengc
434 (when (= (get-header-data (hash-table-table hash-table))
435 vm:vector-must-rehash-subtype)
436 (rehash hash-table nil))
437 #+gengc
438 (when (hash-table-needing-rehash hash-table)
439 (flush-needing-rehash hash-table))
440 (multiple-value-bind
441 (hashing eq-based)
442 (funcall (hash-table-hash-fun hash-table) key)
443 (let* ((vector (hash-table-table hash-table))
444 (length (length vector))
445 (index (rem hashing length)))
446 (declare (type index hashing))
447 (if eq-based
448 (if (hash-table-weak-p hash-table)
449 (do ((bucket (svref vector index)
450 (hash-table-bucket-next bucket)))
451 ((null bucket) (values default nil))
452 (when #+gengc (hash-table-eq-bucket-p bucket)
453 #-gengc (null (hash-table-bucket-hash bucket))
454 (multiple-value-bind
455 (bucket-key valid)
456 (weak-pointer-value (hash-table-bucket-key bucket))
457 (assert valid)
458 (when (eq key bucket-key)
459 (return (values (hash-table-bucket-value bucket) t))))))
460 (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
476
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
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
517 ;;; %PUTHASH -- public setf method.
518 ;;;
519 (defun %puthash (key hash-table value)
520 (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 #-gengc
527 ((= (get-header-data (hash-table-table hash-table))
528 vm:vector-must-rehash-subtype)
529 (rehash hash-table nil))))
530 #+gengc
531 (when (hash-table-needing-rehash hash-table)
532 (flush-needing-rehash hash-table))
533 (multiple-value-bind
534 (hashing eq-based)
535 (funcall (hash-table-hash-fun hash-table) key)
536 (declare (type hash hashing))
537 (let* ((vector (hash-table-table hash-table))
538 (length (length vector))
539 (index (rem hashing length))
540 (first-bucket (svref vector index)))
541 (declare (type index index))
542 (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 :key (if (hash-table-weak-p hash-table)
585 (make-weak-pointer key)
586 key)
587 :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 :key (if (hash-table-weak-p hash-table)
599 (make-weak-pointer key)
600 key)
601 :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 value)
616
617 ;;; REMHASH -- public.
618 ;;;
619 (defun remhash (key hash-table)
620 "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 #-gengc
626 (when (= (get-header-data (hash-table-table hash-table))
627 vm:vector-must-rehash-subtype)
628 (rehash hash-table nil))
629 #+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
694
695 ;;; 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 #+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 (setf (aref vector i) nil))
708 (setf (hash-table-number-entries hash-table) 0)
709 #-gengc
710 (set-header-data vector vm:vector-normal-subtype))
711 hash-table)
712
713
714
715 ;;;; MAPHASH and WITH-HASH-TABLE-ITERATOR
716
717 (declaim (maybe-inline maphash))
718 (defun maphash (map-function hash-table)
719 "For each entry in HASH-TABLE, calls MAP-FUNCTION on the key and value
720 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 (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
754
755 (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 (weak-p (hash-table-weak-p ,hash-table))
765 (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 (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 ((= (incf index) length)
791 (values nil))
792 (t
793 (setf bucket (svref vector index))
794 (,function)))))
795 #',function))))
796 (macrolet ((,function () '(funcall ,n-function)))
797 ,@body))))
798
799
800
801 ;;;; SXHASH and support functions
802
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 (defconstant sxhash-bits-byte (byte 29 0))
810 (defconstant sxmash-total-bits 29)
811 (defconstant sxmash-rotate-bits 9)
812
813 (defmacro sxmash (place with)
814 `(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
827 (defmacro sxhash-simple-string (sequence)
828 `(%sxhash-simple-string ,sequence))
829
830 (defmacro sxhash-string (sequence)
831 (let ((data (gensym))
832 (start (gensym))
833 (end (gensym)))
834 `(with-array-data ((,data (the (values string &rest t) ,sequence))
835 (,start)
836 (,end))
837 (if (zerop ,start)
838 (%sxhash-simple-substring ,data ,end)
839 (sxhash-simple-string (coerce (the (values string &rest t)
840 ,sequence)
841 'simple-string))))))
842
843 (defmacro sxhash-list (sequence depth &key (equalp nil))
844 `(if (= ,depth sxhash-max-depth)
845 0
846 (do ((sequence ,sequence (cdr (the list sequence)))
847 (index 0 (1+ index))
848 (hash 2)
849 (,depth (1+ ,depth)))
850 ((or (atom sequence) (= index sxhash-max-len)) hash)
851 (declare (fixnum hash index))
852 (sxmash hash (,(if equalp 'internal-equalp-hash 'internal-sxhash)
853 (car sequence) ,depth)))))
854
855 (defmacro sxhash-bit-vector (vector)
856 `(let* ((length (length ,vector))
857 (hash length))
858 (declare (type index length) (type hash hash))
859 (dotimes (index (min length sxhash-max-len) hash)
860 (declare (type index index))
861 (sxmash hash (bit ,vector index)))))
862
863 ); eval-when (compile eval)
864
865
866 (defun internal-sxhash (s-expr depth)
867 (declare (type index depth) (values hash))
868 (typecase s-expr
869 ;; The pointers and immediate types.
870 (list (sxhash-list s-expr depth))
871 (fixnum (ldb sxhash-bits-byte s-expr))
872 (character (char-code (char-upcase s-expr)))
873 (instance
874 (if (typep s-expr 'structure-object)
875 (internal-sxhash (%class-name (layout-class (%instance-layout s-expr)))
876 depth)
877 (sxhash-instance s-expr)))
878 (funcallable-instance (sxhash-instance s-expr))
879 ;; Other-pointer types.
880 (simple-string (sxhash-simple-string s-expr))
881 (symbol (sxhash-simple-string (symbol-name s-expr)))
882 (number
883 (etypecase s-expr
884 (integer (ldb sxhash-bits-byte s-expr))
885 (single-float
886 (let ((bits (single-float-bits s-expr)))
887 (ldb sxhash-bits-byte
888 (logxor (ash bits (- sxmash-rotate-bits)) bits))))
889 (double-float
890 (let ((lo (double-float-low-bits s-expr))
891 (hi (double-float-high-bits s-expr)))
892 (ldb sxhash-bits-byte
893 (logxor (ash lo (- sxmash-rotate-bits)) lo
894 (ldb sxhash-bits-byte
895 (logxor (ash hi (- sxmash-rotate-bits)) hi))))))
896 #+long-float
897 (long-float
898 (let ((lo (long-float-low-bits s-expr))
899 #+sparc (mid (long-float-mid-bits s-expr))
900 (hi (long-float-high-bits s-expr))
901 (exp (long-float-exp-bits s-expr)))
902 (ldb sxhash-bits-byte
903 (logxor (ash lo (- sxmash-rotate-bits)) lo
904 #+sparc (ash mid (- sxmash-rotate-bits)) #+sparc mid
905 (ash hi (- sxmash-rotate-bits)) hi
906 (ldb sxhash-bits-byte
907 (logxor (ash exp (- sxmash-rotate-bits)) exp))))))
908 (ratio (logxor (internal-sxhash (numerator s-expr) 0)
909 (internal-sxhash (denominator s-expr) 0)))
910 (complex (logxor (internal-sxhash (realpart s-expr) 0)
911 (internal-sxhash (imagpart s-expr) 0)))))
912 (array
913 (typecase s-expr
914 (string (sxhash-string s-expr))
915 (simple-bit-vector (sxhash-bit-vector
916 (truly-the simple-bit-vector s-expr)))
917 (bit-vector (sxhash-bit-vector (truly-the bit-vector s-expr)))
918 (t (array-rank s-expr))))
919 ;; Everything else.
920 (t 42)))
921
922 (defun sxhash (s-expr)
923 "Computes a hash code for S-EXPR and returns it as an integer."
924 (internal-sxhash s-expr 0))
925
926
927 ;;;; Equalp hash.
928
929 (eval-when (compile eval)
930
931 (defmacro hash-table-equalp-hash (table)
932 `(let ((hash (hash-table-count ,table)))
933 (declare (type hash hash))
934 (sxmash hash (sxhash (hash-table-test ,table)))
935 hash))
936
937 (defmacro structure-equalp-hash (structure depth)
938 `(if (= ,depth sxhash-max-depth)
939 0
940 (let* ((layout (%instance-layout ,structure))
941 (length (min (1- (layout-length layout)) sxhash-max-len))
942 (hash (internal-sxhash (%class-name (layout-class layout))
943 depth))
944 (,depth (+ ,depth 1)))
945 (declare (type index length) (type hash hash))
946 (do ((index 1 (1+ index)))
947 ((= index length) hash)
948 (declare (type index index))
949 (sxmash hash (internal-equalp-hash
950 (%instance-ref ,structure index) ,depth))))))
951
952 (defmacro vector-equalp-hash (vector depth)
953 `(if (= ,depth sxhash-max-depth)
954 0
955 (let* ((length (length ,vector))
956 (hash length)
957 (,depth (+ ,depth 1)))
958 (declare (type index length) (type hash hash))
959 (dotimes (index (min length sxhash-max-len) hash)
960 (declare (type index index))
961 (sxmash hash (internal-equalp-hash (aref ,vector index) ,depth))))))
962
963 (defmacro array-equalp-hash (array depth)
964 `(if (= ,depth sxhash-max-depth)
965 0
966 (let* ((size (array-total-size ,array))
967 (hash size)
968 (,depth (+ ,depth 1)))
969 (declare (type hash hash))
970 (dotimes (index (min sxhash-max-len size) hash)
971 (sxmash hash (internal-equalp-hash
972 (row-major-aref ,array index) ,depth))))))
973
974 ); eval-when (compile eval)
975
976
977 (defun internal-equalp-hash (s-expr depth)
978 (declare (type index depth) (values hash))
979 (typecase s-expr
980 ;; The pointers and immediate types.
981 (list (sxhash-list s-expr depth :equalp t))
982 (fixnum (ldb sxhash-bits-byte s-expr))
983 (character (char-code (char-upcase s-expr)))
984 (instance
985 (typecase s-expr
986 (hash-table (hash-table-equalp-hash s-expr))
987 (structure-object (structure-equalp-hash s-expr depth))
988 (t 42)))
989 ;; Other-pointer types.
990 (simple-string (vector-equalp-hash (truly-the simple-string s-expr) depth))
991 (symbol (sxhash-simple-string (symbol-name s-expr)))
992 (number
993 (etypecase s-expr
994 (integer (sxhash s-expr))
995 (float
996 (macrolet ((frob (val type)
997 (let ((lo (coerce most-negative-fixnum type))
998 (hi (coerce most-positive-fixnum type)))
999 `(if (<= ,lo ,val ,hi)
1000 (multiple-value-bind (q r)
1001 (truncate ,val)
1002 (if (zerop r)
1003 (sxhash q)
1004 (sxhash (coerce ,val 'long-float))))
1005 (multiple-value-bind (q r)
1006 (truncate ,val)
1007 (if (zerop r)
1008 (sxhash q)
1009 (sxhash (coerce ,val 'long-float))))))))
1010 (etypecase s-expr
1011 (single-float (frob s-expr single-float))
1012 (double-float (frob s-expr double-float))
1013 #+long-float (long-float (frob s-expr long-float)))))
1014 (ratio
1015 (let ((float (coerce s-expr 'long-float)))
1016 (if (= float s-expr)
1017 (sxhash float)
1018 (sxhash s-expr))))
1019 (complex (if (zerop (imagpart s-expr))
1020 (internal-equalp-hash (realpart s-expr) 0)
1021 (logxor (internal-equalp-hash (realpart s-expr) 0)
1022 (internal-equalp-hash (realpart s-expr) 0))))))
1023 (array
1024 (typecase s-expr
1025 (simple-vector (vector-equalp-hash (truly-the simple-vector s-expr) depth))
1026 (vector (vector-equalp-hash s-expr depth))
1027 (t (array-equalp-hash s-expr depth))))
1028 ;; Everything else.
1029 (t 42)))
1030
1031
1032 ;;;; Dumping one as a constant.
1033
1034 (defun make-hash-table-load-form (table)
1035 (values
1036 `(make-hash-table
1037 :test ',(hash-table-test table) :size ',(hash-table-size table)
1038 :rehash-size ',(hash-table-rehash-size table)
1039 :rehash-threshold ',(hash-table-rehash-threshold table))
1040 (let ((values nil))
1041 (declare (inline maphash))
1042 (maphash #'(lambda (key value)
1043 (push (cons key value) values))
1044 table)
1045 (if values
1046 `(stuff-hash-table ,table ',values)
1047 nil))))
1048
1049 (defun stuff-hash-table (table alist)
1050 (dolist (x alist)
1051 (setf (gethash (car x) table) (cdr x))))

  ViewVC Help
Powered by ViewVC 1.1.5