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

Contents of /src/code/hash.lisp

Parent Directory Parent Directory | Revision Log Revision Log


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

  ViewVC Help
Powered by ViewVC 1.1.5