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

Contents of /src/code/hash.lisp

Parent Directory Parent Directory | Revision Log Revision Log


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

  ViewVC Help
Powered by ViewVC 1.1.5