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

Contents of /src/code/hash.lisp

Parent Directory Parent Directory | Revision Log Revision Log


Revision 1.8 - (hide annotations)
Tue Dec 4 12:30:43 1990 UTC (23 years, 4 months ago) by wlott
Branch: MAIN
Changes since 1.7: +37 -3 lines
Added Blaine's with-hash-table-iterator.
1 ram 1.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 wlott 1.8 hash-table-count sxhash
17     with-hash-table-iterator))
18 ram 1.1
19 wlott 1.2 ;;; Vector subtype codes.
20    
21     (defconstant valid-hashing 2)
22     (defconstant must-rehash 3)
23    
24    
25 ram 1.1 ;;; What a hash-table is:
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)
32     (size 65 :type fixnum)
33     (rehash-size 101) ; might be a float
34     (rehash-threshold 57 :type fixnum)
35     (number-entries 0 :type fixnum)
36     (table () :type simple-vector))
37    
38     ;;; A hash-table-table is a vector of association lists. When an
39     ;;; entry is made in a hash table, a pair of (key . value) is consed onto
40     ;;; the element in the vector arrived at by hashing.
41    
42     ;;; How to print one:
43    
44     (defun %print-hash-table (structure stream depth)
45     (declare (ignore depth))
46     (format stream "#<~A Hash Table {~X}>"
47     (symbol-name (hash-table-kind structure))
48 wlott 1.2 (system:%primitive make-fixnum structure)))
49 ram 1.1
50    
51    
52     ;;; Hashing functions for the three kinds of hash tables:
53    
54     (eval-when (compile)
55    
56     (defmacro eq-hash (object)
57     "Gives us a hashing of an object such that (eq a b) implies
58     (= (eq-hash a) (eq-hash b))"
59 wlott 1.2 `(truly-the (unsigned-byte 24) (%primitive make-fixnum ,object)))
60 ram 1.1
61     (defmacro eql-hash (object)
62     "Gives us a hashing of an object such that (eql a b) implies
63     (= (eql-hash a) (eql-hash b))"
64     `(if (numberp ,object)
65     (logand (truncate ,object) most-positive-fixnum)
66 wlott 1.2 (truly-the fixnum (%primitive make-fixnum ,object))))
67 ram 1.1
68     (defmacro equal-hash (object)
69     "Gives us a hashing of an object such that (equal a b) implies
70     (= (equal-hash a) (equal-hash b))"
71     `(sxhash ,object))
72    
73     )
74    
75     ;;; Rehashing functions:
76    
77     (defun almost-primify (num)
78     (declare (fixnum num))
79     "Almost-Primify returns an almost prime number greater than or equal
80     to NUM."
81     (if (= (rem num 2) 0)
82     (setq num (+ 1 num)))
83     (if (= (rem num 3) 0)
84     (setq num (+ 2 num)))
85     (if (= (rem num 7) 0)
86     (setq num (+ 4 num)))
87     num)
88    
89     (eval-when (compile)
90    
91     (defmacro grow-size (table)
92     "Returns a fixnum for the next size of a growing hash-table."
93     `(let ((rehash-size (hash-table-rehash-size ,table)))
94     (if (floatp rehash-size)
95     (ceiling (* rehash-size (hash-table-size ,table)))
96     (+ rehash-size (hash-table-size ,table)))))
97    
98     (defmacro grow-rehash-threshold (table new-length)
99     "Returns the next rehash threshold for the table."
100     table
101     `,new-length
102     ; `(ceiling (* (hash-table-rehash-threshold ,table)
103     ; (/ ,new-length (hash-table-size ,table))))
104     )
105    
106     (defmacro hash-set (vector key value length hashing-function)
107     "Used for rehashing. Enters the value for the key into the vector
108     by hashing. Never grows the vector. Assumes the key is not yet
109     entered."
110     `(let ((index (rem (the fixnum (funcall ,hashing-function ,key))
111     (the fixnum ,length))))
112     (declare (fixnum index))
113     (setf (aref (the simple-vector ,vector) index)
114     (cons (cons ,key ,value)
115     (aref (the simple-vector ,vector) index)))))
116    
117     )
118    
119     (defun rehash (structure hash-vector new-length)
120     (declare (simple-vector hash-vector))
121     (declare (fixnum new-length))
122     "Rehashes a hash table and replaces the TABLE entry in the structure if
123     someone hasn't done so already. New vector is of NEW-LENGTH."
124 wlott 1.5 (do ((new-vector (make-array new-length :initial-element nil))
125 ram 1.1 (i 0 (1+ i))
126     (size (hash-table-size structure))
127     (hashing-function (case (hash-table-kind structure)
128     (eq #'(lambda (x) (eq-hash x)))
129     (eql #'(lambda (x) (eql-hash x)))
130     (equal #'(lambda (x) (equal-hash x))))))
131     ((= i size)
132     (cond ((eq hash-vector (hash-table-table structure))
133     (cond ((> new-length size)
134     (setf (hash-table-table structure) new-vector)
135     (setf (hash-table-rehash-threshold structure)
136     (grow-rehash-threshold structure new-length))
137     (setf (hash-table-size structure) new-length))
138     (t
139     (setf (hash-table-table structure) new-vector)))
140     (if (not (eq (hash-table-kind structure) 'equal))
141     (%primitive set-vector-subtype new-vector
142 wlott 1.2 valid-hashing)))))
143 ram 1.1 (declare (fixnum i size))
144     (do ((bucket (aref hash-vector i) (cdr bucket)))
145     ((null bucket))
146     (hash-set new-vector (caar bucket) (cdar bucket) new-length
147     hashing-function))
148     (setf (aref hash-vector i) nil)))
149    
150     ;;; Macros for Gethash, %Puthash, and Remhash:
151    
152     (eval-when (compile)
153    
154     ;;; Hashop dispatches on the kind of hash table we've got, rehashes if
155     ;;; necessary, and binds Vector to the hash vector, Index to the index
156     ;;; into that vector that the Key points to, and Size to the size of the
157     ;;; hash vector. Since Equal hash tables only need to be maybe rehashed
158     ;;; sometimes, one can tell it if it's one of those times with the
159     ;;; Equal-Needs-To-Rehash-P argument.
160    
161     (defmacro hashop (equal-needs-to-rehash-p eq-body eql-body equal-body)
162     `(let* ((vector (hash-table-table hash-table))
163     (size (length vector)))
164     (declare (simple-vector vector) (fixnum size)
165     (inline assoc))
166     (case (hash-table-kind hash-table)
167     (equal
168     ,@(if equal-needs-to-rehash-p `((equal-rehash-if-needed)))
169     (let ((index (rem (the fixnum (equal-hash key)) size)))
170     (declare (fixnum index))
171     ,equal-body))
172     (eq
173     (without-gcing
174     (eq-rehash-if-needed)
175     (let ((index (rem (the fixnum (eq-hash key)) size)))
176     (declare (fixnum index))
177     ,eq-body)))
178     (eql
179     (without-gcing
180     (eq-rehash-if-needed)
181     (let ((index (rem (the fixnum (eql-hash key)) size)))
182     (declare (fixnum index))
183     ,eql-body))))))
184    
185     (defmacro eq-rehash-if-needed ()
186 wlott 1.2 `(let ((subtype (truly-the (unsigned-byte 24)
187     (%primitive get-vector-subtype vector))))
188     (declare (type (unsigned-byte 24) subtype))
189     (cond ((/= subtype valid-hashing)
190 ram 1.1 (rehash hash-table vector size)
191     (setq vector (hash-table-table hash-table)))
192     ((> (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 equal-rehash-if-needed ()
199     `(cond ((> (hash-table-number-entries hash-table)
200     (hash-table-rehash-threshold hash-table))
201     (rehash hash-table vector (grow-size hash-table))
202     (setq vector (hash-table-table hash-table))
203     (setq size (length vector)))))
204    
205     (defmacro rehash-if-needed ()
206 wlott 1.2 `(let ((subtype (truly-the (unsigned-byte 24)
207     (%primitive get-vector-subtype vector)))
208 ram 1.1 (size (length vector)))
209 wlott 1.2 (declare (type (unsigned-byte 24) subtype)
210     (fixnum size))
211 ram 1.1 (cond ((and (not (eq (hash-table-kind hash-table) 'equal))
212 wlott 1.2 (/= subtype valid-hashing))
213 ram 1.1 (rehash hash-table vector size)
214     (setq vector (hash-table-table hash-table))
215     (setq size (length vector)))
216     ((> (hash-table-number-entries hash-table)
217     (hash-table-rehash-threshold hash-table))
218     (rehash hash-table vector (grow-size hash-table))
219     (setq vector (hash-table-table hash-table))
220     (setq size (length vector))))))
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     (cond ((eq test #'eq) (setq test 'eq))
231     ((eq test #'eql) (setq test 'eql))
232     ((eq test #'equal) (setq test 'equal)))
233 wlott 1.2 (if (not (member test '(eq eql equal) :test #'eq))
234 ram 1.1 (error "~S is an illegal :Test for hash tables." test))
235     (setq size (if (<= size 37) 37 (almost-primify size)))
236     (cond ((null rehash-threshold)
237     (setq rehash-threshold size))
238     ((floatp rehash-threshold)
239     (setq rehash-threshold (ceiling (* rehash-threshold size)))))
240     (make-hash-table-structure :size size
241     :rehash-size rehash-size
242     :rehash-threshold rehash-threshold
243     :table
244     (if (eq test 'equal)
245 wlott 1.5 (make-array size :initial-element nil)
246 ram 1.1 (%primitive set-vector-subtype
247 wlott 1.5 (make-array size
248     :initial-element nil)
249 wlott 1.2 valid-hashing))
250 ram 1.1 :kind test)))
251    
252     ;;; Manipulating hash tables:
253    
254     (defun gethash (key hash-table &optional default)
255     "Finds the entry in Hash-Table whose key is Key and returns the associated
256     value and T as multiple values, or returns Default and Nil if there is no
257     such entry."
258     (macrolet ((lookup (test)
259     `(let ((cons (assoc key (aref vector index) :test #',test)))
260     (declare (list cons))
261     (if cons
262     (values (cdr cons) t)
263     (values default nil)))))
264     (hashop nil
265     (lookup eq)
266     (lookup eql)
267     (lookup equal))))
268    
269     (defun %puthash (key hash-table value)
270     "Create an entry in HASH-TABLE associating KEY with VALUE; if there already
271     is an entry for KEY, replace it. Returns VALUE."
272     (macrolet ((store (test)
273     `(let ((cons (assoc key (aref vector index) :test #',test)))
274     (declare (list cons))
275     (cond (cons (setf (cdr cons) value))
276     (t
277     (push (cons key value) (aref vector index))
278     (incf (hash-table-number-entries hash-table))
279     value)))))
280     (hashop t
281     (store eq)
282     (store eql)
283     (store equal))))
284    
285     (defun remhash (key hash-table)
286     "Remove any entry for KEY in HASH-TABLE. Returns T if such an entry
287     existed; () otherwise."
288     (hashop nil
289     (let ((bucket (aref vector index))) ; EQ case
290     (cond ((and bucket (eq (caar bucket) key))
291     (pop (aref vector index))
292     (decf (hash-table-number-entries hash-table))
293     t)
294     (t
295     (do ((last bucket bucket)
296     (bucket (cdr bucket) (cdr bucket)))
297     ((null bucket) ())
298     (when (eq (caar bucket) key)
299     (rplacd last (cdr bucket))
300     (decf (hash-table-number-entries hash-table))
301     (return t))))))
302     (let ((bucket (aref vector index))) ; EQL case
303     (cond ((and bucket (eql (caar bucket) key))
304     (pop (aref vector index))
305     (decf (hash-table-number-entries hash-table))
306     t)
307     (t
308     (do ((last bucket bucket)
309     (bucket (cdr bucket) (cdr bucket)))
310     ((null bucket) ())
311     (when (eql (caar bucket) key)
312     (rplacd last (cdr bucket))
313     (decf (hash-table-number-entries hash-table))
314     (return t))))))
315     (let ((bucket (aref vector index))) ; EQUAL case
316     (cond ((and bucket (equal (caar bucket) key))
317     (pop (aref vector index))
318     (decf (hash-table-number-entries hash-table))
319     t)
320     (t
321     (do ((last bucket bucket)
322     (bucket (cdr bucket) (cdr bucket)))
323     ((null bucket) ())
324     (when (equal (caar bucket) key)
325     (rplacd last (cdr bucket))
326     (decf (hash-table-number-entries hash-table))
327     (return t))))))))
328    
329     (defun maphash (map-function hash-table)
330     "For each entry in HASH-TABLE, calls MAP-FUNCTION on the key and value
331     of the entry; returns T."
332     (let ((vector (hash-table-table hash-table)))
333     (declare (simple-vector vector))
334     (rehash-if-needed)
335     (do ((i 0 (1+ i))
336     (size (hash-table-size hash-table)))
337     ((= i size))
338     (declare (fixnum i size))
339     (do ((bucket (aref vector i) (cdr bucket)))
340     ((null bucket))
341    
342     (funcall map-function (caar bucket) (cdar bucket))))))
343    
344     (defun clrhash (hash-table)
345     "Removes all entries of HASH-TABLE and returns the hash table itself."
346     (let ((vector (hash-table-table hash-table)))
347     (declare (simple-vector vector))
348     (setf (hash-table-number-entries hash-table) 0)
349     (do ((i 0 (1+ i))
350     (size (hash-table-size hash-table)))
351     ((= i size) hash-table)
352     (declare (fixnum i size))
353     (setf (aref vector i) nil))))
354    
355     (defun hash-table-count (hash-table)
356     "Returns the number of entries in the given Hash-Table."
357     (hash-table-number-entries hash-table))
358    
359     ;;; Primitive Hash Function
360    
361     ;;; The maximum length and depth to which we hash lists.
362     (defconstant sxhash-max-len 7)
363     (defconstant sxhash-max-depth 3)
364    
365     (eval-when (compile eval)
366    
367 ram 1.3 (defconstant sxhash-bits-byte (byte 23 0))
368 wlott 1.2 (defconstant sxmash-total-bits 26)
369     (defconstant sxmash-rotate-bits 7)
370    
371     (defmacro sxmash (place with)
372     (let ((n-with (gensym)))
373     `(let ((,n-with ,with))
374     (declare (fixnum ,n-with))
375     (setf ,place
376     (logxor (ash ,n-with ,(- sxmash-rotate-bits sxmash-total-bits))
377     (ash (logand ,n-with
378     ,(1- (ash 1
379     (- sxmash-total-bits
380     sxmash-rotate-bits))))
381     ,sxmash-rotate-bits)
382     (the fixnum ,place))))))
383    
384 ram 1.1 (defmacro sxhash-simple-string (sequence)
385 wlott 1.6 `(%sxhash-simple-string ,sequence))
386 ram 1.1
387     (defmacro sxhash-string (sequence)
388     (let ((data (gensym))
389     (start (gensym))
390     (end (gensym)))
391     `(with-array-data ((,data ,sequence)
392     (,start)
393 wlott 1.2 (,end))
394 ram 1.1 (if (zerop ,start)
395 wlott 1.6 (%sxhash-simple-substring ,data ,end)
396 ram 1.1 (sxhash-simple-string (coerce (the string ,sequence)
397     'simple-string))))))
398    
399     (defmacro sxhash-list (sequence depth)
400     `(if (= ,depth sxhash-max-depth)
401     0
402     (do ((sequence ,sequence (cdr (the list sequence)))
403     (index 0 (1+ index))
404     (hash 2))
405     ((or (atom sequence) (= index sxhash-max-len)) hash)
406     (declare (fixnum hash index))
407 wlott 1.2 (sxmash hash (internal-sxhash (car sequence) (1+ ,depth))))))
408 ram 1.1
409 wlott 1.2
410 ram 1.1 ); eval-when (compile eval)
411    
412    
413     (defun sxhash (s-expr)
414     "Computes a hash code for S-EXPR and returns it as an integer."
415     (internal-sxhash s-expr 0))
416    
417 wlott 1.2
418 ram 1.1 (defun internal-sxhash (s-expr depth)
419     (typecase s-expr
420 wlott 1.2 ;; The pointers and immediate types.
421     (list (sxhash-list s-expr depth))
422     (fixnum
423 ram 1.3 (ldb sxhash-bits-byte s-expr))
424 wlott 1.4 (structure
425     (internal-sxhash (type-of s-expr) depth))
426 wlott 1.2 ;; Other-pointer types.
427     (simple-string (sxhash-simple-string s-expr))
428 ram 1.1 (symbol (sxhash-simple-string (symbol-name s-expr)))
429     (number
430     (etypecase s-expr
431 ram 1.3 (integer (ldb sxhash-bits-byte s-expr))
432     (single-float
433 wlott 1.7 (let ((bits (single-float-bits s-expr)))
434 ram 1.3 (ldb sxhash-bits-byte
435     (logxor (ash bits (- sxmash-rotate-bits))
436     bits))))
437     (double-float
438     (let* ((val s-expr)
439 wlott 1.7 (lo (double-float-low-bits val))
440     (hi (double-float-high-bits val)))
441 ram 1.3 (ldb sxhash-bits-byte
442     (logxor (ash lo (- sxmash-rotate-bits))
443     (ash hi (- sxmash-rotate-bits))
444     lo hi))))
445 ram 1.1 (ratio (the fixnum (+ (internal-sxhash (numerator s-expr) 0)
446     (internal-sxhash (denominator s-expr) 0))))
447     (complex (the fixnum (+ (internal-sxhash (realpart s-expr) 0)
448     (internal-sxhash (imagpart s-expr) 0))))))
449 wlott 1.2 (array
450     (typecase s-expr
451     (string (sxhash-string s-expr))
452     (t (array-rank s-expr))))
453     ;; Everything else.
454 ram 1.3 (t 42)))
455 wlott 1.8
456    
457    
458     ;;;; WITH-HASH-TABLE-ITERATOR
459    
460     (defmacro with-hash-table-iterator ((function hash-table) &body body)
461     "WITH-HASH-TABLE-ITERATOR ((function hash-table) &body body)
462     provides a method of manually looping over the elements of a hash-table.
463     function is bound to a generator-macro that, withing the scope of the
464     invocation, returns three values. First, whether there are any more objects
465     in the hash-table, second, the key, and third, the value."
466     (let ((counter (gensym))
467     (pointer (gensym))
468     (table (gensym))
469     (size (gensym))
470     (the-table (gensym)))
471     `(let* ((,the-table ,hash-table)
472     (,table (hash-table-table ,the-table))
473     (,size (hash-table-size ,the-table))
474     (,counter 0)
475     (,pointer nil))
476     (macrolet ((,function ()
477     `(loop
478     (when (= ,',counter ,',size) (return))
479     (let ((bucket (or ,',pointer
480     (aref ,',table ,',counter))))
481     (when bucket
482     (cond ((cdr bucket)
483     (setf ,',pointer (cdr bucket)))
484     (t
485     (setf ,',pointer nil)
486     (incf ,',counter)))
487     (return (values t (caar bucket) (cdar bucket)))))
488     (incf ,',counter))))
489     ,@body))))

  ViewVC Help
Powered by ViewVC 1.1.5