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

Contents of /src/code/hash.lisp

Parent Directory Parent Directory | Revision Log Revision Log


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

  ViewVC Help
Powered by ViewVC 1.1.5