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

Contents of /src/code/hash.lisp

Parent Directory Parent Directory | Revision Log Revision Log


Revision 1.1 - (show annotations)
Tue Feb 6 17:24:35 1990 UTC (24 years, 2 months ago) by ram
Branch: MAIN
Initial revision
1 ;;; -*- Log: code.log; Package: Lisp -*-
2 ;;;
3 ;;; **********************************************************************
4 ;;; This code was written as part of the Spice 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 Spice Lisp, please contact
7 ;;; Scott Fahlman (FAHLMAN@CMUC).
8 ;;; **********************************************************************
9 ;;;
10 ;;; Hashing and hash table functions for Spice Lisp.
11 ;;; Written by Skef Wholey.
12 ;;;
13 (in-package 'lisp)
14 (export '(hash-table hash-table-p make-hash-table
15 gethash remhash maphash clrhash
16 hash-table-count sxhash))
17
18 ;;; What a hash-table is:
19
20 (defstruct (hash-table (:constructor make-hash-table-structure)
21 (:conc-name hash-table-)
22 (:print-function %print-hash-table))
23 "Structure used to implement hash tables."
24 (kind 'eq)
25 (size 65 :type fixnum)
26 (rehash-size 101) ; might be a float
27 (rehash-threshold 57 :type fixnum)
28 (number-entries 0 :type fixnum)
29 (table () :type simple-vector))
30
31 ;;; A hash-table-table is a vector of association lists. When an
32 ;;; entry is made in a hash table, a pair of (key . value) is consed onto
33 ;;; the element in the vector arrived at by hashing.
34
35 ;;; How to print one:
36
37 (defun %print-hash-table (structure stream depth)
38 (declare (ignore depth))
39 (format stream "#<~A Hash Table {~X}>"
40 (symbol-name (hash-table-kind structure))
41 (system:%primitive lisp::make-fixnum structure)))
42
43
44
45 ;;; Hashing functions for the three kinds of hash tables:
46
47 (eval-when (compile)
48
49 (defmacro eq-hash (object)
50 "Gives us a hashing of an object such that (eq a b) implies
51 (= (eq-hash a) (eq-hash b))"
52 `(%primitive make-fixnum ,object))
53
54 (defmacro eql-hash (object)
55 "Gives us a hashing of an object such that (eql a b) implies
56 (= (eql-hash a) (eql-hash b))"
57 `(if (numberp ,object)
58 (logand (truncate ,object) most-positive-fixnum)
59 (%primitive make-fixnum ,object)))
60
61 (defmacro equal-hash (object)
62 "Gives us a hashing of an object such that (equal a b) implies
63 (= (equal-hash a) (equal-hash b))"
64 `(sxhash ,object))
65
66 )
67
68 ;;; Rehashing functions:
69
70 (defun almost-primify (num)
71 (declare (fixnum num))
72 "Almost-Primify returns an almost prime number greater than or equal
73 to NUM."
74 (if (= (rem num 2) 0)
75 (setq num (+ 1 num)))
76 (if (= (rem num 3) 0)
77 (setq num (+ 2 num)))
78 (if (= (rem num 7) 0)
79 (setq num (+ 4 num)))
80 num)
81
82 (eval-when (compile)
83
84 (defmacro grow-size (table)
85 "Returns a fixnum for the next size of a growing hash-table."
86 `(let ((rehash-size (hash-table-rehash-size ,table)))
87 (if (floatp rehash-size)
88 (ceiling (* rehash-size (hash-table-size ,table)))
89 (+ rehash-size (hash-table-size ,table)))))
90
91 (defmacro grow-rehash-threshold (table new-length)
92 "Returns the next rehash threshold for the table."
93 table
94 `,new-length
95 ; `(ceiling (* (hash-table-rehash-threshold ,table)
96 ; (/ ,new-length (hash-table-size ,table))))
97 )
98
99 (defmacro hash-set (vector key value length hashing-function)
100 "Used for rehashing. Enters the value for the key into the vector
101 by hashing. Never grows the vector. Assumes the key is not yet
102 entered."
103 `(let ((index (rem (the fixnum (funcall ,hashing-function ,key))
104 (the fixnum ,length))))
105 (declare (fixnum index))
106 (setf (aref (the simple-vector ,vector) index)
107 (cons (cons ,key ,value)
108 (aref (the simple-vector ,vector) index)))))
109
110 )
111
112 (defun rehash (structure hash-vector new-length)
113 (declare (simple-vector hash-vector))
114 (declare (fixnum new-length))
115 "Rehashes a hash table and replaces the TABLE entry in the structure if
116 someone hasn't done so already. New vector is of NEW-LENGTH."
117 (do ((new-vector (make-array new-length))
118 (i 0 (1+ i))
119 (size (hash-table-size structure))
120 (hashing-function (case (hash-table-kind structure)
121 (eq #'(lambda (x) (eq-hash x)))
122 (eql #'(lambda (x) (eql-hash x)))
123 (equal #'(lambda (x) (equal-hash x))))))
124 ((= i size)
125 (cond ((eq hash-vector (hash-table-table structure))
126 (cond ((> new-length size)
127 (setf (hash-table-table structure) new-vector)
128 (setf (hash-table-rehash-threshold structure)
129 (grow-rehash-threshold structure new-length))
130 (setf (hash-table-size structure) new-length))
131 (t
132 (setf (hash-table-table structure) new-vector)))
133 (if (not (eq (hash-table-kind structure) 'equal))
134 (%primitive set-vector-subtype new-vector
135 (+ 2 (%primitive newspace-bit)))))))
136 (declare (fixnum i size))
137 (do ((bucket (aref hash-vector i) (cdr bucket)))
138 ((null bucket))
139 (hash-set new-vector (caar bucket) (cdar bucket) new-length
140 hashing-function))
141 (setf (aref hash-vector i) nil)))
142
143 ;;; Macros for Gethash, %Puthash, and Remhash:
144
145 (eval-when (compile)
146
147 ;;; Hashop dispatches on the kind of hash table we've got, rehashes if
148 ;;; necessary, and binds Vector to the hash vector, Index to the index
149 ;;; into that vector that the Key points to, and Size to the size of the
150 ;;; hash vector. Since Equal hash tables only need to be maybe rehashed
151 ;;; sometimes, one can tell it if it's one of those times with the
152 ;;; Equal-Needs-To-Rehash-P argument.
153
154 (defmacro hashop (equal-needs-to-rehash-p eq-body eql-body equal-body)
155 `(let* ((vector (hash-table-table hash-table))
156 (size (length vector)))
157 (declare (simple-vector vector) (fixnum size)
158 (inline assoc))
159 (case (hash-table-kind hash-table)
160 (equal
161 ,@(if equal-needs-to-rehash-p `((equal-rehash-if-needed)))
162 (let ((index (rem (the fixnum (equal-hash key)) size)))
163 (declare (fixnum index))
164 ,equal-body))
165 (eq
166 (without-gcing
167 (eq-rehash-if-needed)
168 (let ((index (rem (the fixnum (eq-hash key)) size)))
169 (declare (fixnum index))
170 ,eq-body)))
171 (eql
172 (without-gcing
173 (eq-rehash-if-needed)
174 (let ((index (rem (the fixnum (eql-hash key)) size)))
175 (declare (fixnum index))
176 ,eql-body))))))
177
178 (defmacro eq-rehash-if-needed ()
179 `(let ((subtype (%primitive get-vector-subtype vector)))
180 (declare (fixnum subtype))
181 (cond ((or (= subtype 4)
182 (/= subtype (+ 2 (%primitive newspace-bit))))
183 (rehash hash-table vector size)
184 (setq vector (hash-table-table hash-table)))
185 ((> (hash-table-number-entries hash-table)
186 (hash-table-rehash-threshold hash-table))
187 (rehash hash-table vector (grow-size hash-table))
188 (setq vector (hash-table-table hash-table))
189 (setq size (length vector))))))
190
191 (defmacro equal-rehash-if-needed ()
192 `(cond ((> (hash-table-number-entries hash-table)
193 (hash-table-rehash-threshold hash-table))
194 (rehash hash-table vector (grow-size hash-table))
195 (setq vector (hash-table-table hash-table))
196 (setq size (length vector)))))
197
198 (defmacro rehash-if-needed ()
199 `(let ((subtype (%primitive get-vector-subtype vector))
200 (size (length vector)))
201 (declare (fixnum subtype size))
202 (cond ((and (not (eq (hash-table-kind hash-table) 'equal))
203 (or (= subtype 4)
204 (/= subtype (the fixnum (+ 2 (the fixnum (%primitive newspace-bit)))))))
205 (rehash hash-table vector size)
206 (setq vector (hash-table-table hash-table))
207 (setq size (length vector)))
208 ((> (hash-table-number-entries hash-table)
209 (hash-table-rehash-threshold hash-table))
210 (rehash hash-table vector (grow-size hash-table))
211 (setq vector (hash-table-table hash-table))
212 (setq size (length vector))))))
213
214 )
215
216 ;;; Making hash tables:
217
218 (defun make-hash-table (&key (test 'eql) (size 65) (rehash-size 101)
219 rehash-threshold)
220 "Creates and returns a hash table. See manual for details."
221 (declare (fixnum size))
222 (cond ((eq test #'eq) (setq test 'eq))
223 ((eq test #'eql) (setq test 'eql))
224 ((eq test #'equal) (setq test 'equal)))
225 (if (not (memq test '(eq eql equal)))
226 (error "~S is an illegal :Test for hash tables." test))
227 (setq size (if (<= size 37) 37 (almost-primify size)))
228 (cond ((null rehash-threshold)
229 (setq rehash-threshold size))
230 ((floatp rehash-threshold)
231 (setq rehash-threshold (ceiling (* rehash-threshold size)))))
232 (make-hash-table-structure :size size
233 :rehash-size rehash-size
234 :rehash-threshold rehash-threshold
235 :table
236 (if (eq test 'equal)
237 (make-array size)
238 (%primitive set-vector-subtype
239 (make-array size)
240 (the fixnum (+ 2 (the fixnum (%primitive newspace-bit))))))
241 :kind test)))
242
243 ;;; Manipulating hash tables:
244
245 (defun gethash (key hash-table &optional default)
246 "Finds the entry in Hash-Table whose key is Key and returns the associated
247 value and T as multiple values, or returns Default and Nil if there is no
248 such entry."
249 (macrolet ((lookup (test)
250 `(let ((cons (assoc key (aref vector index) :test #',test)))
251 (declare (list cons))
252 (if cons
253 (values (cdr cons) t)
254 (values default nil)))))
255 (hashop nil
256 (lookup eq)
257 (lookup eql)
258 (lookup equal))))
259
260 (defun %puthash (key hash-table value)
261 "Create an entry in HASH-TABLE associating KEY with VALUE; if there already
262 is an entry for KEY, replace it. Returns VALUE."
263 (macrolet ((store (test)
264 `(let ((cons (assoc key (aref vector index) :test #',test)))
265 (declare (list cons))
266 (cond (cons (setf (cdr cons) value))
267 (t
268 (push (cons key value) (aref vector index))
269 (incf (hash-table-number-entries hash-table))
270 value)))))
271 (hashop t
272 (store eq)
273 (store eql)
274 (store equal))))
275
276 (defun remhash (key hash-table)
277 "Remove any entry for KEY in HASH-TABLE. Returns T if such an entry
278 existed; () otherwise."
279 (hashop nil
280 (let ((bucket (aref vector index))) ; EQ case
281 (cond ((and bucket (eq (caar bucket) key))
282 (pop (aref vector index))
283 (decf (hash-table-number-entries hash-table))
284 t)
285 (t
286 (do ((last bucket bucket)
287 (bucket (cdr bucket) (cdr bucket)))
288 ((null bucket) ())
289 (when (eq (caar bucket) key)
290 (rplacd last (cdr bucket))
291 (decf (hash-table-number-entries hash-table))
292 (return t))))))
293 (let ((bucket (aref vector index))) ; EQL case
294 (cond ((and bucket (eql (caar bucket) key))
295 (pop (aref vector index))
296 (decf (hash-table-number-entries hash-table))
297 t)
298 (t
299 (do ((last bucket bucket)
300 (bucket (cdr bucket) (cdr bucket)))
301 ((null bucket) ())
302 (when (eql (caar bucket) key)
303 (rplacd last (cdr bucket))
304 (decf (hash-table-number-entries hash-table))
305 (return t))))))
306 (let ((bucket (aref vector index))) ; EQUAL case
307 (cond ((and bucket (equal (caar bucket) key))
308 (pop (aref vector index))
309 (decf (hash-table-number-entries hash-table))
310 t)
311 (t
312 (do ((last bucket bucket)
313 (bucket (cdr bucket) (cdr bucket)))
314 ((null bucket) ())
315 (when (equal (caar bucket) key)
316 (rplacd last (cdr bucket))
317 (decf (hash-table-number-entries hash-table))
318 (return t))))))))
319
320 (defun maphash (map-function hash-table)
321 "For each entry in HASH-TABLE, calls MAP-FUNCTION on the key and value
322 of the entry; returns T."
323 (let ((vector (hash-table-table hash-table)))
324 (declare (simple-vector vector))
325 (rehash-if-needed)
326 (do ((i 0 (1+ i))
327 (size (hash-table-size hash-table)))
328 ((= i size))
329 (declare (fixnum i size))
330 (do ((bucket (aref vector i) (cdr bucket)))
331 ((null bucket))
332
333 (funcall map-function (caar bucket) (cdar bucket))))))
334
335 (defun clrhash (hash-table)
336 "Removes all entries of HASH-TABLE and returns the hash table itself."
337 (let ((vector (hash-table-table hash-table)))
338 (declare (simple-vector vector))
339 (setf (hash-table-number-entries hash-table) 0)
340 (do ((i 0 (1+ i))
341 (size (hash-table-size hash-table)))
342 ((= i size) hash-table)
343 (declare (fixnum i size))
344 (setf (aref vector i) nil))))
345
346 (defun hash-table-count (hash-table)
347 "Returns the number of entries in the given Hash-Table."
348 (hash-table-number-entries hash-table))
349
350 ;;; Primitive Hash Function
351
352 ;;; The maximum length and depth to which we hash lists.
353 (defconstant sxhash-max-len 7)
354 (defconstant sxhash-max-depth 3)
355
356 (eval-when (compile eval)
357
358 ;;; We could use a rotate function here, but that isn't in ucode, so
359 ;;; instead we Xor the number with a lsh'ed version of itself...
360 ;;;
361 (defmacro sxmash (x num)
362 (let ((n-x (gensym)))
363 `(let ((,n-x ,x))
364 (declare (fixnum ,n-x))
365 (abs (logxor (the fixnum (%primitive lsh ,n-x ,num)) ,n-x)))))
366
367 (defmacro sxhash-simple-string (sequence)
368 `(%primitive sxhash-simple-string ,sequence))
369
370 (defmacro sxhash-string (sequence)
371 (let ((data (gensym))
372 (start (gensym))
373 (end (gensym)))
374 `(with-array-data ((,data ,sequence)
375 (,start)
376 (,end (%primitive header-ref ,sequence
377 %array-fill-pointer-slot)))
378 (if (zerop ,start)
379 (%primitive sxhash-simple-substring ,data ,end)
380 (sxhash-simple-string (coerce (the string ,sequence)
381 'simple-string))))))
382
383 (defmacro sxhash-list (sequence depth)
384 `(if (= ,depth sxhash-max-depth)
385 0
386 (do ((sequence ,sequence (cdr (the list sequence)))
387 (index 0 (1+ index))
388 (hash 2))
389 ((or (atom sequence) (= index sxhash-max-len)) hash)
390 (declare (fixnum hash index))
391 (setq hash
392 (sxmash
393 (logxor
394 hash
395 (internal-sxhash (car sequence) (1+ ,depth)))
396 7)))))
397
398 ); eval-when (compile eval)
399
400
401 ;;; This multi-level type dispatch is faster, since typecase doesn't
402 ;;; turn into a real dispatch.
403 ;;;
404 (defun sxhash (s-expr)
405 "Computes a hash code for S-EXPR and returns it as an integer."
406 (internal-sxhash s-expr 0))
407
408 (defun internal-sxhash (s-expr depth)
409 (typecase s-expr
410 (array
411 (typecase s-expr
412 (simple-string (sxhash-simple-string s-expr))
413 (string (sxhash-string s-expr))
414 (t (array-rank s-expr))))
415 (symbol (sxhash-simple-string (symbol-name s-expr)))
416 (list (sxhash-list s-expr depth))
417 (number
418 (etypecase s-expr
419 (integer (ldb (byte 23 0) s-expr))
420 (float (multiple-value-bind (significand exponent)
421 (integer-decode-float s-expr)
422 (logxor (the fixnum (ldb (byte 23 0) significand))
423 (the fixnum (ldb (byte 23 0) exponent)))))
424 (ratio (the fixnum (+ (internal-sxhash (numerator s-expr) 0)
425 (internal-sxhash (denominator s-expr) 0))))
426 (complex (the fixnum (+ (internal-sxhash (realpart s-expr) 0)
427 (internal-sxhash (imagpart s-expr) 0))))))
428 (compiled-function (%primitive header-length s-expr))
429 (t (%primitive make-fixnum s-expr))))

  ViewVC Help
Powered by ViewVC 1.1.5