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

Contents of /src/code/hash.lisp

Parent Directory Parent Directory | Revision Log Revision Log


Revision 1.11.1.1 - (show annotations) (vendor branch)
Tue Mar 3 08:20:40 1992 UTC (22 years, 1 month ago) by wlott
Branch: gengc
Changes since 1.11: +261 -285 lines
Merged trunk changes
1 ;;; -*- Log: code.log; Package: Lisp -*-
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.11.1.1 1992/03/03 08:20:40 wlott Exp $")
11 ;;;
12 ;;; **********************************************************************
13 ;;;
14 ;;; Hashing and hash table functions for Spice Lisp.
15 ;;; Written by Skef Wholey.
16 ;;;
17 (in-package 'lisp)
18 (export '(hash-table hash-table-p make-hash-table
19 gethash remhash maphash clrhash
20 hash-table-count sxhash
21 with-hash-table-iterator))
22
23 ;;; Hash-values are all positive fixnums:
24 (deftype hash-value ()
25 '(and fixnum (unsigned-byte)))
26
27 (defstruct (hash-table (:constructor make-hash-table-structure)
28 (:conc-name hash-table-)
29 (:print-function %print-hash-table)
30 (:make-load-form-fun make-hash-table-load-form))
31 "Structure used to implement hash tables."
32 (kind 'eq :type (member eq eql equal))
33 (rehash-size 101 :type real) ; might be a float
34 (rehash-threshold 57 :type fixnum)
35 (number-entries 0 :type fixnum)
36 (table (required-argument) :type simple-vector)
37 (needing-rehash nil :type list))
38 ;;;
39 (defun %print-hash-table (structure stream depth)
40 (declare (ignore depth))
41 (format stream "#<~A Hash Table {~X}>"
42 (symbol-name (hash-table-kind structure))
43 (system:%primitive make-fixnum structure)))
44
45
46 (defstruct (hash-table-bucket
47 (:print-function %print-hash-table-bucket)
48 (:constructor %make-bucket (key hash value next)))
49 (key nil :type t)
50 (hash 0 :type hash-value)
51 (value nil :type t)
52 (next nil :type (or null hash-table-bucket))
53 (scavhook nil :type (or null scavenger-hook)))
54 ;;;
55 (defun %print-hash-table-bucket (bucket stream depth)
56 (declare (ignore depth))
57 (format stream "#<hash-table-bucket ~S->~S>"
58 (hash-table-bucket-key bucket)
59 (hash-table-bucket-value bucket)))
60
61 (defun make-hash-table-bucket (table key hash value next scav-hook-p)
62 (declare (type hash-table table) (type hash-value hash)
63 (type (or null hash-table-bucket) next))
64 (let ((bucket (%make-bucket key hash value next)))
65 (when scav-hook-p
66 (setf (hash-table-bucket-scavhook bucket)
67 (make-scavenger-hook
68 :value key
69 :function #'(lambda ()
70 (push bucket (hash-table-needing-rehash table))
71 (setf (scavenger-hook-value
72 (hash-table-bucket-scavhook bucket))
73 nil)))))
74 bucket))
75
76
77
78 ;;; Hashing functions for the three kinds of hash tables:
79
80 (eval-when (compile eval)
81
82 (defmacro eq-hash (object)
83 "Gives us a hashing of an object such that (eq a b) implies
84 (= (eq-hash a) (eq-hash b))"
85 `(values (truly-the hash-value (%primitive make-fixnum ,object))
86 t))
87
88 (defmacro eql-hash (object)
89 "Gives us a hashing of an object such that (eql a b) implies
90 (= (eql-hash a) (eql-hash b))"
91 `(if (numberp ,object)
92 (values (%eql-hash object) nil)
93 (eq-hash object)))
94
95 (defmacro equal-hash (object)
96 "Gives us a hashing of an object such that (equal a b) implies
97 (= (equal-hash a) (equal-hash b))"
98 `(values (sxhash ,object) nil))
99
100 )
101
102 (defun %eql-hash (number)
103 (etypecase number
104 (fixnum
105 (logand number most-positive-fixnum))
106 (integer
107 (logand number most-positive-fixnum))
108 (float
109 (%eql-hash (integer-decode-float number)))
110 (ratio
111 (logxor (%eql-hash (numerator number))
112 (%eql-hash (denominator number))))
113 (complex
114 (logxor (%eql-hash (realpart number))
115 (%eql-hash (imagpart number))))))
116
117
118 (defun hash (table object)
119 (ecase (hash-table-kind table)
120 (eq (eq-hash object))
121 (eql (eql-hash object))
122 (equal (equal-hash object))))
123
124
125 ;;; Rehashing functions:
126
127 (defun almost-primify (num)
128 (declare (fixnum num))
129 "Almost-Primify returns an almost prime number greater than or equal
130 to NUM."
131 (when (zerop (rem num 2))
132 (incf num))
133 (when (zerop (rem num 3))
134 (incf num 2))
135 (when (zerop (rem num 7))
136 (incf num 4))
137 num)
138
139 (defun rehash (table)
140 "Rehashes all the entries in the hash table TABLE. Must only be called
141 inside a WITHOUT-GCING."
142 (let* ((old-vector (hash-table-table table))
143 (old-length (length old-vector))
144 (rehash-size (hash-table-rehash-size table))
145 (new-length (if (floatp rehash-size)
146 (ceiling (* rehash-size old-length))
147 (+ rehash-size old-length)))
148 (new-vector (make-array new-length :initial-element nil)))
149 (declare (type simple-vector old-vector new-vector)
150 (type index old-length new-length))
151 (flet ((reenter-bucket (bucket)
152 (let ((key (hash-table-bucket-key bucket)))
153 (multiple-value-bind
154 (hashing needs-scav-hook)
155 (hash table key)
156 (let ((index (rem hashing new-length))
157 (value (hash-table-bucket-value bucket)))
158 (setf (svref new-vector index)
159 (make-hash-table-bucket table key hashing value
160 (svref new-vector index)
161 needs-scav-hook)))))))
162 (dotimes (i old-length)
163 (do ((bucket (aref old-vector i) (hash-table-bucket-next bucket)))
164 ((null bucket))
165 (reenter-bucket bucket))
166 (setf (aref old-vector i) nil))
167 (dolist (bucket (hash-table-needing-rehash table))
168 (reenter-bucket bucket)))
169 (setf (hash-table-table table) new-vector)
170 (setf (hash-table-needing-rehash table) nil)
171 (when (> new-length old-length)
172 (setf (hash-table-rehash-threshold table) new-length))))
173
174 (defun find-bucket (hash-table bucket-list key hashing)
175 (declare (type hash-table hash-table)
176 (type (or hash-table-bucket null) bucket-list)
177 (type hash-value hashing))
178 (flet ((frob (test)
179 (do ((prev nil bucket)
180 (bucket bucket-list (hash-table-bucket-next bucket)))
181 ((or (null bucket)
182 (and (= hashing (hash-table-bucket-hash bucket))
183 (funcall test (hash-table-bucket-key bucket) key)))
184 (values bucket prev)))))
185 (declare (inline frob))
186 (ecase (hash-table-kind hash-table)
187 (equal (frob #'equal))
188 (eql (frob #'eql))
189 (eq (frob #'eq)))))
190
191 (defun flush-needing-rehash (table)
192 (declare (type hash-table table))
193 (let* ((vector (hash-table-table table))
194 (length (length vector)))
195 (declare (type simple-vector vector)
196 (type index length))
197 (dolist (bucket (hash-table-needing-rehash table))
198 (declare (type (or null hash-table-bucket) bucket))
199 (let ((index (rem (hash-table-bucket-hash bucket) length)))
200 (declare (type index index))
201 (do ((prev nil ptr)
202 (ptr (svref vector index) (hash-table-bucket-next ptr)))
203 ((or (null bucket) (eq bucket ptr))
204 (unless bucket
205 (error "Can't find the bucket in the hash table. ~
206 Something is broken bigtime."))
207 (if prev
208 (setf (hash-table-bucket-next prev)
209 (hash-table-bucket-next bucket))
210 (setf (svref vector index)
211 (hash-table-bucket-next bucket))))
212 (declare (type (or null hash-table-bucket) prev ptr))))
213 (let* ((key (hash-table-bucket-key bucket))
214 (hashing (hash table key))
215 (index (rem hashing length)))
216 (declare (type hash-value hashing) (type index index))
217 (setf (hash-table-bucket-next bucket) (svref vector index))
218 (setf (svref vector index) bucket)
219 (setf (scavenger-hook-value (hash-table-bucket-scavhook bucket)) key)
220 (setf (hash-table-bucket-hash bucket) hashing))))
221 (setf (hash-table-needing-rehash table) nil))
222
223
224
225 ;;; Making hash tables:
226
227 (defun make-hash-table (&key (test 'eql) (size 65) (rehash-size 101)
228 (rehash-threshold size))
229 "Creates and returns a hash table. See manual for details."
230 (declare (fixnum size))
231 (let* ((test (cond ((eq test #'eq) 'eq)
232 ((eq test #'eql) 'eql)
233 ((eq test #'equal) 'equal)
234 ((member test '(eq eql equal) :test #'eq)
235 test)
236 (t
237 (error "~S is an illegal :Test for hash tables." test))))
238 (size (if (<= size 37)
239 37
240 (almost-primify size)))
241 (rehash-threshold (cond ((null rehash-threshold)
242 size)
243 ((floatp rehash-threshold)
244 (ceiling (* rehash-threshold size)))
245 (t
246 rehash-threshold))))
247 (make-hash-table-structure :rehash-size rehash-size
248 :rehash-threshold rehash-threshold
249 :table (make-array size :initial-element nil)
250 :kind test)))
251
252
253
254 ;;; Manipulating hash tables:
255
256 (defun gethash (key hash-table &optional default)
257 "Finds the entry in Hash-Table whose key is Key and returns the associated
258 value and T as multiple values, or returns Default and Nil if there is no
259 such entry."
260 (without-gcing
261 (when (hash-table-needing-rehash hash-table)
262 (flush-needing-rehash hash-table))
263 (let* ((vector (hash-table-table hash-table))
264 (size (length vector))
265 (hashing (hash hash-table key))
266 (index (rem hashing size))
267 (bucket (find-bucket hash-table (svref vector index) key hashing)))
268 (if bucket
269 (values (hash-table-bucket-value bucket) t)
270 (values default nil)))))
271
272
273 (defun %puthash (key hash-table value)
274 "Create an entry in HASH-TABLE associating KEY with VALUE; if there already
275 is an entry for KEY, replace it. Returns VALUE."
276 (without-gcing
277 (cond ((> (hash-table-number-entries hash-table)
278 (hash-table-rehash-threshold hash-table))
279 (rehash hash-table))
280 ((hash-table-needing-rehash hash-table)
281 (flush-needing-rehash hash-table)))
282 (let* ((vector (hash-table-table hash-table))
283 (size (length vector)))
284 (multiple-value-bind (hashing scav-hook-p) (hash hash-table key)
285 (let* ((index (rem hashing size))
286 (bucket (find-bucket hash-table (svref vector index)
287 key hashing)))
288 (if bucket
289 (setf (hash-table-bucket-value bucket) value)
290 (setf (svref vector index)
291 (make-hash-table-bucket hash-table key hashing value
292 (svref vector index)
293 scav-hook-p)))))))
294 value)
295
296 (defun remhash (key hash-table)
297 "Remove any entry for KEY in HASH-TABLE. Returns T if such an entry
298 existed, and NIL if not."
299 (without-gcing
300 (when (hash-table-needing-rehash hash-table)
301 (flush-needing-rehash hash-table))
302 (let* ((vector (hash-table-table hash-table))
303 (size (length vector))
304 (hashing (hash hash-table key))
305 (index (rem hashing size)))
306 (multiple-value-bind
307 (bucket prev)
308 (find-bucket hash-table (svref vector index) key hashing)
309 (when bucket
310 (if prev
311 (setf (hash-table-bucket-next prev)
312 (hash-table-bucket-next bucket))
313 (setf (svref vector index)
314 (hash-table-bucket-next bucket)))
315 (decf (hash-table-number-entries hash-table))
316 t)))))
317
318
319 (defun maphash (map-function hash-table)
320 "For each entry in HASH-TABLE, calls MAP-FUNCTION on the key and value
321 of the entry; returns T."
322 (let ((vector (hash-table-table hash-table)))
323 (declare (simple-vector vector))
324 (dotimes (index (length vector))
325 (do ((bucket (aref vector index) (hash-table-bucket-next bucket)))
326 ((null bucket))
327 (funcall map-function
328 (hash-table-bucket-key bucket)
329 (hash-table-bucket-value bucket))))))
330
331 (defun clrhash (hash-table)
332 "Removes all entries of HASH-TABLE and returns the hash table itself."
333 (declare (type hash-table hash-table))
334 (let ((vector (hash-table-table hash-table)))
335 (declare (simple-vector vector))
336 (setf (hash-table-number-entries hash-table) 0)
337 (dotimes (i (length vector))
338 (setf (svref vector i) nil))
339 (setf (hash-table-needing-rehash hash-table) nil))
340 hash-table)
341
342 (defun hash-table-count (hash-table)
343 "Returns the number of entries in the given Hash-Table."
344 (hash-table-number-entries hash-table))
345
346
347
348 ;;; Primitive Hash Function
349
350 ;;; The maximum length and depth to which we hash lists.
351 (defconstant sxhash-max-len 7)
352 (defconstant sxhash-max-depth 3)
353
354 (eval-when (compile eval)
355
356 (defconstant sxhash-bits-byte (byte 23 0))
357 (defconstant sxmash-total-bits 26)
358 (defconstant sxmash-rotate-bits 7)
359
360 (defmacro sxmash (place with)
361 (let ((n-with (gensym)))
362 `(let ((,n-with ,with))
363 (declare (fixnum ,n-with))
364 (setf ,place
365 (logxor (ash ,n-with ,(- sxmash-rotate-bits sxmash-total-bits))
366 (ash (logand ,n-with
367 ,(1- (ash 1
368 (- sxmash-total-bits
369 sxmash-rotate-bits))))
370 ,sxmash-rotate-bits)
371 (the fixnum ,place))))))
372
373 (defmacro sxhash-simple-string (sequence)
374 `(%sxhash-simple-string ,sequence))
375
376 (defmacro sxhash-string (sequence)
377 (let ((data (gensym))
378 (start (gensym))
379 (end (gensym)))
380 `(with-array-data ((,data ,sequence)
381 (,start)
382 (,end))
383 (if (zerop ,start)
384 (%sxhash-simple-substring ,data ,end)
385 (sxhash-simple-string (coerce (the string ,sequence)
386 'simple-string))))))
387
388 (defmacro sxhash-list (sequence depth)
389 `(if (= ,depth sxhash-max-depth)
390 0
391 (do ((sequence ,sequence (cdr (the list sequence)))
392 (index 0 (1+ index))
393 (hash 2))
394 ((or (atom sequence) (= index sxhash-max-len)) hash)
395 (declare (fixnum hash index))
396 (sxmash hash (internal-sxhash (car sequence) (1+ ,depth))))))
397
398
399 ); eval-when (compile eval)
400
401
402 (defun sxhash (s-expr)
403 "Computes a hash code for S-EXPR and returns it as an integer."
404 (internal-sxhash s-expr 0))
405
406
407 (defun internal-sxhash (s-expr depth)
408 (typecase s-expr
409 ;; The pointers and immediate types.
410 (list (sxhash-list s-expr depth))
411 (fixnum
412 (ldb sxhash-bits-byte s-expr))
413 (structure
414 (internal-sxhash (type-of s-expr) depth))
415 ;; Other-pointer types.
416 (simple-string (sxhash-simple-string s-expr))
417 (symbol (sxhash-simple-string (symbol-name s-expr)))
418 (number
419 (etypecase s-expr
420 (integer (ldb sxhash-bits-byte s-expr))
421 (single-float
422 (let ((bits (single-float-bits s-expr)))
423 (ldb sxhash-bits-byte
424 (logxor (ash bits (- sxmash-rotate-bits))
425 bits))))
426 (double-float
427 (let* ((val s-expr)
428 (lo (double-float-low-bits val))
429 (hi (double-float-high-bits val)))
430 (ldb sxhash-bits-byte
431 (logxor (ash lo (- sxmash-rotate-bits))
432 (ash hi (- sxmash-rotate-bits))
433 lo hi))))
434 (ratio (the fixnum (+ (internal-sxhash (numerator s-expr) 0)
435 (internal-sxhash (denominator s-expr) 0))))
436 (complex (the fixnum (+ (internal-sxhash (realpart s-expr) 0)
437 (internal-sxhash (imagpart s-expr) 0))))))
438 (array
439 (typecase s-expr
440 (string (sxhash-string s-expr))
441 (t (array-rank s-expr))))
442 ;; Everything else.
443 (t 42)))
444
445
446
447 ;;;; WITH-HASH-TABLE-ITERATOR
448
449 (defmacro with-hash-table-iterator ((function hash-table) &body body)
450 "WITH-HASH-TABLE-ITERATOR ((function hash-table) &body body)
451 provides a method of manually looping over the elements of a hash-table.
452 function is bound to a generator-macro that, withing the scope of the
453 invocation, returns three values. First, whether there are any more objects
454 in the hash-table, second, the key, and third, the value."
455 (let ((counter (gensym))
456 (bucket (gensym))
457 (table (gensym))
458 (size (gensym)))
459 `(let* ((,table (hash-table-table ,hash-table))
460 (,size (length ,table))
461 (,counter 0)
462 (,bucket (svref ,table 0)))
463 (declare (type index ,counter ,size)
464 (type simple-vector ,table)
465 (type (or null hash-table-bucket) ,bucket))
466 (macrolet ((,function ()
467 `(loop
468 (when (= ,',counter ,',size)
469 (return))
470 (if ,',bucket
471 (return
472 (multiple-value-prog1
473 (values t
474 (hash-table-bucket-key ,',bucket)
475 (hash-table-bucket-value ,',bucket))
476 (setf ,',bucket
477 (hash-table-bucket-next ,',bucket))))
478 (setf ,',bucket
479 (svref ,table (incf ,',counter)))))))
480 ,@body))))
481
482
483
484 ;;;; Dumping one as a constant.
485
486 (defun make-hash-table-load-form (table)
487 (values
488 `(make-hash-table
489 :test ',(hash-table-kind table) :size ',(hash-table-size table)
490 :hash-table-rehash-size ',(hash-table-rehash-size table)
491 :hash-table-rehash-threshold ',(hash-table-rehash-threshold table))
492 (let ((sets nil))
493 (with-hash-table-iterator (next table)
494 (loop
495 (multiple-value-bind (more key value) (next)
496 (if more
497 (setf sets (list* `(gethash ',key ,table) `',value sets))
498 (return)))))
499 (if sets
500 `(setf ,@sets)
501 nil))))

  ViewVC Help
Powered by ViewVC 1.1.5