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

Contents of /src/code/hash.lisp

Parent Directory Parent Directory | Revision Log Revision Log


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

  ViewVC Help
Powered by ViewVC 1.1.5