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

Diff of /src/code/hash.lisp

Parent Directory Parent Directory | Revision Log Revision Log | View Patch Patch

revision 1.9.2.5 by wlott, Wed Jul 31 21:13:18 1991 UTC revision 1.45 by rtoy, Fri Mar 19 15:18:59 2010 UTC
# Line 1  Line 1 
1  ;;; -*- Log: code.log; Package: Lisp -*-  ;;; -*- Package: CL -*-
2  ;;;  ;;;
3  ;;; **********************************************************************  ;;; **********************************************************************
4  ;;; This code was written as part of the CMU Common Lisp project at  ;;; 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.  ;;; Carnegie Mellon University, and has been placed in the public domain.
 ;;; If you want to use this code or any part of CMU Common Lisp, please contact  
 ;;; Scott Fahlman or slisp-group@cs.cmu.edu.  
6  ;;;  ;;;
7  (ext:file-comment  (ext:file-comment
8    "$Header$")    "$Header$")
# Line 12  Line 10 
10  ;;; **********************************************************************  ;;; **********************************************************************
11  ;;;  ;;;
12  ;;; Hashing and hash table functions for Spice Lisp.  ;;; Hashing and hash table functions for Spice Lisp.
13  ;;; Written by Skef Wholey.  ;;; Originally written by Skef Wholey.
14    ;;; Everything except SXHASH rewritten by William Lott.
15    ;;; Equalp hashing by William Newman, Cadabra Inc, and Douglas Crosher, 2000.
16  ;;;  ;;;
17  (in-package 'lisp)  (in-package :lisp)
18    
19    (intl:textdomain "cmucl")
20    
21  (export '(hash-table hash-table-p make-hash-table  (export '(hash-table hash-table-p make-hash-table
22            gethash remhash maphash clrhash            gethash remhash maphash clrhash
23            hash-table-count sxhash            hash-table-count with-hash-table-iterator
24            with-hash-table-iterator))            hash-table-rehash-size hash-table-rehash-threshold
25              hash-table-size hash-table-test sxhash))
26    
27    (in-package :ext)
28    (export '(define-hash-table-test))
29    
30    (in-package :lisp)
31    
32  ;;; Hash-values are all positive fixnums:  
33  (deftype hash-value ()  ;;;; The hash-table structures.
34    '(and fixnum (unsigned-byte)))  
35    ;;; HASH-TABLE -- defstruct.
36  (defstruct (hash-table (:constructor make-hash-table-structure)  ;;;
37                         (:conc-name hash-table-)  (defstruct (hash-table
38                         (:print-function %print-hash-table))              (:constructor %make-hash-table)
39                (:print-function %print-hash-table)
40                (:make-load-form-fun make-hash-table-load-form))
41    "Structure used to implement hash tables."    "Structure used to implement hash tables."
42    (kind 'eq :type (member eq eql equal))    ;;
43    (rehash-size 101 :type real)                  ; might be a float    ;; The type of hash table this is.  Only used for printing and as part of
44    (rehash-threshold 57 :type fixnum)    ;; the exported interface.
45    (number-entries 0 :type fixnum)    (test (required-argument) :type symbol :read-only t)
46      ;;
47      ;; The function used to compare two keys.  Returns T if they are the same
48      ;; and NIL if not.
49      (test-fun (required-argument) :type function :read-only t)
50      ;;
51      ;; The function used to compute the hashing of a key.  Returns two values:
52      ;; the index hashing and T if that might change with the next GC.
53      (hash-fun (required-argument) :type function :read-only t)
54      ;;
55      ;; How much to grow the hash table by when it fills up.  If an index, then
56      ;; add that amount.  If a floating point number, then multiply it by that.
57      (rehash-size (required-argument) :type (or index (single-float (1.0)))
58                   :read-only t)
59      ;;
60      ;; How full the hash table has to get before we rehash.
61      (rehash-threshold (required-argument) :type (single-float (0.0) 1.0)
62                        :read-only t)
63      ;;
64      ;; (* rehash-threshold (length table)), saved here so we don't have to keep
65      ;; recomputing it.
66      (rehash-trigger (required-argument) :type index)
67      ;;
68      ;; The current number of entries in the table.
69      (number-entries 0 :type index)
70      ;;
71      ;; Vector of ht-buckets.
72    (table (required-argument) :type simple-vector)    (table (required-argument) :type simple-vector)
73    (needing-rehash nil :type list))    ;;
74      ;; True if this is a weak hash table, meaning that key->value mappings will
75      ;; disappear if there are no other references to the key.  Note: this only
76      ;; matters if the hash function indicates that the hashing is EQ based.
77      (weak-p nil :type (member t nil))
78      ;;
79      #+gengc
80      ;; Chain of buckets that need to be rehashed because their hashing is EQ
81      ;; based and the key has been moved by the garbage collector.
82      (needing-rehash nil :type (or null hash-table-bucket)))
83  ;;;  ;;;
84  (defun %print-hash-table (structure stream depth)  (defun %print-hash-table (ht stream depth)
85    (declare (ignore depth))    (declare (ignore depth) (stream stream))
86    (format stream "#<~A Hash Table {~X}>"    (print-unreadable-object (ht stream :identity t)
87            (symbol-name (hash-table-kind structure))      (format stream "~A hash table, ~D entr~@:P"
88            (system:%primitive make-fixnum structure)))              (symbol-name (hash-table-test ht))
89                (hash-table-number-entries ht))))
90    
91    (defconstant max-hash most-positive-fixnum)
92    
93    (deftype hash ()
94      `(integer 0 ,max-hash))
95    
96    
97  (defstruct (hash-table-bucket  (defstruct (hash-table-bucket
98              (:print-function %print-hash-table-bucket)              (:print-function %print-hash-table-bucket))
99              (:constructor %make-bucket (key hash value next)))    ;;
100      ;; The hashing associated with key, kept around so we don't have to recompute
101      ;; it each time.  In the non-gengc system, if this is NIL it means that the
102      ;; hashing is EQ based, so use the address of the value.  If the gengc
103      ;; system, we use the presence of the scavhook to tell that.
104      #-gengc (hash nil :type (or hash null))
105      #+gengc (hash 0 :type hash)
106      ;;
107      ;; The key and value, originally supplied by the user.  If the hash table
108      ;; is weak, and this is eq based, then the key is really a weak pointer to
109      ;; the key.
110    (key nil :type t)    (key nil :type t)
   (hash 0 :type hash-value)  
111    (value nil :type t)    (value nil :type t)
112    (next nil :type (or null hash-table-bucket))    ;;
113    (scavhook nil :type (or null scavenger-hook)))    ;; The next bucket, or NIL if there are no more.
114      (next nil :type (or hash-table-bucket null)))
115  ;;;  ;;;
116  (defun %print-hash-table-bucket (bucket stream depth)  (defun %print-hash-table-bucket (bucket stream depth)
117    (declare (ignore depth))    (declare (ignore depth))
118    (format stream "#<hash-table-bucket ~S->~S>"    (print-unreadable-object (bucket stream :type t)
119            (hash-table-bucket-key bucket)      (format stream "for ~S->~S~@[ ~D~]"
120            (hash-table-bucket-value bucket)))              (hash-table-bucket-key bucket)
121                (hash-table-bucket-value bucket)
122  (defun make-hash-table-bucket (table key hash value next scav-hook-p)              (hash-table-bucket-hash bucket))))
123    (declare (type hash-table table) (type hash-value hash)  
124             (type (or null hash-table-bucket) next))  #+gengc
125    (let ((bucket (%make-bucket key hash value next)))  (defstruct (hash-table-eq-bucket
126      (when scav-hook-p              (:include hash-table-bucket))
127        (setf (hash-table-bucket-scavhook bucket)    ;;
128              (make-scavenger-hook    ;; The scavenger-hook object used to detect when the EQ hashing of key will
129               :value key    ;; change.  Only NIL during creation.
130               :function #'(lambda ()    (scavhook nil :type (or null scavenger-hook))
131                             (push bucket (hash-table-needing-rehash table))    ;;
132                             (setf (scavenger-hook-value    ;; True iff this bucket is still linked into the corresponding hash table's
133                                    (hash-table-bucket-scavhook bucket))    ;; vector.
134                                   nil)))))    (linked nil :type (member t nil)))
     bucket))  
135    
136    #|
137    
138    ;;; SCAN-STATE -- defstruct.
139  ;;; Hashing functions for the three kinds of hash tables:  ;;;
140    ;;; Holds the state of a MAPHASH or WITH-HASH-TABLE-ITERATOR.
141    ;;;
142    (defstruct (scan-state)
143      ;;
144      ;; The index into the hash-table-table.
145      (index 0 :type index)
146      ;;
147      ;; The current bucket in that chain.
148      (bucket nil :type (or null hash-table-bucket))
149      ;;
150      )
151    
152  (eval-when (compile eval)  ;;; Non-gengc:
153    ;;;
154    ;;; %puthash: if there are any active scans, then make sure the current bucket
155    ;;; for each scan holds the key we are trying to puthash, and flame out of it
156    ;;; isn't.  Given that we have our hands directly on the correct bucket, just
157    ;;; go for it.
158    ;;;
159    ;;; remhash: make the same check as with %puthash.  If it checks out, then
160    ;;; just scan down the correct bucket chain and yank it.
161    ;;;
162    ;;; rehash: because of the above two tests, rehash will only be called by
163    ;;; gethash.  And we need to do the rehash in order to look anything up.  So
164    ;;; make a list of all the remaining buckets, and stick them in the scan-state.
165    ;;;
166    ;;; Gengc:
167    ;;;
168    ;;; %puthash & remhash: same as above.
169    ;;;
170    ;;; rehash: is only ever called by puthash, so doesn't need anything special to
171    ;;; account for active scans.
172    ;;;
173    ;;; flush-needing-rehash: will only be called by gethash for the same reason
174    ;;; rehash is only called by gethash in the non-gengc system.  And basically
175    ;;; needs to do the same thing rehash does in the non-gengc system.
176    ;;;
177    ;;; hash-table-scavenger-hook: needs to check to see if the bucket being
178    ;;; unlinked is after the current bucket in any of the active scans.  If so,
179    ;;; it needs to add it to a list of buckets that will be processed after all
180    ;;; the buckets visable in the hash-table-table have been delt with.
181    
182  (defmacro eq-hash (object)  |#
   "Gives us a hashing of an object such that (eq a b) implies  
    (= (eq-hash a) (eq-hash b))"  
   `(values (truly-the hash-value (%primitive make-fixnum ,object))  
            t))  
   
 (defmacro eql-hash (object)  
   "Gives us a hashing of an object such that (eql a b) implies  
    (= (eql-hash a) (eql-hash b))"  
   `(if (numberp ,object)  
        (values (%eql-hash object) nil)  
        (eq-hash object)))  
   
 (defmacro equal-hash (object)  
   "Gives us a hashing of an object such that (equal a b) implies  
    (= (equal-hash a) (equal-hash b))"  
   `(values (sxhash ,object) nil))  
   
 )  
   
 (defun %eql-hash (number)  
   (etypecase number  
     (fixnum  
      (logand number most-positive-fixnum))  
     (integer  
      (logand number most-positive-fixnum))  
     (float  
      (%eql-hash (integer-decode-float number)))  
     (ratio  
      (logxor (%eql-hash (numerator number))  
              (%eql-hash (denominator number))))  
     (complex  
      (logxor (%eql-hash (realpart number))  
              (%eql-hash (imagpart number))))))  
   
   
 (defun hash (table object)  
   (ecase (hash-table-kind table)  
     (eq (eq-hash object))  
     (eql (eql-hash object))  
     (equal (equal-hash object))))  
183    
184    
185  ;;; Rehashing functions:  ;;;; Utility functions.
186    
187    (declaim (inline pointer-hash))
188    (defun pointer-hash (key)
189      (declare (values hash))
190      (truly-the hash (%primitive make-fixnum key)))
191    
192    (declaim (inline eq-hash))
193    (defun eq-hash (key)
194      (declare (values hash (member t nil)))
195      (values (pointer-hash key)
196              (oddp (get-lisp-obj-address key))))
197    
198    (declaim (inline eql-hash))
199    (defun eql-hash (key)
200      (declare (values hash (member t nil)))
201      (if (numberp key)
202          (equal-hash key)
203          (eq-hash key)))
204    
205    (declaim (inline equal-hash))
206    (defun equal-hash (key)
207      (declare (values hash (member t nil)))
208      (values (sxhash key) nil))
209    
210    (defun equalp-hash (key)
211      (declare (values hash (member t nil)))
212      (values (internal-equalp-hash key 0) nil))
213    
214    
215  (defun almost-primify (num)  (defun almost-primify (num)
216    (declare (fixnum num))    (declare (type index num))
217    "Almost-Primify returns an almost prime number greater than or equal    "Almost-Primify returns an almost prime number greater than or equal
218     to NUM."     to NUM."
219    (when (zerop (rem num 2))    (if (= (rem num 2) 0)
220      (incf num))        (setq num (+ 1 num)))
221    (when (zerop (rem num 3))    (if (= (rem num 3) 0)
222      (incf num 2))        (setq num (+ 2 num)))
223    (when (zerop (rem num 7))    (if (= (rem num 7) 0)
224      (incf num 4))        (setq num (+ 4 num)))
225    num)    num)
226    
 (defun rehash (table)  
   "Rehashes all the entries in the hash table TABLE.  Must only be called  
    inside a WITHOUT-GCING."  
   (let* ((old-vector (hash-table-table table))  
          (old-length (length old-vector))  
          (rehash-size (hash-table-rehash-size table))  
          (new-length (if (floatp rehash-size)  
                          (ceiling (* rehash-size old-length))  
                          (+ rehash-size old-length)))  
          (new-vector (make-array new-length :initial-element nil)))  
     (declare (type simple-vector old-vector new-vector)  
              (type index old-length new-length))  
     (flet ((reenter-bucket (bucket)  
              (let ((key (hash-table-bucket-key bucket)))  
                (multiple-value-bind  
                    (hashing needs-scav-hook)  
                    (hash table key)  
                  (let ((index (rem hashing new-length))  
                        (value (hash-table-bucket-value bucket)))  
                    (setf (svref new-vector index)  
                          (make-hash-table-bucket table key hashing value  
                                                  (svref new-vector index)  
                                                  needs-scav-hook)))))))  
       (dotimes (i old-length)  
         (do ((bucket (aref old-vector i) (hash-table-bucket-next bucket)))  
             ((null bucket))  
           (reenter-bucket bucket))  
         (setf (aref old-vector i) nil))  
       (dolist (bucket (hash-table-needing-rehash table))  
         (reenter-bucket bucket)))  
     (setf (hash-table-table table) new-vector)  
     (setf (hash-table-needing-rehash table) nil)  
     (when (> new-length old-length)  
       (setf (hash-table-rehash-threshold table) new-length))))  
227    
228  (defun find-bucket (hash-table bucket-list key hashing)  
229    (declare (type hash-table hash-table)  ;;;; User defined hash table tests.
            (type (or hash-table-bucket null) bucket-list)  
            (type hash-value hashing))  
   (flet ((frob (test)  
            (do ((prev nil bucket)  
                 (bucket bucket-list (hash-table-bucket-next bucket)))  
                ((or (null bucket)  
                     (and (= hashing (hash-table-bucket-hash bucket))  
                          (funcall test (hash-table-bucket-key bucket) key)))  
                 (values bucket prev)))))  
     (declare (inline frob))  
     (ecase (hash-table-kind hash-table)  
       (equal (frob #'equal))  
       (eql (frob #'eql))  
       (eq (frob #'eq)))))  
230    
231  (defun flush-needing-rehash (table)  ;;; *HASH-TABLE-TESTS* -- Internal.
232    (declare (type hash-table table))  ;;;
233    (let* ((vector (hash-table-table table))  (defvar *hash-table-tests* nil)
          (length (length vector)))  
     (declare (type simple-vector vector)  
              (type index length))  
     (dolist (bucket (hash-table-needing-rehash table))  
       (declare (type (or null hash-table-bucket) bucket))  
       (let ((index (rem (hash-table-bucket-hash bucket) length)))  
         (declare (type index index))  
         (do ((prev nil ptr)  
              (ptr (svref vector index) (hash-table-bucket-next ptr)))  
             ((or (null bucket) (eq bucket ptr))  
              (unless bucket  
                (error "Can't find the bucket in the hash table.  ~  
                        Something is broken bigtime."))  
              (if prev  
                  (setf (hash-table-bucket-next prev)  
                        (hash-table-bucket-next bucket))  
                  (setf (svref vector index)  
                        (hash-table-bucket-next bucket))))  
           (declare (type (or null hash-table-bucket) prev ptr))))  
       (let* ((key (hash-table-bucket-key bucket))  
              (hashing (hash table key))  
              (index (rem hashing length)))  
         (declare (type hash-value hashing) (type index index))  
         (setf (hash-table-bucket-next bucket) (svref vector index))  
         (setf (svref vector index) bucket)  
         (setf (scavenger-hook-value (hash-table-bucket-scavhook bucket)) key)  
         (setf (hash-table-bucket-hash bucket) hashing))))  
   (setf (hash-table-needing-rehash table) nil))  
234    
235    ;;; DEFINE-HASH-TABLE-TEST -- Public.
236    ;;;
237    (defun define-hash-table-test (name test-fun hash-fun)
238      "Define a new kind of hash table test."
239      (declare (type symbol name)
240               (type function test-fun hash-fun))
241      (setf *hash-table-tests*
242            (cons (list name test-fun hash-fun)
243                  (remove name *hash-table-tests* :test #'eq :key #'car)))
244      name)
245    
246    
247  ;;; Making hash tables:  ;;;; Construction and simple accessors.
248    
249  (defun make-hash-table (&key (test 'eql) (size 65) (rehash-size 101)  ;;; MAKE-HASH-TABLE -- public.
250                               rehash-threshold)  ;;;
251    "Creates and returns a hash table.  See manual for details."  (defun make-hash-table (&key (test 'eql) (size 65) (rehash-size 1.5)
252    (declare (fixnum size))                               (rehash-threshold 1) (weak-p nil))
253    (let* ((test (cond ((eq test #'eq) 'eq)    "Creates and returns a new hash table.  The keywords are as follows:
254                       ((eq test #'eql) 'eql)       :TEST -- Indicates what kind of test to use.  Only EQ, EQL, EQUAL,
255                       ((eq test #'equal) 'equal)         and EQUALP are currently supported.
256                       ((member test '(eq eql equal) :test #'eq)       :SIZE -- A hint as to how many elements will be put in this hash
257                        test)         table.
258                       (t       :REHASH-SIZE -- Indicates how to expand the table when it fills up.
259                        (error "~S is an illegal :Test for hash tables." test))))         If an integer, add space for that many elements.  If a floating
260           (size (if (<= size 37)         point number (which must be greater than 1.0), multiple the size
261                     37         by that amount.
262                     (almost-primify size)))       :REHASH-THRESHOLD -- Indicates how dense the table can become before
263           (rehash-threshold (cond ((null rehash-threshold)         forcing a rehash.  Can be any positive number <= to 1, with density
264                                    size)         approaching zero as the threshold approaches 0.  Density 1 means an
265                                   ((floatp rehash-threshold)         average of one entry per bucket.
266                                    (ceiling (* rehash-threshold size)))     CMUCL Extension:
267                                   (t       :WEAK-P -- If T, don't keep entries if the key would otherwise be
268                                    rehash-threshold))))         garbage."
269    (make-hash-table-structure :rehash-size rehash-size    (declare (type (or function symbol) test)
270                               :rehash-threshold rehash-threshold             (type index size) (type (member t nil) weak-p))
271                               :table (make-array size :initial-element nil)    (let ((rehash-size (if (integerp rehash-size)
272                               :kind test)))                           rehash-size
273                             (float rehash-size 1.0)))
274            (rehash-threshold (float rehash-threshold 1.0)))
275        (multiple-value-bind
276            (test test-fun hash-fun)
277            (cond ((or (eq test #'eq) (eq test 'eq))
278                   (values 'eq #'eq #'eq-hash))
279                  ((or (eq test #'eql) (eq test 'eql))
280                   (values 'eql #'eql #'eql-hash))
281                  ((or (eq test #'equal) (eq test 'equal))
282                   (values 'equal #'equal #'equal-hash))
283                  ((or (eq test #'equalp) (eq test 'equalp))
284                   (values 'equalp #'equalp #'equalp-hash))
285                  (t
286                   (dolist (info *hash-table-tests*
287                                 (error "Unknown :TEST for MAKE-HASH-TABLE: ~S"
288                                        test))
289                     (destructuring-bind
290                      (test-name test-fun hash-fun)
291                      info
292                      (when (or (eq test test-name) (eq test test-fun))
293                        (return (values test-name test-fun hash-fun)))))))
294          (let* ((scaled-size (round (/ (float size) rehash-threshold)))
295                 (length (if (<= scaled-size 37) 37 (almost-primify scaled-size)))
296                 (vector (make-array length :initial-element nil)))
297            (declare (type index scaled-size length)
298                     (type simple-vector vector))
299            (%make-hash-table
300             :test test
301             :test-fun test-fun
302             :hash-fun hash-fun
303             :rehash-size rehash-size
304             :rehash-threshold rehash-threshold
305             :rehash-trigger (round (* (float length) rehash-threshold))
306             :table vector
307             :weak-p weak-p)))))
308    
309    (declaim (inline hash-table-count))
310    (defun hash-table-count (hash-table)
311      "Returns the number of entries in the given HASH-TABLE."
312      (declare (type hash-table hash-table)
313               (values index))
314      (hash-table-number-entries hash-table))
315    
316    (setf (documentation 'hash-table-rehash-size 'function)
317          "Return the rehash-size HASH-TABLE was created with.")
318    
319    (setf (documentation 'hash-table-rehash-threshold 'function)
320          "Return the rehash-threshold HASH-TABLE was created with.")
321    
322    (declaim (inline hash-table-size))
323    (defun hash-table-size (hash-table)
324      "Return a size that can be used with MAKE-HASH-TABLE to create a hash
325       table that can hold however many entries HASH-TABLE can hold without
326       having to be grown."
327      (hash-table-rehash-trigger hash-table))
328    
329    (setf (documentation 'hash-table-test 'function)
330          "Return the test HASH-TABLE was created with.")
331    
332    (setf (documentation 'hash-table-weak-p 'function)
333          "Return T if HASH-TABLE will not keep entries for keys that would
334       otherwise be garbage, and NIL if it will.")
335    
336    
337  ;;; Manipulating hash tables:  ;;;; Accessing functions.
338    
339    ;;; REHASH -- internal.
340    ;;;
341    ;;; Make a new vector for TABLE.  If GROW is NIL, use the same size as before,
342    ;;; otherwise extend the table based on the rehash-size.
343    ;;;
344    (defun rehash (table grow)
345      (declare (type hash-table table))
346      (let* ((old-vector (hash-table-table table))
347             (old-length (length old-vector))
348             (new-length
349              (if grow
350                  (let ((rehash-size (hash-table-rehash-size table)))
351                    (etypecase rehash-size
352                      (fixnum
353                       (+ rehash-size old-length))
354                      (float
355                       (the (values index t) (round (* rehash-size old-length))))))
356                  old-length))
357             (new-vector (make-array new-length :initial-element nil))
358             #-gengc (weak-p (hash-table-weak-p table)))
359        (declare (type index new-length))
360        (dotimes (i old-length)
361          (declare (type index i))
362          (do ((bucket (svref old-vector i) next)
363               (next nil))
364              ((null bucket))
365            (setf next (hash-table-bucket-next bucket))
366            (block deal-with-one-bucket
367              (let* ((hashing
368                      #-gengc
369                      (or (hash-table-bucket-hash bucket)
370                          (let ((key (hash-table-bucket-key bucket)))
371                            (set-header-data new-vector
372                                             vm:vector-valid-hashing-subtype)
373                            (if weak-p
374                                (multiple-value-bind
375                                    (real-key valid)
376                                    (weak-pointer-value key)
377                                  (cond (valid
378                                         (pointer-hash real-key))
379                                        (t
380                                         (decf (hash-table-number-entries table))
381                                         (return-from deal-with-one-bucket nil))))
382                                (pointer-hash key))))
383                      #+gengc (hash-table-bucket-hash bucket))
384                     (index (rem hashing new-length)))
385                (declare (type index hashing index))
386                (setf (hash-table-bucket-next bucket) (svref new-vector index))
387                (setf (svref new-vector index) bucket))))
388          ;; We clobber the old vector contents so that if it is living in
389          ;; static space it won't keep ahold of pointers into dynamic space.
390          (setf (svref old-vector i) nil))
391        (setf (hash-table-table table) new-vector)
392        (unless (= new-length old-length)
393          (setf (hash-table-rehash-trigger table)
394                (round (* (hash-table-rehash-threshold table)
395                          (float new-length))))))
396      (undefined-value))
397    
398    #+gengc
399    (defun flush-needing-rehash (table)
400      (let* ((weak-p (hash-table-weak-p table))
401             (vector (hash-table-table table))
402             (length (length vector)))
403        (do ((bucket (hash-table-needing-rehash table) next)
404             (next nil))
405            ((null bucket))
406          (setf next (hash-table-bucket-next bucket))
407          (flet ((relink-bucket (key)
408                   (let* ((hashing (pointer-hash key))
409                          (index (rem hashing length)))
410                     (setf (hash-table-bucket-hash bucket) hashing)
411                     (setf (hash-table-bucket-next bucket) (svref vector index))
412                     (setf (svref vector index) bucket)
413                     (setf (hash-table-eq-bucket-linked bucket) t))))
414            (let ((key (hash-table-bucket-key bucket)))
415              (if weak-p
416                  (multiple-value-bind
417                      (real-key valid)
418                      (weak-pointer-value key)
419                    (if valid
420                        (relink-bucket real-key)
421                        (decf (hash-table-number-entries table))))
422                  (relink-bucket key))))))
423      (setf (hash-table-needing-rehash table) nil)
424      (undefined-value))
425    
426    ;;; GETHASH -- Public.
427    ;;;
428  (defun gethash (key hash-table &optional default)  (defun gethash (key hash-table &optional default)
429    "Finds the entry in Hash-Table whose key is Key and returns the associated    "Finds the entry in HASH-TABLE whose key is KEY and returns the associated
430     value and T as multiple values, or returns Default and Nil if there is no     value and T as multiple values, or returns DEFAULT and NIL if there is no
431     such entry."     such entry.  Entries can be added using SETF."
432      (declare (type hash-table hash-table)
433               (values t (member t nil)))
434    (without-gcing    (without-gcing
435      (when (hash-table-needing-rehash hash-table)     #-gengc
436        (flush-needing-rehash hash-table))     (when (= (get-header-data (hash-table-table hash-table))
437      (let* ((vector (hash-table-table hash-table))              vm:vector-must-rehash-subtype)
438             (size (length vector))       (rehash hash-table nil))
439             (hashing (hash hash-table key))     #+gengc
440             (index (rem hashing size))     (when (hash-table-needing-rehash hash-table)
441             (bucket (find-bucket hash-table (svref vector index) key hashing)))       (flush-needing-rehash hash-table))
442        (if bucket     (multiple-value-bind
443            (values (hash-table-bucket-value bucket) t)         (hashing eq-based)
444            (values default nil)))))         (funcall (hash-table-hash-fun hash-table) key)
445         (let* ((vector (hash-table-table hash-table))
446                (length (length vector))
447                (index (rem hashing length)))
448           (declare (type index hashing))
449           (if eq-based
450               (if (hash-table-weak-p hash-table)
451                   (do ((bucket (svref vector index)
452                                (hash-table-bucket-next bucket)))
453                       ((null bucket) (values default nil))
454                     (when #+gengc (hash-table-eq-bucket-p bucket)
455                           #-gengc (null (hash-table-bucket-hash bucket))
456                       (multiple-value-bind
457                           (bucket-key valid)
458                           (weak-pointer-value (hash-table-bucket-key bucket))
459                         (assert valid)
460                         (when (eq key bucket-key)
461                           (return (values (hash-table-bucket-value bucket) t))))))
462                   (do ((bucket (svref vector index)
463                                (hash-table-bucket-next bucket)))
464                       ((null bucket) (values default nil))
465                     (when (eq key (hash-table-bucket-key bucket))
466                       (return (values (hash-table-bucket-value bucket) t)))))
467               (do ((test-fun (hash-table-test-fun hash-table))
468                    (bucket (svref vector index) (hash-table-bucket-next bucket)))
469                   ((null bucket) (values default nil))
470                 (let ((bucket-hashing (hash-table-bucket-hash bucket)))
471                   (when (and #-gengc bucket-hashing
472                              (= bucket-hashing hashing)
473                              #+gengc (not (hash-table-eq-bucket-p bucket))
474                              (funcall test-fun key
475                                       (hash-table-bucket-key bucket)))
476                     (return (values (hash-table-bucket-value bucket) t))))))))))
477    
478    
479    #+gengc
480    (defun get-hash-table-scavenger-hook (hash-table bucket)
481      (declare (type hash-table hash-table)
482               (type hash-table-eq-bucket bucket))
483      (flet ((hash-table-scavenger-hook ()
484               (when (hash-table-eq-bucket-linked bucket)
485                 (let* ((vector (hash-table-table hash-table))
486                        (length (length vector))
487                        (index (rem (hash-table-eq-bucket-hash bucket) length)))
488                   (declare (type index index))
489                   (do ((prev nil next)
490                        (next (svref vector index) (hash-table-bucket-next next)))
491                       ((null next)
492                        (warn "Couldn't find where ~S was linked inside ~S"
493                              bucket hash-table))
494                     (when (eq next bucket)
495                       (if prev
496                           (setf (hash-table-bucket-next prev)
497                                 (hash-table-bucket-next bucket))
498                           (setf (svref vector index)
499                                 (hash-table-bucket-next bucket)))
500                       (setf (hash-table-eq-bucket-linked bucket) nil)
501                       (return)))
502                   (if (and (hash-table-weak-p hash-table)
503                            (not (nth-value 1
504                                            (weak-pointer-value
505                                             (hash-table-bucket-key bucket)))))
506                       (decf (hash-table-number-entries hash-table))
507                       (setf (hash-table-bucket-next bucket)
508                               (hash-table-needing-rehash hash-table)
509                             (hash-table-needing-rehash hash-table)
510                               bucket))))))
511        #'hash-table-scavenger-hook))
512    
513    ;;; So people can call #'(setf gethash).
514    ;;;
515    (defun (setf gethash) (new-value key table &optional default)
516      (declare (ignore default))
517      (%puthash key table new-value))
518    
519    ;;; %PUTHASH -- public setf method.
520    ;;;
521  (defun %puthash (key hash-table value)  (defun %puthash (key hash-table value)
522    "Create an entry in HASH-TABLE associating KEY with VALUE; if there already    (declare (type hash-table hash-table))
    is an entry for KEY, replace it.  Returns VALUE."  
523    (without-gcing    (without-gcing
524      (cond ((> (hash-table-number-entries hash-table)     (let ((entries (1+ (hash-table-number-entries hash-table))))
525                (hash-table-rehash-threshold hash-table))       (setf (hash-table-number-entries hash-table) entries)
526             (rehash hash-table))       (cond ((> entries (hash-table-rehash-trigger hash-table))
527            ((hash-table-needing-rehash hash-table)              (rehash hash-table t))
528             (flush-needing-rehash hash-table)))             #-gengc
529      (let* ((vector (hash-table-table hash-table))             ((= (get-header-data (hash-table-table hash-table))
530             (size (length vector)))                 vm:vector-must-rehash-subtype)
531        (multiple-value-bind (hashing scav-hook-p) (hash hash-table key)              (rehash hash-table nil))))
532          (let* ((index (rem hashing size))     #+gengc
533                 (bucket (find-bucket hash-table (svref vector index)     (when (hash-table-needing-rehash hash-table)
534                                      key hashing)))       (flush-needing-rehash hash-table))
535            (if bucket     (multiple-value-bind
536                (setf (hash-table-bucket-value bucket) value)         (hashing eq-based)
537                (setf (svref vector index)         (funcall (hash-table-hash-fun hash-table) key)
538                      (make-hash-table-bucket hash-table key hashing value       (declare (type hash hashing))
539                                              (svref vector index)       (let* ((vector (hash-table-table hash-table))
540                                              scav-hook-p)))))))              (length (length vector))
541                (index (rem hashing length))
542                (first-bucket (svref vector index)))
543           (declare (type index index))
544           (block scan
545             (if eq-based
546                 (if (hash-table-weak-p hash-table)
547                     (do ((bucket first-bucket (hash-table-bucket-next bucket)))
548                         ((null bucket))
549                       (when #+gengc (hash-table-eq-bucket-p bucket)
550                             #-gengc (null (hash-table-bucket-hash bucket))
551                         (multiple-value-bind
552                             (bucket-key valid)
553                             (weak-pointer-value (hash-table-bucket-key bucket))
554                           (assert valid)
555                           (when (eq key bucket-key)
556                             (setf (hash-table-bucket-value bucket) value)
557                             (decf (hash-table-number-entries hash-table))
558                             (return-from scan nil)))))
559                     (do ((bucket first-bucket (hash-table-bucket-next bucket)))
560                         ((null bucket))
561                       (when (eq key (hash-table-bucket-key bucket))
562                         (setf (hash-table-bucket-value bucket) value)
563                         (decf (hash-table-number-entries hash-table))
564                         (return-from scan nil))))
565                 (do ((test-fun (hash-table-test-fun hash-table))
566                      (bucket first-bucket (hash-table-bucket-next bucket)))
567                     ((null bucket))
568                   (let ((bucket-hashing (hash-table-bucket-hash bucket)))
569                     (when (and #-gengc bucket-hashing
570                                (= bucket-hashing hashing)
571                                #+gengc (not (hash-table-eq-bucket-p bucket))
572                                (funcall test-fun
573                                         key
574                                         (hash-table-bucket-key bucket)))
575                       (setf (hash-table-bucket-value bucket) value)
576                       (decf (hash-table-number-entries hash-table))
577                       (return-from scan nil)))))
578             #-gengc
579             (when eq-based
580               (set-header-data vector vm:vector-valid-hashing-subtype))
581             (setf (svref vector index)
582                   #-gengc
583                   (if eq-based
584                       (make-hash-table-bucket
585                        :hash nil
586                        :key (if (hash-table-weak-p hash-table)
587                                 (make-weak-pointer key)
588                                 key)
589                        :value value
590                        :next first-bucket)
591                       (make-hash-table-bucket
592                        :hash hashing
593                        :key key
594                        :value value
595                        :next first-bucket))
596                   #+gengc
597                   (if eq-based
598                       (let ((bucket (make-hash-table-eq-bucket
599                                      :hash hashing
600                                      :key (if (hash-table-weak-p hash-table)
601                                               (make-weak-pointer key)
602                                               key)
603                                      :value value
604                                      :next first-bucket
605                                      :linked t)))
606                         (setf (hash-table-eq-bucket-scavhook bucket)
607                               (make-scavenger-hook
608                                :value key
609                                :function (get-hash-table-scavenger-hook
610                                           hash-table bucket)))
611                         bucket)
612                       (make-hash-table-bucket
613                        :hash hashing
614                        :key key
615                        :value value
616                        :next first-bucket)))))))
617    value)    value)
618    
619    ;;; REMHASH -- public.
620    ;;;
621  (defun remhash (key hash-table)  (defun remhash (key hash-table)
622    "Remove any entry for KEY in HASH-TABLE.  Returns T if such an entry    "Remove the entry in HASH-TABLE associated with KEY.  Returns T if there
623     existed, and NIL if not."     was such an entry, and NIL if not."
624      (declare (type hash-table hash-table)
625               (values (member t nil)))
626    (without-gcing    (without-gcing
627      (when (hash-table-needing-rehash hash-table)     #-gengc
628        (flush-needing-rehash hash-table))     (when (= (get-header-data (hash-table-table hash-table))
629      (let* ((vector (hash-table-table hash-table))              vm:vector-must-rehash-subtype)
630             (size (length vector))       (rehash hash-table nil))
631             (hashing (hash hash-table key))     #+gengc
632             (index (rem hashing size)))     (when (hash-table-needing-rehash hash-table)
633        (multiple-value-bind       (flush-needing-rehash hash-table))
634            (bucket prev)     (multiple-value-bind
635            (find-bucket hash-table (svref vector index) key hashing)         (hashing eq-based)
636          (when bucket         (funcall (hash-table-hash-fun hash-table) key)
637            (if prev       (let* ((vector (hash-table-table hash-table))
638                (setf (hash-table-bucket-next prev)              (length (length vector))
639                      (hash-table-bucket-next bucket))              (index (rem hashing length)))
640                (setf (svref vector index)         (declare (type index hashing index))
641                      (hash-table-bucket-next bucket)))         (if eq-based
642            (decf (hash-table-number-entries hash-table))             (if (hash-table-weak-p hash-table)
643            t)))))                 (do ((prev nil bucket)
644                        (bucket (svref vector index)
645                                (hash-table-bucket-next bucket)))
646                       ((null bucket) nil)
647                     (when #+gengc (hash-table-eq-bucket-p bucket)
648                           #-gengc (null (hash-table-bucket-hash bucket))
649                       (multiple-value-bind
650                           (bucket-key valid)
651                           (weak-pointer-value (hash-table-bucket-key bucket))
652                         (assert valid)
653                         (when (eq key bucket-key)
654                           #+gengc
655                           (setf (hash-table-eq-bucket-linked bucket) nil)
656                           (if prev
657                               (setf (hash-table-bucket-next prev)
658                                     (hash-table-bucket-next bucket))
659                               (setf (svref vector index)
660                                     (hash-table-bucket-next bucket)))
661                           (decf (hash-table-number-entries hash-table))
662                           (return t)))))
663                   (do ((prev nil bucket)
664                        (bucket (svref vector index)
665                                (hash-table-bucket-next bucket)))
666                       ((null bucket) nil)
667                     (when (eq key (hash-table-bucket-key bucket))
668                       #+gengc
669                       (setf (hash-table-eq-bucket-linked bucket) nil)
670                       (if prev
671                           (setf (hash-table-bucket-next prev)
672                                 (hash-table-bucket-next bucket))
673                           (setf (svref vector index)
674                                 (hash-table-bucket-next bucket)))
675                       (decf (hash-table-number-entries hash-table))
676                       (return t))))
677               (do ((test-fun (hash-table-test-fun hash-table))
678                    (prev nil bucket)
679                    (bucket (svref vector index)
680                            (hash-table-bucket-next bucket)))
681                   ((null bucket) nil)
682                 (let ((bucket-hashing (hash-table-bucket-hash bucket)))
683                   (when (and #-gengc bucket-hashing
684                              (= bucket-hashing hashing)
685                              #+gengc (not (hash-table-eq-bucket-p bucket))
686                              (funcall test-fun key
687                                       (hash-table-bucket-key bucket)))
688                     (if prev
689                         (setf (hash-table-bucket-next prev)
690                               (hash-table-bucket-next bucket))
691                         (setf (svref vector index)
692                               (hash-table-bucket-next bucket)))
693                     (decf (hash-table-number-entries hash-table))
694                     (return t)))))))))
695    
696    
697  (defun maphash (map-function hash-table)  ;;; CLRHASH -- public.
698    "For each entry in HASH-TABLE, calls MAP-FUNCTION on the key and value  ;;;
   of the entry; returns T."  
   (let ((vector (hash-table-table hash-table)))  
     (declare (simple-vector vector))  
     (dotimes (index (length vector))  
       (do ((bucket (aref vector index) (hash-table-bucket-next bucket)))  
           ((null bucket))  
         (funcall map-function  
                  (hash-table-bucket-key bucket)  
                  (hash-table-bucket-value bucket))))))  
   
699  (defun clrhash (hash-table)  (defun clrhash (hash-table)
700    "Removes all entries of HASH-TABLE and returns the hash table itself."    "This removes all the entries from HASH-TABLE and returns the hash table
701    (declare (type hash-table hash-table))     itself."
702    (let ((vector (hash-table-table hash-table)))    (let ((vector (hash-table-table hash-table)))
     (declare (simple-vector vector))  
     (setf (hash-table-number-entries hash-table) 0)  
703      (dotimes (i (length vector))      (dotimes (i (length vector))
704        (setf (svref vector i) nil))        #+gengc
705      (setf (hash-table-needing-rehash hash-table) nil))        (do ((bucket (aref vector i) (hash-table-bucket-next bucket)))
706              ((null bucket))
707            (when (hash-table-eq-bucket-p bucket)
708              (setf (hash-table-eq-bucket-linked bucket) nil)))
709          (setf (aref vector i) nil))
710        (setf (hash-table-number-entries hash-table) 0)
711        #-gengc
712        (set-header-data vector vm:vector-normal-subtype))
713    hash-table)    hash-table)
714    
715  (defun hash-table-count (hash-table)  
716    "Returns the number of entries in the given Hash-Table."  
717    (hash-table-number-entries hash-table))  ;;;; MAPHASH and WITH-HASH-TABLE-ITERATOR
718    
719    (declaim (maybe-inline maphash))
720    (defun maphash (map-function hash-table)
721      "For each entry in HASH-TABLE, calls MAP-FUNCTION on the key and value
722       of the entry; returns NIL."
723      (declare (type (or function symbol) map-function)
724               (type hash-table hash-table))
725      (let ((fun (etypecase map-function
726                   (function
727                    map-function)
728                   (symbol
729                    (symbol-function map-function))))
730            (vector (hash-table-table hash-table)))
731        (declare (type function fun))
732        (if (hash-table-weak-p hash-table)
733            (dotimes (i (length vector))
734              (declare (type index i))
735              (do ((bucket (svref vector i) (hash-table-bucket-next bucket)))
736                  ((null bucket))
737                (if #-gengc (null (hash-table-bucket-hash bucket))
738                    #+gengc (hash-table-eq-bucket-p bucket)
739                    (let ((weak-pointer (hash-table-bucket-key bucket)))
740                      (multiple-value-bind
741                          (key valid)
742                          (weak-pointer-value weak-pointer)
743                        (when valid
744                          (funcall fun key (hash-table-bucket-value bucket)))))
745                    (funcall fun
746                             (hash-table-bucket-key bucket)
747                             (hash-table-bucket-value bucket)))))
748            (dotimes (i (length vector))
749              (declare (type index i))
750              (do ((bucket (svref vector i) (hash-table-bucket-next bucket)))
751                  ((null bucket))
752                (funcall fun
753                         (hash-table-bucket-key bucket)
754                         (hash-table-bucket-value bucket)))))))
755    
756    
757    (defmacro with-hash-table-iterator ((function hash-table) &body body)
758      "WITH-HASH-TABLE-ITERATOR ((function hash-table) &body body)
759       provides a method of manually looping over the elements of a hash-table.
760       function is bound to a generator-macro that, withing the scope of the
761       invocation, returns three values.  First, whether there are any more objects
762       in the hash-table, second, the key, and third, the value."
763      (let ((n-function (gensym "WITH-HASH-TABLE-ITERRATOR-")))
764        `(let ((,n-function
765                (let* ((table ,hash-table)
766                       (weak-p (hash-table-weak-p ,hash-table))
767                       (vector (hash-table-table table))
768                       (length (length vector))
769                       (index 0)
770                       (bucket (svref vector 0)))
771                  (labels
772                      ((,function ()
773                         (cond
774                          (bucket
775                           (let ((orig bucket))
776                             (setf bucket (hash-table-bucket-next orig))
777                             (if (and weak-p
778                                      #-gengc (null (hash-table-bucket-hash orig))
779                                      #+gengc (hash-table-eq-bucket-p orig))
780                                 (multiple-value-bind
781                                     (key valid)
782                                     (weak-pointer-value
783                                      (hash-table-bucket-key orig))
784                                   (if valid
785                                       (values t
786                                               key
787                                               (hash-table-bucket-value orig))
788                                       (,function)))
789                                 (values t
790                                         (hash-table-bucket-key orig)
791                                         (hash-table-bucket-value orig)))))
792                          ((= (incf index) length)
793                           (values nil))
794                          (t
795                           (setf bucket (svref vector index))
796                           (,function)))))
797                    #',function))))
798           (macrolet ((,function () '(funcall ,n-function)))
799             ,@body))))
800    
801    
802    
803  ;;; Primitive Hash Function  ;;;; SXHASH and support functions
804    
805  ;;; The maximum length and depth to which we hash lists.  ;;; The maximum length and depth to which we hash lists.
806  (defconstant sxhash-max-len 7)  (defconstant sxhash-max-len 7)
# Line 352  Line 808 
808    
809  (eval-when (compile eval)  (eval-when (compile eval)
810    
811  (defconstant sxhash-bits-byte (byte 23 0))  (defconstant sxhash-bits-byte (byte 29 0))
812  (defconstant sxmash-total-bits 26)  (defconstant sxmash-total-bits 29)
813  (defconstant sxmash-rotate-bits 7)  (defconstant sxmash-rotate-bits 9)
814    
815  (defmacro sxmash (place with)  (defmacro sxmash (place with)
816    (let ((n-with (gensym)))    `(setf ,place
817      `(let ((,n-with ,with))           (logxor (truly-the hash
818         (declare (fixnum ,n-with))                              (ash ,place
819         (setf ,place                                   ,(- sxmash-rotate-bits sxmash-total-bits)))
820               (logxor (ash ,n-with ,(- sxmash-rotate-bits sxmash-total-bits))                   (truly-the hash
821                       (ash (logand ,n-with                              (ash (logand
822                                      ,place
823                                    ,(1- (ash 1                                    ,(1- (ash 1
824                                              (- sxmash-total-bits                                              (- sxmash-total-bits
825                                                 sxmash-rotate-bits))))                                                 sxmash-rotate-bits))))
826                            ,sxmash-rotate-bits)                                   ,sxmash-rotate-bits))
827                       (the fixnum ,place))))))                   (truly-the hash ,with))))
828    
829  (defmacro sxhash-simple-string (sequence)  (defmacro sxhash-simple-string (sequence)
830    `(%sxhash-simple-string ,sequence))    `(%sxhash-simple-string ,sequence))
# Line 376  Line 833 
833    (let ((data (gensym))    (let ((data (gensym))
834          (start (gensym))          (start (gensym))
835          (end (gensym)))          (end (gensym)))
836      `(with-array-data ((,data ,sequence)      `(with-array-data ((,data (the (values string &rest t) ,sequence))
837                         (,start)                         (,start)
838                         (,end))                         (,end))
839         (if (zerop ,start)         (if (zerop ,start)
840             (%sxhash-simple-substring ,data ,end)             (%sxhash-simple-substring ,data ,end)
841             (sxhash-simple-string (coerce (the string ,sequence)             (sxhash-simple-string (coerce (the (values string &rest t)
842                                                  ,sequence)
843                                           'simple-string))))))                                           'simple-string))))))
844    
845  (defmacro sxhash-list (sequence depth)  (defmacro sxhash-list (sequence depth &key (equalp nil))
846    `(if (= ,depth sxhash-max-depth)    `(if (= ,depth sxhash-max-depth)
847         0         0
848         (do ((sequence ,sequence (cdr (the list sequence)))         (do ((sequence ,sequence (cdr (the list sequence)))
849              (index 0 (1+ index))              (index 0 (1+ index))
850              (hash 2))              (hash 2)
851                (,depth (1+ ,depth)))
852             ((or (atom sequence) (= index sxhash-max-len)) hash)             ((or (atom sequence) (= index sxhash-max-len)) hash)
853           (declare (fixnum hash index))           (declare (fixnum hash index))
854           (sxmash hash (internal-sxhash (car sequence) (1+ ,depth))))))           (sxmash hash (,(if equalp 'internal-equalp-hash 'internal-sxhash)
855                            (car sequence) ,depth)))))
856    
857    (defmacro sxhash-bit-vector (vector)
858      `(let* ((length (length ,vector))
859              (hash length))
860         (declare (type index length) (type hash hash))
861         (dotimes (index (min length sxhash-max-len) hash)
862           (declare (type index index))
863           (sxmash hash (bit ,vector index)))))
864    
865  ); eval-when (compile eval)  ); eval-when (compile eval)
866    
867    
 (defun sxhash (s-expr)  
   "Computes a hash code for S-EXPR and returns it as an integer."  
   (internal-sxhash s-expr 0))  
   
   
868  (defun internal-sxhash (s-expr depth)  (defun internal-sxhash (s-expr depth)
869      (declare (type index depth) (values hash))
870    (typecase s-expr    (typecase s-expr
871      ;; The pointers and immediate types.      ;; The pointers and immediate types.
872      (list (sxhash-list s-expr depth))      (list (sxhash-list s-expr depth))
873      (fixnum      (fixnum (ldb sxhash-bits-byte s-expr))
874       (ldb sxhash-bits-byte s-expr))      (character (char-code (char-upcase s-expr)))
875      (structure      (instance
876       (internal-sxhash (type-of s-expr) depth))       (if (typep s-expr 'structure-object)
877             (internal-sxhash (%class-name (layout-class (%instance-layout s-expr)))
878                              depth)
879             (sxhash-instance s-expr)))
880        (funcallable-instance (sxhash-instance s-expr))
881      ;; Other-pointer types.      ;; Other-pointer types.
882      (simple-string (sxhash-simple-string s-expr))      (simple-string (sxhash-simple-string s-expr))
883      (symbol (sxhash-simple-string (symbol-name s-expr)))      (symbol (sxhash-simple-string (symbol-name s-expr)))
# Line 420  Line 887 
887         (single-float         (single-float
888          (let ((bits (single-float-bits s-expr)))          (let ((bits (single-float-bits s-expr)))
889            (ldb sxhash-bits-byte            (ldb sxhash-bits-byte
890                 (logxor (ash bits (- sxmash-rotate-bits))                 (logxor (ash bits (- sxmash-rotate-bits)) bits))))
                        bits))))  
891         (double-float         (double-float
892          (let* ((val s-expr)          (let ((lo (double-float-low-bits s-expr))
893                 (lo (double-float-low-bits val))                (hi (double-float-high-bits s-expr)))
894                 (hi (double-float-high-bits val)))            (ldb sxhash-bits-byte
895                   (logxor (ash lo (- sxmash-rotate-bits)) lo
896                           (ldb sxhash-bits-byte
897                                (logxor (ash hi (- sxmash-rotate-bits)) hi))))))
898           #+long-float
899           (long-float
900            (let ((lo (long-float-low-bits s-expr))
901                  #+sparc (mid (long-float-mid-bits s-expr))
902                  (hi (long-float-high-bits s-expr))
903                  (exp (long-float-exp-bits s-expr)))
904            (ldb sxhash-bits-byte            (ldb sxhash-bits-byte
905                 (logxor (ash lo (- sxmash-rotate-bits))                 (logxor (ash lo (- sxmash-rotate-bits)) lo
906                         (ash hi (- sxmash-rotate-bits))                         #+sparc (ash mid (- sxmash-rotate-bits)) #+sparc mid
907                         lo hi))))                         (ash hi (- sxmash-rotate-bits)) hi
908         (ratio (the fixnum (+ (internal-sxhash (numerator s-expr) 0)                         (ldb sxhash-bits-byte
909                               (internal-sxhash (denominator s-expr) 0))))                              (logxor (ash exp (- sxmash-rotate-bits)) exp))))))
910         (complex (the fixnum (+ (internal-sxhash (realpart s-expr) 0)         (ratio (logxor (internal-sxhash (numerator s-expr) 0)
911                                 (internal-sxhash (imagpart s-expr) 0))))))                        (internal-sxhash (denominator s-expr) 0)))
912           (complex (logxor (internal-sxhash (realpart s-expr) 0)
913                            (internal-sxhash (imagpart s-expr) 0)))))
914      (array      (array
915       (typecase s-expr       (typecase s-expr
916         (string (sxhash-string s-expr))         (string (sxhash-string s-expr))
917           (simple-bit-vector (sxhash-bit-vector
918                               (truly-the simple-bit-vector s-expr)))
919           (bit-vector (sxhash-bit-vector (truly-the bit-vector s-expr)))
920         (t (array-rank s-expr))))         (t (array-rank s-expr))))
921      ;; Everything else.      ;; Everything else.
922      (t 42)))      (t 42)))
923    
924    (defun sxhash (s-expr)
925      "Computes a hash code for S-EXPR and returns it as an integer."
926      (internal-sxhash s-expr 0))
927    
928    
929  ;;;; WITH-HASH-TABLE-ITERATOR  ;;;; Equalp hash.
930    
931  (defmacro with-hash-table-iterator ((function hash-table) &body body)  (eval-when (compile eval)
932    "WITH-HASH-TABLE-ITERATOR ((function hash-table) &body body)  
933     provides a method of manually looping over the elements of a hash-table.  (defmacro hash-table-equalp-hash (table)
934     function is bound to a generator-macro that, withing the scope of the    `(let ((hash (hash-table-count ,table)))
935     invocation, returns three values.  First, whether there are any more objects       (declare (type hash hash))
936     in the hash-table, second, the key, and third, the value."       (sxmash hash (sxhash (hash-table-test ,table)))
937    (let ((counter (gensym))       hash))
938          (bucket (gensym))  
939          (table (gensym))  (defmacro structure-equalp-hash (structure depth)
940          (size (gensym)))    `(if (= ,depth sxhash-max-depth)
941      `(let* ((,table (hash-table-table ,hash-table))         0
942              (,size (length ,table))         (let* ((layout (%instance-layout ,structure))
943              (,counter 0)                (length (min (1- (layout-length layout)) sxhash-max-len))
944              (,bucket (svref ,table 0)))                (hash (internal-sxhash (%class-name (layout-class layout))
945         (declare (type index ,counter ,size)                                       depth))
946                  (type simple-vector ,table)                (,depth (+ ,depth 1)))
947                  (type (or null hash-table-bucket) ,bucket))           (declare (type index length) (type hash hash))
948         (macrolet ((,function ()           (do ((index 1 (1+ index)))
949                       `(loop               ((= index length) hash)
950                          (when (= ,',counter ,',size)             (declare (type index index))
951                            (return))             (sxmash hash (internal-equalp-hash
952                          (if ,',bucket                           (%instance-ref ,structure index) ,depth))))))
953                              (return  
954                               (multiple-value-prog1  (defmacro vector-equalp-hash (vector depth)
955                                   (values t    `(if (= ,depth sxhash-max-depth)
956                                           (hash-table-bucket-key ,',bucket)         0
957                                           (hash-table-bucket-value ,',bucket))         (let* ((length (length ,vector))
958                                 (setf ,',bucket                (hash length)
959                                       (hash-table-bucket-next ,',bucket))))                (,depth (+ ,depth 1)))
960                              (setf ,',bucket           (declare (type index length) (type hash hash))
961                                    (svref ,table (incf ,',counter)))))))           (dotimes (index (min length sxhash-max-len) hash)
962           ,@body))))             (declare (type index index))
963               (sxmash hash (internal-equalp-hash (aref ,vector index) ,depth))))))
964    
965    (defmacro array-equalp-hash (array depth)
966      `(if (= ,depth sxhash-max-depth)
967           0
968           (let* ((size (array-total-size ,array))
969                  (hash size)
970                  (,depth (+ ,depth 1)))
971             (declare (type hash hash))
972             (dotimes (index (min sxhash-max-len size) hash)
973               (sxmash hash (internal-equalp-hash
974                             (row-major-aref ,array index) ,depth))))))
975    
976    ); eval-when (compile eval)
977    
978    
979    (defun internal-equalp-hash (s-expr depth)
980      (declare (type index depth) (values hash))
981      (typecase s-expr
982        ;; The pointers and immediate types.
983        (list (sxhash-list s-expr depth :equalp t))
984        (fixnum (ldb sxhash-bits-byte s-expr))
985        (character (char-code (char-upcase s-expr)))
986        (instance
987         (typecase s-expr
988           (hash-table (hash-table-equalp-hash s-expr))
989           (structure-object (structure-equalp-hash s-expr depth))
990           (t 42)))
991        ;; Other-pointer types.
992        (simple-string (vector-equalp-hash (truly-the simple-string s-expr) depth))
993        (symbol (sxhash-simple-string (symbol-name s-expr)))
994        (number
995         (etypecase s-expr
996           (integer (sxhash s-expr))
997           (float
998            (macrolet ((frob (val type)
999                         (let ((lo (coerce most-negative-fixnum type))
1000                               (hi (coerce most-positive-fixnum type)))
1001                           `(if (<= ,lo ,val ,hi)
1002                                (multiple-value-bind (q r)
1003                                    (truncate ,val)
1004                                  (if (zerop r)
1005                                      (sxhash q)
1006                                      (sxhash (coerce ,val 'long-float))))
1007                                (multiple-value-bind (q r)
1008                                    (truncate ,val)
1009                                  (if (zerop r)
1010                                      (sxhash q)
1011                                      (sxhash (coerce ,val 'long-float))))))))
1012              (etypecase s-expr
1013                (single-float (frob s-expr single-float))
1014                (double-float (frob s-expr double-float))
1015                #+long-float (long-float (frob s-expr long-float)))))
1016           (ratio
1017            (let ((float (coerce s-expr 'long-float)))
1018              (if (= float s-expr)
1019                  (sxhash float)
1020                  (sxhash s-expr))))
1021           (complex (if (zerop (imagpart s-expr))
1022                        (internal-equalp-hash (realpart s-expr) 0)
1023                        (logxor (internal-equalp-hash (realpart s-expr) 0)
1024                                (internal-equalp-hash (realpart s-expr) 0))))))
1025        (array
1026         (typecase s-expr
1027           (simple-vector (vector-equalp-hash (truly-the simple-vector s-expr) depth))
1028           (vector (vector-equalp-hash s-expr depth))
1029           (t (array-equalp-hash s-expr depth))))
1030        ;; Everything else.
1031        (t 42)))
1032    
1033    
1034    ;;;; Dumping one as a constant.
1035    
1036    (defun make-hash-table-load-form (table)
1037      (values
1038       `(make-hash-table
1039         :test ',(hash-table-test table) :size ',(hash-table-size table)
1040         :rehash-size ',(hash-table-rehash-size table)
1041         :rehash-threshold ',(hash-table-rehash-threshold table))
1042       (let ((values nil))
1043         (declare (inline maphash))
1044         (maphash #'(lambda (key value)
1045                      (push (cons key value) values))
1046                  table)
1047         (if values
1048             `(stuff-hash-table ,table ',values)
1049             nil))))
1050    
1051    (defun stuff-hash-table (table alist)
1052      (dolist (x alist)
1053        (setf (gethash (car x) table) (cdr x))))

Legend:
Removed from v.1.9.2.5  
changed lines
  Added in v.1.45

  ViewVC Help
Powered by ViewVC 1.1.5