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

Contents of /src/code/hash.lisp

Parent Directory Parent Directory | Revision Log Revision Log


Revision 1.20 - (show annotations)
Mon Oct 26 03:44:16 1992 UTC (21 years, 5 months ago) by wlott
Branch: MAIN
Changes since 1.19: +18 -2 lines
Added EXT:*HASH-TABLE-TESTS* and made MAKE-HASH-TABLE look in it for any
:TEST types that it doesn't understand.  Entries in EXT:*HASH-TABLE-TESTS*
should be lists of the three values: the name, the test function, and the
hash function.  The test function takes two objects and returns true iff
they are the same.  The hash function takes one object and returns two
values: the (positive fixnum) hash value and true if the hashing depends on
pointer values and will have to be redone if the object moves.
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 ;;; If you want to use this code or any part of CMU Common Lisp, please contact
7 ;;; Scott Fahlman or slisp-group@cs.cmu.edu.
8 ;;;
9 (ext:file-comment
10 "$Header: /tiger/var/lib/cvsroots/cmucl/src/code/hash.lisp,v 1.20 1992/10/26 03:44:16 wlott Exp $")
11 ;;;
12 ;;; **********************************************************************
13 ;;;
14 ;;; Hashing and hash table functions for Spice Lisp.
15 ;;; Originally written by Skef Wholey.
16 ;;; Everything except SXHASH rewritten by William Lott.
17 ;;;
18 (in-package :common-lisp)
19
20 (export '(hash-table hash-table-p make-hash-table
21 gethash remhash maphash clrhash
22 hash-table-count with-hash-table-iterator
23 hash-table-rehash-size hash-table-rehash-threshold
24 hash-table-size hash-table-test
25 sxhash))
26
27 (in-package :ext)
28 (export '(*hash-table-tests*))
29
30 (in-package :common-lisp)
31
32
33 ;;;; The hash-table structure.
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 (float (1.0))) :read-only t)
56 ;;
57 ;; How full the hash table has to get before we rehash.
58 (rehash-threshold (required-argument) :type (real 0 1) :read-only t)
59 ;;
60 ;; (* rehash-threshold (length table)), saved here so we don't have to keep
61 ;; recomputing it.
62 (rehash-trigger (required-argument) :type index)
63 ;;
64 ;; The current number of entries in the table.
65 (number-entries 0 :type index)
66 ;;
67 ;; Vector of ht-buckets.
68 (table (required-argument) :type simple-vector))
69 ;;;
70 (defun %print-hash-table (ht stream depth)
71 (declare (ignore depth))
72 (print-unreadable-object (ht stream :identity t)
73 (format stream "~A hash table, ~D entr~@:P"
74 (symbol-name (hash-table-test ht))
75 (hash-table-number-entries ht))))
76
77 (defconstant max-hash most-positive-fixnum)
78
79 (deftype hash ()
80 `(integer 0 ,max-hash))
81
82
83 (defstruct hash-table-bucket
84 ;;
85 ;; The hashing associated with key, kept around so we don't have to recompute
86 ;; it each time. When NIL, then just use %primitive make-fixnum. We don't
87 ;; cache the results of make-fixnum, because it can change with a GC.
88 (hash nil :type (or hash null))
89 ;;
90 ;; The key and value, originally supplied by the user.
91 (key nil :type t)
92 (value nil :type t)
93 ;;
94 ;; The next bucket, or NIL if there are no more.
95 (next nil :type (or hash-table-bucket null)))
96
97
98
99 ;;;; Utility functions.
100
101 (declaim (inline pointer-hash))
102 (defun pointer-hash (key)
103 (declare (values hash))
104 (truly-the hash (%primitive make-fixnum key)))
105
106 (declaim (inline eq-hash))
107 (defun eq-hash (key)
108 (declare (values hash (member t nil)))
109 (values (pointer-hash key)
110 (oddp (get-lisp-obj-address key))))
111
112 (declaim (inline eql-hash))
113 (defun eql-hash (key)
114 (declare (values hash (member t nil)))
115 (if (numberp key)
116 (equal-hash key)
117 (eq-hash key)))
118
119 (declaim (inline equal-hash))
120 (defun equal-hash (key)
121 (declare (values hash (member t nil)))
122 (values (sxhash key) nil))
123
124
125 (defun almost-primify (num)
126 (declare (type index num))
127 "Almost-Primify returns an almost prime number greater than or equal
128 to NUM."
129 (if (= (rem num 2) 0)
130 (setq num (+ 1 num)))
131 (if (= (rem num 3) 0)
132 (setq num (+ 2 num)))
133 (if (= (rem num 7) 0)
134 (setq num (+ 4 num)))
135 num)
136
137
138
139 ;;;; Construction and simple accessors.
140
141 ;;; *HASH-TABLE-TESTS* -- Public.
142 ;;;
143 (defvar *hash-table-tests* nil)
144
145 ;;; MAKE-HASH-TABLE -- public.
146 ;;;
147 (defun make-hash-table (&key (test 'eql) (size 65) (rehash-size 1.5)
148 (rehash-threshold 1))
149 "Creates and returns a new hash table. The keywords are as follows:
150 :TEST -- Indicates what kind of test to use. Only EQ, EQL, and EQUAL
151 are currently supported.
152 :SIZE -- A hint as to how many elements will be put in this hash
153 table.
154 :REHASH-SIZE -- Indicates how to expand the table when it fills up.
155 If an integer, add space for that many elements. If a floating
156 point number (which must be greater than 1.0), multiple the size
157 by that amount.
158 :REHASH-THRESHOLD -- Indicates how dense the table can become before
159 forcing a rehash. Can be any real number between 0 and 1 (inclusive)."
160 (declare (type (or function (member eq eql equal)) test)
161 (type index size)
162 (type (or index (float (1.0))) rehash-size)
163 (type (real 0 1) rehash-threshold))
164 (multiple-value-bind
165 (test test-fun hash-fun)
166 (cond ((or (eq test #'eq) (eq test 'eq))
167 (values 'eq #'eq #'eq-hash))
168 ((or (eq test #'eql) (eq test 'eql))
169 (values 'eql #'eql #'eql-hash))
170 ((or (eq test #'equal) (eq test 'equal))
171 (values 'equal #'equal #'equal-hash))
172 (t
173 (dolist (info *hash-table-tests*
174 (error "Unknown :TEST for MAKE-HASH-TABLE: ~S"
175 test))
176 (destructuring-bind
177 (test-name test-fun hash-fun)
178 info
179 (when (or (eq test test-name) (eq test test-fun))
180 (return (values test-name test-fun hash-fun)))))))
181 (let* ((size (ceiling size rehash-threshold))
182 (length (if (<= size 37) 37 (almost-primify size)))
183 (vector (make-array length :initial-element nil)))
184 (declare (type index size length)
185 (type simple-vector vector))
186 (%make-hash-table
187 :test test
188 :test-fun test-fun
189 :hash-fun hash-fun
190 :rehash-size rehash-size
191 :rehash-threshold rehash-threshold
192 :rehash-trigger (* size rehash-threshold)
193 :table vector))))
194
195 (defun hash-table-count (hash-table)
196 "Returns the number of entries in the given HASH-TABLE."
197 (declare (type hash-table hash-table)
198 (values index))
199 (hash-table-number-entries hash-table))
200
201 (setf (documentation 'hash-table-rehash-size 'function)
202 "Return the rehash-size HASH-TABLE was created with.")
203
204 (setf (documentation 'hash-table-rehash-threshold 'function)
205 "Return the rehash-threshold HASH-TABLE was created with.")
206
207 (defun hash-table-size (hash-table)
208 "Return a size that can be used with MAKE-HASH-TABLE to create a hash
209 table that can hold however many entries HASH-TABLE can hold without
210 having to be grown."
211 (hash-table-rehash-trigger hash-table))
212
213 (setf (documentation 'hash-table-test 'function)
214 "Return the test HASH-TABLE was created with.")
215
216
217 ;;;; Accessing functions.
218
219 ;;; REHASH -- internal.
220 ;;;
221 ;;; Make a new vector for TABLE. If GROW is NIL, use the same size as before,
222 ;;; otherwise extend the table based on the rehash-size.
223 ;;;
224 (defun rehash (table grow)
225 (declare (type hash-table table))
226 (let* ((old-vector (hash-table-table table))
227 (old-length (length old-vector))
228 (new-length
229 (if grow
230 (let ((rehash-size (hash-table-rehash-size table)))
231 (etypecase rehash-size
232 (fixnum
233 (+ rehash-size old-length))
234 (float
235 (ceiling (* rehash-size old-length)))))
236 old-length))
237 (new-vector (make-array new-length :initial-element nil)))
238 (dotimes (i old-length)
239 (do ((bucket (svref old-vector i) next)
240 (next nil))
241 ((null bucket))
242 (setf next (hash-table-bucket-next bucket))
243 (let* ((old-hashing (hash-table-bucket-hash bucket))
244 (hashing (cond
245 (old-hashing old-hashing)
246 (t
247 (set-header-data new-vector
248 vm:vector-valid-hashing-subtype)
249 (pointer-hash (hash-table-bucket-key bucket)))))
250 (index (rem hashing new-length)))
251 (setf (hash-table-bucket-next bucket) (svref new-vector index))
252 (setf (svref new-vector index) bucket)))
253 ;; We clobber the old vector contents so that if it is living in
254 ;; static space it won't keep ahold of pointers into dynamic space.
255 (setf (svref old-vector i) nil))
256 (setf (hash-table-table table) new-vector)
257 (unless (= new-length old-length)
258 (setf (hash-table-rehash-trigger table)
259 (let ((threshold (hash-table-rehash-threshold table)))
260 ;; Optimize the threshold=1 case so we don't have to use
261 ;; generic arithmetic in the most common case.
262 (if (eql threshold 1)
263 new-length
264 (truncate (* threshold new-length)))))))
265 (undefined-value))
266
267 ;;; GETHASH -- Public.
268 ;;;
269 (defun gethash (key hash-table &optional default)
270 "Finds the entry in HASH-TABLE whose key is KEY and returns the associated
271 value and T as multiple values, or returns DEFAULT and NIL if there is no
272 such entry. Entries can be added using SETF."
273 (declare (type hash-table hash-table)
274 (values t (member t nil)))
275 (without-gcing
276 (when (= (get-header-data (hash-table-table hash-table))
277 vm:vector-must-rehash-subtype)
278 (rehash hash-table nil))
279 (let* ((vector (hash-table-table hash-table))
280 (length (length vector))
281 (hashing (funcall (hash-table-hash-fun hash-table) key))
282 (index (rem hashing length))
283 (test-fun (hash-table-test-fun hash-table)))
284 (do ((bucket (svref vector index) (hash-table-bucket-next bucket)))
285 ((null bucket) (values default nil))
286 (let ((bucket-hashing (hash-table-bucket-hash bucket)))
287 (when (if bucket-hashing
288 (and (= bucket-hashing hashing)
289 (funcall test-fun key (hash-table-bucket-key bucket)))
290 (eq key (hash-table-bucket-key bucket)))
291 (return (values (hash-table-bucket-value bucket) t))))))))
292
293 ;;; %PUTHASH -- public setf method.
294 ;;;
295 (defun %puthash (key hash-table value)
296 (declare (type hash-table hash-table))
297 (without-gcing
298 (let ((entries (1+ (hash-table-number-entries hash-table))))
299 (setf (hash-table-number-entries hash-table) entries)
300 (cond ((> entries (hash-table-rehash-trigger hash-table))
301 (rehash hash-table t))
302 ((= (get-header-data (hash-table-table hash-table))
303 vm:vector-must-rehash-subtype)
304 (rehash hash-table nil))))
305 (multiple-value-bind
306 (hashing eq-based)
307 (funcall (hash-table-hash-fun hash-table) key)
308 (let* ((vector (hash-table-table hash-table))
309 (length (length vector))
310 (index (rem hashing length))
311 (first-bucket (svref vector index))
312 (test-fun (hash-table-test-fun hash-table)))
313 (do ((bucket first-bucket (hash-table-bucket-next bucket)))
314 ((null bucket)
315 (when eq-based
316 (set-header-data vector vm:vector-valid-hashing-subtype))
317 (setf (svref vector index)
318 (make-hash-table-bucket
319 :hash (unless eq-based hashing)
320 :key key
321 :value value
322 :next first-bucket)))
323 (let ((bucket-hashing (hash-table-bucket-hash bucket)))
324 (when (if bucket-hashing
325 (and (= bucket-hashing hashing)
326 (funcall test-fun
327 key (hash-table-bucket-key bucket)))
328 (eq key (hash-table-bucket-key bucket)))
329 (setf (hash-table-bucket-value bucket) value)
330 (decf (hash-table-number-entries hash-table))
331 (return)))))))
332 value)
333
334 ;;; REMHASH -- public.
335 ;;;
336 (defun remhash (key hash-table)
337 "Remove the entry in HASH-TABLE associated with KEY. Returns T if there
338 was such an entry, and NIL if not."
339 (declare (type hash-table hash-table)
340 (values (member t nil)))
341 (without-gcing
342 (when (= (get-header-data (hash-table-table hash-table))
343 vm:vector-must-rehash-subtype)
344 (rehash hash-table nil))
345 (let* ((vector (hash-table-table hash-table))
346 (length (length vector))
347 (hashing (funcall (hash-table-hash-fun hash-table) key))
348 (index (rem hashing length))
349 (test-fun (hash-table-test-fun hash-table)))
350 (do ((prev nil bucket)
351 (bucket (svref vector index) (hash-table-bucket-next bucket)))
352 ((null bucket) nil)
353 (let ((bucket-hashing (hash-table-bucket-hash bucket)))
354 (when (if bucket-hashing
355 (and (= bucket-hashing hashing)
356 (funcall test-fun key (hash-table-bucket-key bucket)))
357 (eq key (hash-table-bucket-key bucket)))
358 (if prev
359 (setf (hash-table-bucket-next prev)
360 (hash-table-bucket-next bucket))
361 (setf (svref vector index)
362 (hash-table-bucket-next bucket)))
363 (decf (hash-table-number-entries hash-table))
364 (return t)))))))
365
366 ;;; CLRHASH -- public.
367 ;;;
368 (defun clrhash (hash-table)
369 "This removes all the entries from HASH-TABLE and returns the hash table
370 itself."
371 (let ((vector (hash-table-table hash-table)))
372 (dotimes (i (length vector))
373 (setf (aref vector i) nil))
374 (setf (hash-table-number-entries hash-table) 0)
375 (set-header-data vector vm:vector-normal-subtype))
376 hash-table)
377
378
379
380 ;;;; MAPHASH and WITH-HASH-TABLE-ITERATOR
381
382 (declaim (maybe-inline maphash))
383 (defun maphash (map-function hash-table)
384 "For each entry in HASH-TABLE, calls MAP-FUNCTION on the key and value
385 of the entry; returns NIL."
386 (declare (type (or function symbol) map-function)
387 (type hash-table hash-table))
388 (let ((fun (etypecase map-function
389 (function
390 map-function)
391 (symbol
392 (symbol-function map-function))))
393 (vector (hash-table-table hash-table)))
394 (dotimes (i (length vector))
395 (do ((bucket (svref vector i) (hash-table-bucket-next bucket)))
396 ((null bucket))
397 (funcall fun
398 (hash-table-bucket-key bucket)
399 (hash-table-bucket-value bucket))))))
400
401
402 (defmacro with-hash-table-iterator ((function hash-table) &body body)
403 "WITH-HASH-TABLE-ITERATOR ((function hash-table) &body body)
404 provides a method of manually looping over the elements of a hash-table.
405 function is bound to a generator-macro that, withing the scope of the
406 invocation, returns three values. First, whether there are any more objects
407 in the hash-table, second, the key, and third, the value."
408 (let ((n-function (gensym "WITH-HASH-TABLE-ITERRATOR-")))
409 `(let ((,n-function
410 (let* ((table ,hash-table)
411 (vector (hash-table-table table))
412 (length (length vector))
413 (index 0)
414 (bucket (svref vector 0)))
415 (labels
416 ((,function ()
417 (cond
418 (bucket
419 (multiple-value-prog1
420 (values t
421 (hash-table-bucket-key bucket)
422 (hash-table-bucket-value bucket))
423 (setf bucket (hash-table-bucket-next bucket))))
424 ((= (incf index) length)
425 (values nil))
426 (t
427 (setf bucket (svref vector index))
428 (,function)))))
429 #',function))))
430 (macrolet ((,function () '(funcall ,n-function)))
431 ,@body))))
432
433
434
435 ;;;; SXHASH and support functions
436
437 ;;; The maximum length and depth to which we hash lists.
438 (defconstant sxhash-max-len 7)
439 (defconstant sxhash-max-depth 3)
440
441 (eval-when (compile eval)
442
443 (defconstant sxhash-bits-byte (byte 23 0))
444 (defconstant sxmash-total-bits 26)
445 (defconstant sxmash-rotate-bits 7)
446
447 (defmacro sxmash (place with)
448 (let ((n-with (gensym)))
449 `(let ((,n-with ,with))
450 (declare (fixnum ,n-with))
451 (setf ,place
452 (logxor (ash ,n-with ,(- sxmash-rotate-bits sxmash-total-bits))
453 (ash (logand ,n-with
454 ,(1- (ash 1
455 (- sxmash-total-bits
456 sxmash-rotate-bits))))
457 ,sxmash-rotate-bits)
458 (the fixnum ,place))))))
459
460 (defmacro sxhash-simple-string (sequence)
461 `(%sxhash-simple-string ,sequence))
462
463 (defmacro sxhash-string (sequence)
464 (let ((data (gensym))
465 (start (gensym))
466 (end (gensym)))
467 `(with-array-data ((,data ,sequence)
468 (,start)
469 (,end))
470 (if (zerop ,start)
471 (%sxhash-simple-substring ,data ,end)
472 (sxhash-simple-string (coerce (the string ,sequence)
473 'simple-string))))))
474
475 (defmacro sxhash-list (sequence depth)
476 `(if (= ,depth sxhash-max-depth)
477 0
478 (do ((sequence ,sequence (cdr (the list sequence)))
479 (index 0 (1+ index))
480 (hash 2))
481 ((or (atom sequence) (= index sxhash-max-len)) hash)
482 (declare (fixnum hash index))
483 (sxmash hash (internal-sxhash (car sequence) (1+ ,depth))))))
484
485
486 ); eval-when (compile eval)
487
488
489 (defun sxhash (s-expr)
490 "Computes a hash code for S-EXPR and returns it as an integer."
491 (internal-sxhash s-expr 0))
492
493
494 (defun internal-sxhash (s-expr depth)
495 (typecase s-expr
496 ;; The pointers and immediate types.
497 (list (sxhash-list s-expr depth))
498 (fixnum
499 (ldb sxhash-bits-byte s-expr))
500 (structure
501 (internal-sxhash (type-of s-expr) depth))
502 ;; Other-pointer types.
503 (simple-string (sxhash-simple-string s-expr))
504 (symbol (sxhash-simple-string (symbol-name s-expr)))
505 (number
506 (etypecase s-expr
507 (integer (ldb sxhash-bits-byte s-expr))
508 (single-float
509 (let ((bits (single-float-bits s-expr)))
510 (ldb sxhash-bits-byte
511 (logxor (ash bits (- sxmash-rotate-bits))
512 bits))))
513 (double-float
514 (let* ((val s-expr)
515 (lo (double-float-low-bits val))
516 (hi (double-float-high-bits val)))
517 (ldb sxhash-bits-byte
518 (logxor (ash lo (- sxmash-rotate-bits))
519 (ash hi (- sxmash-rotate-bits))
520 lo hi))))
521 (ratio (the fixnum (+ (internal-sxhash (numerator s-expr) 0)
522 (internal-sxhash (denominator s-expr) 0))))
523 (complex (the fixnum (+ (internal-sxhash (realpart s-expr) 0)
524 (internal-sxhash (imagpart s-expr) 0))))))
525 (array
526 (typecase s-expr
527 (string (sxhash-string s-expr))
528 (t (array-rank s-expr))))
529 ;; Everything else.
530 (t 42)))
531
532
533
534 ;;;; Dumping one as a constant.
535
536 (defun make-hash-table-load-form (table)
537 (values
538 `(make-hash-table
539 :test ',(hash-table-test table) :size ',(hash-table-size table)
540 :rehash-size ',(hash-table-rehash-size table)
541 :rehash-threshold ',(hash-table-rehash-threshold table))
542 (let ((values nil))
543 (declare (inline maphash))
544 (maphash #'(lambda (key value)
545 (push (cons key value) values))
546 table)
547 (if values
548 `(stuff-hash-table ,table ',values)
549 nil))))
550
551 (defun stuff-hash-table (table alist)
552 (dolist (x alist)
553 (setf (gethash (car x) table) (cdr x))))

  ViewVC Help
Powered by ViewVC 1.1.5