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

Contents of /src/code/hash.lisp

Parent Directory Parent Directory | Revision Log Revision Log


Revision 1.18 - (hide annotations)
Sat Jun 27 21:41:22 1992 UTC (21 years, 10 months ago) by wlott
Branch: MAIN
Changes since 1.17: +3 -1 lines
Added some type declarations so that a call to make-array gets open coded.
1 wlott 1.13 ;;; -*- Package: CL -*-
2 ram 1.1 ;;;
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.18 "$Header: /tiger/var/lib/cvsroots/cmucl/src/code/hash.lisp,v 1.18 1992/06/27 21:41:22 wlott Exp $")
11 ram 1.9 ;;;
12 ram 1.1 ;;; **********************************************************************
13     ;;;
14     ;;; Hashing and hash table functions for Spice Lisp.
15 wlott 1.13 ;;; Originally written by Skef Wholey.
16     ;;; Everything except SXHASH rewritten by William Lott.
17 ram 1.1 ;;;
18 wlott 1.13 (in-package :common-lisp)
19    
20 ram 1.1 (export '(hash-table hash-table-p make-hash-table
21     gethash remhash maphash clrhash
22 wlott 1.13 hash-table-count with-hash-table-iterator
23     hash-table-rehash-size hash-table-rehash-threshold
24     hash-table-size hash-table-test
25     sxhash))
26 ram 1.1
27 wlott 1.13
28     ;;;; The hash-table structure.
29 wlott 1.2
30 wlott 1.13 (defstruct (hash-table
31     (:constructor %make-hash-table)
32     (:print-function %print-hash-table)
33     (:make-load-form-fun make-hash-table-load-form))
34 ram 1.1 "Structure used to implement hash tables."
35 wlott 1.13 ;;
36     ;; The type of hash table this is. Only used for printing and as part of
37     ;; the exported interface.
38     (test (required-argument) :type symbol :read-only t)
39     ;;
40     ;; The function used to compare two keys. Returns T if they are the same
41     ;; and NIL if not.
42     (test-fun (required-argument) :type function :read-only t)
43     ;;
44     ;; The function used to compute the hashing of a key. Returns two values:
45     ;; the index hashing and T if that might change with the next GC.
46     (hash-fun (required-argument) :type function :read-only t)
47     ;;
48     ;; How much to grow the hash table by when it fills up. If an index, then
49     ;; add that amount. If a floating point number, then multiple it by that.
50     (rehash-size (required-argument) :type (or index (float (1.0))) :read-only t)
51     ;;
52     ;; How full the hash table has to get before we rehash.
53     (rehash-threshold (required-argument) :type (real 0 1) :read-only t)
54     ;;
55     ;; (* rehash-threshold (length table)), saved here so we don't have to keep
56     ;; recomputing it.
57     (rehash-trigger (required-argument) :type index)
58     ;;
59     ;; The current number of entries in the table.
60     (number-entries 0 :type index)
61     ;;
62     ;; Vector of ht-buckets.
63 wlott 1.10 (table (required-argument) :type simple-vector))
64 wlott 1.13 ;;;
65     (defun %print-hash-table (ht stream depth)
66     (declare (ignore depth))
67     (print-unreadable-object (ht stream :identity t)
68 wlott 1.15 (format stream "~A hash table, ~D entr~@:P"
69 wlott 1.13 (symbol-name (hash-table-test ht))
70     (hash-table-number-entries ht))))
71 ram 1.1
72 wlott 1.13 (defconstant max-hash most-positive-fixnum)
73 ram 1.1
74 wlott 1.13 (deftype hash ()
75     `(integer 0 ,max-hash))
76 ram 1.1
77    
78 wlott 1.13 (defstruct hash-table-bucket
79     ;;
80     ;; The hashing associated with key, kept around so we don't have to recompute
81     ;; it each time. When NIL, then just use %primitive make-fixnum. We don't
82     ;; cache the results of make-fixnum, because it can change with a GC.
83     (hash nil :type (or hash null))
84     ;;
85     ;; The key and value, originally supplied by the user.
86     (key nil :type t)
87     (value nil :type t)
88     ;;
89     ;; The next bucket, or NIL if there are no more.
90     (next nil :type (or hash-table-bucket null)))
91 ram 1.1
92 wlott 1.13
93 ram 1.1
94 wlott 1.13 ;;;; Utility functions.
95 ram 1.1
96 wlott 1.13 (declaim (inline pointer-hash))
97     (defun pointer-hash (key)
98     (declare (values hash))
99     (truly-the hash (%primitive make-fixnum key)))
100 ram 1.1
101 wlott 1.13 (declaim (inline eq-hash))
102     (defun eq-hash (key)
103     (declare (values hash (member t nil)))
104     (values (pointer-hash key)
105     (oddp (get-lisp-obj-address key))))
106 ram 1.1
107 wlott 1.13 (declaim (inline eql-hash))
108     (defun eql-hash (key)
109     (declare (values hash (member t nil)))
110     (if (numberp key)
111     (equal-hash key)
112     (eq-hash key)))
113 ram 1.1
114 wlott 1.13 (declaim (inline equal-hash))
115     (defun equal-hash (key)
116     (declare (values hash (member t nil)))
117     (values (sxhash key) nil))
118 ram 1.1
119    
120     (defun almost-primify (num)
121 wlott 1.13 (declare (type index num))
122 ram 1.1 "Almost-Primify returns an almost prime number greater than or equal
123     to NUM."
124     (if (= (rem num 2) 0)
125     (setq num (+ 1 num)))
126     (if (= (rem num 3) 0)
127     (setq num (+ 2 num)))
128     (if (= (rem num 7) 0)
129     (setq num (+ 4 num)))
130     num)
131    
132    
133    
134 wlott 1.13 ;;;; Construction and simple accessors.
135 ram 1.1
136 wlott 1.13 ;;; MAKE-HASH-TABLE -- public.
137     ;;;
138     (defun make-hash-table (&key (test 'eql) (size 65) (rehash-size 1.5)
139     (rehash-threshold 1))
140     "Creates and returns a new hash table. The keywords are as follows:
141     :TEST -- Indicates what kind of test to use. Only EQ, EQL, and EQUAL
142     are currently supported.
143     :SIZE -- A hint as to how many elements will be put in this hash
144     table.
145     :REHASH-SIZE -- Indicates how to expand the table when it fills up.
146     If an integer, add space for that many elements. If a floating
147     point number (which must be greater than 1.0), multiple the size
148     by that amount.
149     :REHASH-THRESHOLD -- Indicates how dense the table can become before
150     forcing a rehash. Can be any real number between 0 and 1 (inclusive)."
151     (declare (type (or function (member eq eql equal)) test)
152     (type index size)
153     (type (or index (float (1.0))) rehash-size)
154     (type (real 0 1) rehash-threshold))
155     (multiple-value-bind
156     (test test-fun hash-fun)
157     (cond ((or (eq test #'eq) (eq test 'eq))
158     (values 'eq #'eq #'eq-hash))
159     ((or (eq test #'eql) (eq test 'eql))
160     (values 'eql #'eql #'eql-hash))
161     ((or (eq test #'equal) (eq test 'equal))
162     (values 'equal #'equal #'equal-hash))
163     (t
164     (error "Unknown :TEST for MAKE-HASH-TABLE: ~S" test)))
165     (let* ((size (ceiling size rehash-threshold))
166     (length (if (<= size 37) 37 (almost-primify size)))
167     (vector (make-array length :initial-element nil)))
168 wlott 1.18 (declare (type index size length)
169     (type simple-vector vector))
170 wlott 1.14 (%make-hash-table
171 wlott 1.13 :test test
172     :test-fun test-fun
173     :hash-fun hash-fun
174     :rehash-size rehash-size
175     :rehash-threshold rehash-threshold
176     :rehash-trigger (* size rehash-threshold)
177     :table vector))))
178 ram 1.1
179 wlott 1.13 (defun hash-table-count (hash-table)
180     "Returns the number of entries in the given HASH-TABLE."
181     (declare (type hash-table hash-table)
182     (values index))
183     (hash-table-number-entries hash-table))
184 ram 1.1
185 wlott 1.13 (setf (documentation 'hash-table-rehash-size 'function)
186     "Return the rehash-size HASH-TABLE was created with.")
187 ram 1.1
188 wlott 1.13 (setf (documentation 'hash-table-rehash-threshold 'function)
189     "Return the rehash-threshold HASH-TABLE was created with.")
190 ram 1.1
191 wlott 1.13 (defun hash-table-size (hash-table)
192     "Return a size that can be used with MAKE-HASH-TABLE to create a hash
193     table that can hold however many entries HASH-TABLE can hold without
194     having to be grown."
195     (hash-table-rehash-trigger hash-table))
196 ram 1.1
197 wlott 1.13 (setf (documentation 'hash-table-test 'function)
198     "Return the test HASH-TABLE was created with.")
199 ram 1.1
200    
201 wlott 1.13 ;;;; Accessing functions.
202 ram 1.1
203 wlott 1.13 ;;; REHASH -- internal.
204     ;;;
205     ;;; Make a new vector for TABLE. If GROW is NIL, use the same size as before,
206     ;;; otherwise extend the table based on the rehash-size.
207     ;;;
208     (defun rehash (table grow)
209     (declare (type hash-table table))
210     (let* ((old-vector (hash-table-table table))
211     (old-length (length old-vector))
212     (new-length
213     (if grow
214     (let ((rehash-size (hash-table-rehash-size table)))
215     (etypecase rehash-size
216     (fixnum
217     (+ rehash-size old-length))
218     (float
219     (ceiling (* rehash-size old-length)))))
220     old-length))
221     (new-vector (make-array new-length :initial-element nil)))
222     (dotimes (i old-length)
223     (do ((bucket (svref old-vector i) next)
224     (next nil))
225     ((null bucket))
226     (setf next (hash-table-bucket-next bucket))
227     (let* ((old-hashing (hash-table-bucket-hash bucket))
228     (hashing (cond
229     (old-hashing old-hashing)
230     (t
231     (set-header-data new-vector
232     vm:vector-valid-hashing-subtype)
233     (pointer-hash (hash-table-bucket-key bucket)))))
234     (index (rem hashing new-length)))
235     (setf (hash-table-bucket-next bucket) (svref new-vector index))
236     (setf (svref new-vector index) bucket)))
237     ;; We clobber the old vector contents so that if it is living in
238     ;; static space it won't keep ahold of pointers into dynamic space.
239     (setf (svref old-vector i) nil))
240     (setf (hash-table-table table) new-vector)
241     (unless (= new-length old-length)
242     (setf (hash-table-rehash-trigger table)
243     (let ((threshold (hash-table-rehash-threshold table)))
244     ;; Optimize the threshold=1 case so we don't have to use
245     ;; generic arithmetic in the most common case.
246     (if (eql threshold 1)
247     new-length
248     (truncate (* threshold new-length)))))))
249     (undefined-value))
250 ram 1.1
251 wlott 1.13 ;;; GETHASH -- Public.
252     ;;;
253 ram 1.1 (defun gethash (key hash-table &optional default)
254 wlott 1.13 "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. Entries can be added using SETF."
257     (declare (type hash-table hash-table)
258     (values t (member t nil)))
259     (without-gcing
260     (when (= (get-header-data (hash-table-table hash-table))
261     vm:vector-must-rehash-subtype)
262     (rehash hash-table nil))
263     (let* ((vector (hash-table-table hash-table))
264     (length (length vector))
265     (hashing (funcall (hash-table-hash-fun hash-table) key))
266     (index (rem hashing length))
267     (test-fun (hash-table-test-fun hash-table)))
268     (do ((bucket (svref vector index) (hash-table-bucket-next bucket)))
269     ((null bucket) (values default nil))
270     (let ((bucket-hashing (hash-table-bucket-hash bucket)))
271     (when (if bucket-hashing
272     (and (= bucket-hashing hashing)
273     (funcall test-fun key (hash-table-bucket-key bucket)))
274     (eq key (hash-table-bucket-key bucket)))
275     (return (values (hash-table-bucket-value bucket) t))))))))
276 ram 1.1
277 wlott 1.13 ;;; %PUTHASH -- public setf method.
278     ;;;
279 ram 1.1 (defun %puthash (key hash-table value)
280 wlott 1.13 (declare (type hash-table hash-table))
281     (without-gcing
282     (let ((entries (1+ (hash-table-number-entries hash-table))))
283     (setf (hash-table-number-entries hash-table) entries)
284     (cond ((> entries (hash-table-rehash-trigger hash-table))
285     (rehash hash-table t))
286     ((= (get-header-data (hash-table-table hash-table))
287     vm:vector-must-rehash-subtype)
288     (rehash hash-table nil))))
289     (multiple-value-bind
290     (hashing eq-based)
291     (funcall (hash-table-hash-fun hash-table) key)
292     (let* ((vector (hash-table-table hash-table))
293     (length (length vector))
294     (index (rem hashing length))
295     (first-bucket (svref vector index))
296     (test-fun (hash-table-test-fun hash-table)))
297     (do ((bucket first-bucket (hash-table-bucket-next bucket)))
298     ((null bucket)
299 wlott 1.15 (when eq-based
300     (set-header-data vector vm:vector-valid-hashing-subtype))
301 wlott 1.13 (setf (svref vector index)
302     (make-hash-table-bucket
303     :hash (unless eq-based hashing)
304     :key key
305     :value value
306     :next first-bucket)))
307     (let ((bucket-hashing (hash-table-bucket-hash bucket)))
308     (when (if bucket-hashing
309     (and (= bucket-hashing hashing)
310     (funcall test-fun
311     key (hash-table-bucket-key bucket)))
312     (eq key (hash-table-bucket-key bucket)))
313     (setf (hash-table-bucket-value bucket) value)
314     (decf (hash-table-number-entries hash-table))
315     (return)))))))
316     value)
317 ram 1.1
318 wlott 1.13 ;;; REMHASH -- public.
319     ;;;
320 ram 1.1 (defun remhash (key hash-table)
321 wlott 1.13 "Remove the entry in HASH-TABLE associated with KEY. Returns T if there
322     was such an entry, and NIL if not."
323     (declare (type hash-table hash-table)
324     (values (member t nil)))
325     (without-gcing
326     (when (= (get-header-data (hash-table-table hash-table))
327     vm:vector-must-rehash-subtype)
328     (rehash hash-table nil))
329     (let* ((vector (hash-table-table hash-table))
330     (length (length vector))
331     (hashing (funcall (hash-table-hash-fun hash-table) key))
332     (index (rem hashing length))
333     (test-fun (hash-table-test-fun hash-table)))
334     (do ((prev nil bucket)
335     (bucket (svref vector index) (hash-table-bucket-next bucket)))
336     ((null bucket) nil)
337     (let ((bucket-hashing (hash-table-bucket-hash bucket)))
338     (when (if bucket-hashing
339     (and (= bucket-hashing hashing)
340     (funcall test-fun key (hash-table-bucket-key bucket)))
341     (eq key (hash-table-bucket-key bucket)))
342     (if prev
343     (setf (hash-table-bucket-next prev)
344     (hash-table-bucket-next bucket))
345     (setf (svref vector index)
346     (hash-table-bucket-next bucket)))
347 wlott 1.16 (decf (hash-table-number-entries hash-table))
348 wlott 1.13 (return t)))))))
349    
350     ;;; CLRHASH -- public.
351     ;;;
352     (defun clrhash (hash-table)
353     "This removes all the entries from HASH-TABLE and returns the hash table
354     itself."
355     (let ((vector (hash-table-table hash-table)))
356     (dotimes (i (length vector))
357     (setf (aref vector i) nil))
358     (setf (hash-table-number-entries hash-table) 0)
359     (set-header-data vector vm:vector-normal-subtype))
360     hash-table)
361    
362    
363 ram 1.1
364 wlott 1.13 ;;;; MAPHASH and WITH-HASH-TABLE-ITERATOR
365    
366     (declaim (maybe-inline maphash))
367 ram 1.1 (defun maphash (map-function hash-table)
368     "For each entry in HASH-TABLE, calls MAP-FUNCTION on the key and value
369 wlott 1.13 of the entry; returns NIL."
370     (declare (type (or function symbol) map-function)
371     (type hash-table hash-table))
372     (let ((fun (etypecase map-function
373     (function
374     map-function)
375     (symbol
376     (symbol-function map-function))))
377     (vector (hash-table-table hash-table)))
378     (dotimes (i (length vector))
379     (do ((bucket (svref vector i) (hash-table-bucket-next bucket)))
380 ram 1.1 ((null bucket))
381 wlott 1.13 (funcall fun
382     (hash-table-bucket-key bucket)
383     (hash-table-bucket-value bucket))))))
384 ram 1.1
385    
386 wlott 1.13 (defmacro with-hash-table-iterator ((function hash-table) &body body)
387     "WITH-HASH-TABLE-ITERATOR ((function hash-table) &body body)
388     provides a method of manually looping over the elements of a hash-table.
389     function is bound to a generator-macro that, withing the scope of the
390     invocation, returns three values. First, whether there are any more objects
391     in the hash-table, second, the key, and third, the value."
392     (let ((n-function (gensym "WITH-HASH-TABLE-ITERRATOR-")))
393     `(let ((,n-function
394     (let* ((table ,hash-table)
395     (vector (hash-table-table table))
396     (length (length vector))
397     (index 0)
398     (bucket (svref vector 0)))
399     (labels
400     ((,function ()
401     (cond
402     (bucket
403     (multiple-value-prog1
404     (values t
405     (hash-table-bucket-key bucket)
406     (hash-table-bucket-value bucket))
407     (setf bucket (hash-table-bucket-next bucket))))
408     ((= (incf index) length)
409     (values nil))
410     (t
411     (setf bucket (svref vector index))
412     (,function)))))
413     #',function))))
414 wlott 1.17 (macrolet ((,function () '(funcall ,n-function)))
415 wlott 1.13 ,@body))))
416    
417    
418 ram 1.1
419 wlott 1.13 ;;;; SXHASH and support functions
420 ram 1.1
421     ;;; The maximum length and depth to which we hash lists.
422     (defconstant sxhash-max-len 7)
423     (defconstant sxhash-max-depth 3)
424    
425     (eval-when (compile eval)
426    
427 ram 1.3 (defconstant sxhash-bits-byte (byte 23 0))
428 wlott 1.2 (defconstant sxmash-total-bits 26)
429     (defconstant sxmash-rotate-bits 7)
430    
431     (defmacro sxmash (place with)
432     (let ((n-with (gensym)))
433     `(let ((,n-with ,with))
434     (declare (fixnum ,n-with))
435     (setf ,place
436     (logxor (ash ,n-with ,(- sxmash-rotate-bits sxmash-total-bits))
437     (ash (logand ,n-with
438     ,(1- (ash 1
439     (- sxmash-total-bits
440     sxmash-rotate-bits))))
441     ,sxmash-rotate-bits)
442     (the fixnum ,place))))))
443    
444 ram 1.1 (defmacro sxhash-simple-string (sequence)
445 wlott 1.6 `(%sxhash-simple-string ,sequence))
446 ram 1.1
447     (defmacro sxhash-string (sequence)
448     (let ((data (gensym))
449     (start (gensym))
450     (end (gensym)))
451     `(with-array-data ((,data ,sequence)
452     (,start)
453 wlott 1.2 (,end))
454 ram 1.1 (if (zerop ,start)
455 wlott 1.6 (%sxhash-simple-substring ,data ,end)
456 ram 1.1 (sxhash-simple-string (coerce (the string ,sequence)
457     'simple-string))))))
458    
459     (defmacro sxhash-list (sequence depth)
460     `(if (= ,depth sxhash-max-depth)
461     0
462     (do ((sequence ,sequence (cdr (the list sequence)))
463     (index 0 (1+ index))
464     (hash 2))
465     ((or (atom sequence) (= index sxhash-max-len)) hash)
466     (declare (fixnum hash index))
467 wlott 1.2 (sxmash hash (internal-sxhash (car sequence) (1+ ,depth))))))
468 ram 1.1
469 wlott 1.2
470 ram 1.1 ); eval-when (compile eval)
471    
472    
473     (defun sxhash (s-expr)
474     "Computes a hash code for S-EXPR and returns it as an integer."
475     (internal-sxhash s-expr 0))
476    
477 wlott 1.2
478 ram 1.1 (defun internal-sxhash (s-expr depth)
479     (typecase s-expr
480 wlott 1.2 ;; The pointers and immediate types.
481     (list (sxhash-list s-expr depth))
482     (fixnum
483 ram 1.3 (ldb sxhash-bits-byte s-expr))
484 wlott 1.4 (structure
485     (internal-sxhash (type-of s-expr) depth))
486 wlott 1.2 ;; Other-pointer types.
487     (simple-string (sxhash-simple-string s-expr))
488 ram 1.1 (symbol (sxhash-simple-string (symbol-name s-expr)))
489     (number
490     (etypecase s-expr
491 ram 1.3 (integer (ldb sxhash-bits-byte s-expr))
492     (single-float
493 wlott 1.7 (let ((bits (single-float-bits s-expr)))
494 ram 1.3 (ldb sxhash-bits-byte
495     (logxor (ash bits (- sxmash-rotate-bits))
496     bits))))
497     (double-float
498     (let* ((val s-expr)
499 wlott 1.7 (lo (double-float-low-bits val))
500     (hi (double-float-high-bits val)))
501 ram 1.3 (ldb sxhash-bits-byte
502     (logxor (ash lo (- sxmash-rotate-bits))
503     (ash hi (- sxmash-rotate-bits))
504     lo hi))))
505 ram 1.1 (ratio (the fixnum (+ (internal-sxhash (numerator s-expr) 0)
506     (internal-sxhash (denominator s-expr) 0))))
507     (complex (the fixnum (+ (internal-sxhash (realpart s-expr) 0)
508     (internal-sxhash (imagpart s-expr) 0))))))
509 wlott 1.2 (array
510     (typecase s-expr
511     (string (sxhash-string s-expr))
512     (t (array-rank s-expr))))
513     ;; Everything else.
514 ram 1.3 (t 42)))
515 wlott 1.8
516    
517    
518 wlott 1.10 ;;;; Dumping one as a constant.
519    
520     (defun make-hash-table-load-form (table)
521     (values
522     `(make-hash-table
523 wlott 1.13 :test ',(hash-table-test table) :size ',(hash-table-size table)
524 wlott 1.10 :hash-table-rehash-size ',(hash-table-rehash-size table)
525     :hash-table-rehash-threshold ',(hash-table-rehash-threshold table))
526     (let ((sets nil))
527 wlott 1.13 (declare (inline maphash))
528     (maphash #'(lambda (key value)
529     (setf sets (list* `(gethash ',key ,table) `',value sets)))
530     table)
531 wlott 1.10 (if sets
532     `(setf ,@sets)
533     nil))))

  ViewVC Help
Powered by ViewVC 1.1.5