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

Contents of /src/code/hash.lisp

Parent Directory Parent Directory | Revision Log Revision Log


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

  ViewVC Help
Powered by ViewVC 1.1.5