/[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.21.1.1 by ram, Wed Feb 10 22:42:03 1993 UTC revision 1.21.1.2 by ram, Tue Feb 16 14:17:10 1993 UTC
# Line 52  Line 52 
52    ;;    ;;
53    ;; How much to grow the hash table by when it fills up.  If an index, then    ;; How much to grow the hash table by when it fills up.  If an index, then
54    ;; add that amount.  If a floating point number, then multiple it by that.    ;; add that amount.  If a floating point number, then multiple it by that.
55    (rehash-size (required-argument) :type (or index (float (1.0))) :read-only t)    (rehash-size (required-argument) :type (or index (single-float (1.0)))
56                   :read-only t)
57    ;;    ;;
58    ;; How full the hash table has to get before we rehash.    ;; How full the hash table has to get before we rehash.
59    (rehash-threshold (required-argument) :type (real 0 1) :read-only t)    (rehash-threshold (required-argument) :type (single-float (0.0) 1.0)
60                        :read-only t)
61    ;;    ;;
62    ;; (* rehash-threshold (length table)), saved here so we don't have to keep    ;; (* rehash-threshold (length table)), saved here so we don't have to keep
63    ;; recomputing it.    ;; recomputing it.
# Line 68  Line 70 
70    (table (required-argument) :type simple-vector))    (table (required-argument) :type simple-vector))
71  ;;;  ;;;
72  (defun %print-hash-table (ht stream depth)  (defun %print-hash-table (ht stream depth)
73    (declare (ignore depth))    (declare (ignore depth) (stream stream))
74    (print-unreadable-object (ht stream :identity t)    (print-unreadable-object (ht stream :identity t)
75      (format stream "~A hash table, ~D entr~@:P"      (format stream "~A hash table, ~D entr~@:P"
76              (symbol-name (hash-table-test ht))              (symbol-name (hash-table-test ht))
# Line 170  Line 172 
172         point number (which must be greater than 1.0), multiple the size         point number (which must be greater than 1.0), multiple the size
173         by that amount.         by that amount.
174       :REHASH-THRESHOLD -- Indicates how dense the table can become before       :REHASH-THRESHOLD -- Indicates how dense the table can become before
175         forcing a rehash.  Can be any real number between 0 and 1 (inclusive)."         forcing a rehash.  Can be any positive number <= to 1, with density
176           approaching zero as the threshold approaches 0.  Density 1 means an
177           average of one entry per bucket."
178    (declare (type (or function (member eq eql equal)) test)    (declare (type (or function (member eq eql equal)) test)
179             (type index size)             (type index size))
180             (type (or index (float (1.0))) rehash-size)    (let ((rehash-size (if (integerp rehash-size)
181             (type (real 0 1) rehash-threshold))                           rehash-size
182    (multiple-value-bind                           (float rehash-size 1.0)))
183        (test test-fun hash-fun)          (rehash-threshold (float rehash-threshold 1.0)))
184        (cond ((or (eq test #'eq) (eq test 'eq))      (multiple-value-bind
185               (values 'eq #'eq #'eq-hash))          (test test-fun hash-fun)
186              ((or (eq test #'eql) (eq test 'eql))          (cond ((or (eq test #'eq) (eq test 'eq))
187               (values 'eql #'eql #'eql-hash))                 (values 'eq #'eq #'eq-hash))
188              ((or (eq test #'equal) (eq test 'equal))                ((or (eq test #'eql) (eq test 'eql))
189               (values 'equal #'equal #'equal-hash))                 (values 'eql #'eql #'eql-hash))
190              (t                ((or (eq test #'equal) (eq test 'equal))
191               (dolist (info *hash-table-tests*                 (values 'equal #'equal #'equal-hash))
192                             (error "Unknown :TEST for MAKE-HASH-TABLE: ~S"                (t
193                                    test))                 (dolist (info *hash-table-tests*
194                 (destructuring-bind                               (error "Unknown :TEST for MAKE-HASH-TABLE: ~S"
195                     (test-name test-fun hash-fun)                                      test))
196                     info                   (destructuring-bind
197                   (when (or (eq test test-name) (eq test test-fun))                    (test-name test-fun hash-fun)
198                     (return (values test-name test-fun hash-fun)))))))                    info
199      (let* ((size (ceiling size rehash-threshold))                    (when (or (eq test test-name) (eq test test-fun))
200             (length (if (<= size 37) 37 (almost-primify size)))                      (return (values test-name test-fun hash-fun)))))))
201             (vector (make-array length :initial-element nil)))        (let* ((scaled-size (round (/ (float size) rehash-threshold)))
202        (declare (type index size length)               (length (if (<= scaled-size 37) 37 (almost-primify scaled-size)))
203                 (type simple-vector vector))               (vector (make-array length :initial-element nil)))
204        (%make-hash-table          (declare (type index scaled-size length)
205         :test test                   (type simple-vector vector))
206         :test-fun test-fun          (%make-hash-table
207         :hash-fun hash-fun           :test test
208         :rehash-size rehash-size           :test-fun test-fun
209         :rehash-threshold rehash-threshold           :hash-fun hash-fun
210         :rehash-trigger (* size rehash-threshold)           :rehash-size rehash-size
211         :table vector))))           :rehash-threshold rehash-threshold
212             :rehash-trigger (round (* (float length) rehash-threshold))
213             :table vector)))))
214    
215  (defun hash-table-count (hash-table)  (defun hash-table-count (hash-table)
216    "Returns the number of entries in the given HASH-TABLE."    "Returns the number of entries in the given HASH-TABLE."
# Line 246  Line 252 
252                    (fixnum                    (fixnum
253                     (+ rehash-size old-length))                     (+ rehash-size old-length))
254                    (float                    (float
255                     (ceiling (* rehash-size old-length)))))                     (the index (round (* rehash-size old-length))))))
256                old-length))                old-length))
257           (new-vector (make-array new-length :initial-element nil)))           (new-vector (make-array new-length :initial-element nil)))
258        (declare (type index new-length))
259      (dotimes (i old-length)      (dotimes (i old-length)
260          (declare (type index i))
261        (do ((bucket (svref old-vector i) next)        (do ((bucket (svref old-vector i) next)
262             (next nil))             (next nil))
263            ((null bucket))            ((null bucket))
# Line 262  Line 270 
270                                             vm:vector-valid-hashing-subtype)                                             vm:vector-valid-hashing-subtype)
271                            (pointer-hash (hash-table-bucket-key bucket)))))                            (pointer-hash (hash-table-bucket-key bucket)))))
272                 (index (rem hashing new-length)))                 (index (rem hashing new-length)))
273              (declare (type index hashing index))
274            (setf (hash-table-bucket-next bucket) (svref new-vector index))            (setf (hash-table-bucket-next bucket) (svref new-vector index))
275            (setf (svref new-vector index) bucket)))            (setf (svref new-vector index) bucket)))
276        ;; We clobber the old vector contents so that if it is living in        ;; We clobber the old vector contents so that if it is living in
# Line 270  Line 279 
279      (setf (hash-table-table table) new-vector)      (setf (hash-table-table table) new-vector)
280      (unless (= new-length old-length)      (unless (= new-length old-length)
281        (setf (hash-table-rehash-trigger table)        (setf (hash-table-rehash-trigger table)
282              (let ((threshold (hash-table-rehash-threshold table)))              (round (* (hash-table-rehash-threshold table)
283                ;; Optimize the threshold=1 case so we don't have to use                        (float new-length))))))
               ;; generic arithmetic in the most common case.  
               (if (eql threshold 1)  
                   new-length  
                   (truncate (* threshold new-length)))))))  
284    (undefined-value))    (undefined-value))
285    
286  ;;; GETHASH -- Public.  ;;; GETHASH -- Public.
# Line 295  Line 300 
300            (hashing (funcall (hash-table-hash-fun hash-table) key))            (hashing (funcall (hash-table-hash-fun hash-table) key))
301            (index (rem hashing length))            (index (rem hashing length))
302            (test-fun (hash-table-test-fun hash-table)))            (test-fun (hash-table-test-fun hash-table)))
303         (declare (type index hashing))
304       (do ((bucket (svref vector index) (hash-table-bucket-next bucket)))       (do ((bucket (svref vector index) (hash-table-bucket-next bucket)))
305           ((null bucket) (values default nil))           ((null bucket) (values default nil))
306         (let ((bucket-hashing (hash-table-bucket-hash bucket)))         (let ((bucket-hashing (hash-table-bucket-hash bucket)))
# Line 319  Line 325 
325     (multiple-value-bind     (multiple-value-bind
326         (hashing eq-based)         (hashing eq-based)
327         (funcall (hash-table-hash-fun hash-table) key)         (funcall (hash-table-hash-fun hash-table) key)
328         (declare (type hash hashing))
329       (let* ((vector (hash-table-table hash-table))       (let* ((vector (hash-table-table hash-table))
330              (length (length vector))              (length (length vector))
331              (index (rem hashing length))              (index (rem hashing length))
332              (first-bucket (svref vector index))              (first-bucket (svref vector index))
333              (test-fun (hash-table-test-fun hash-table)))              (test-fun (hash-table-test-fun hash-table)))
334           (declare (type index index))
335         (do ((bucket first-bucket (hash-table-bucket-next bucket)))         (do ((bucket first-bucket (hash-table-bucket-next bucket)))
336             ((null bucket)             ((null bucket)
337              (when eq-based              (when eq-based
# Line 361  Line 369 
369            (hashing (funcall (hash-table-hash-fun hash-table) key))            (hashing (funcall (hash-table-hash-fun hash-table) key))
370            (index (rem hashing length))            (index (rem hashing length))
371            (test-fun (hash-table-test-fun hash-table)))            (test-fun (hash-table-test-fun hash-table)))
372         (declare (type index hashing index))
373       (do ((prev nil bucket)       (do ((prev nil bucket)
374            (bucket (svref vector index) (hash-table-bucket-next bucket)))            (bucket (svref vector index) (hash-table-bucket-next bucket)))
375           ((null bucket) nil)           ((null bucket) nil)
# Line 406  Line 415 
415                  (symbol-function map-function))))                  (symbol-function map-function))))
416          (vector (hash-table-table hash-table)))          (vector (hash-table-table hash-table)))
417      (dotimes (i (length vector))      (dotimes (i (length vector))
418          (declare (type index i))
419        (do ((bucket (svref vector i) (hash-table-bucket-next bucket)))        (do ((bucket (svref vector i) (hash-table-bucket-next bucket)))
420            ((null bucket))            ((null bucket))
421          (funcall fun          (funcall fun
# Line 461  Line 471 
471  (defmacro sxmash (place with)  (defmacro sxmash (place with)
472    (let ((n-with (gensym)))    (let ((n-with (gensym)))
473      `(let ((,n-with ,with))      `(let ((,n-with ,with))
474         (declare (fixnum ,n-with))         (declare (type hash ,n-with))
475         (setf ,place         (setf ,place
476               (logxor (ash ,n-with ,(- sxmash-rotate-bits sxmash-total-bits))               (logxor (truly-the hash
477                       (ash (logand ,n-with                                  (ash ,n-with
478                                    ,(1- (ash 1                                       ,(- sxmash-rotate-bits
479                                              (- sxmash-total-bits                                           sxmash-total-bits)))
480                                                 sxmash-rotate-bits))))                       (truly-the hash
481                            ,sxmash-rotate-bits)                                  (ash (logand
482                       (the fixnum ,place))))))                                        ,n-with
483                                          ,(1- (ash 1
484                                                    (- sxmash-total-bits
485                                                       sxmash-rotate-bits))))
486                                         ,sxmash-rotate-bits))
487                         (truly-the hash ,place))))))
488    
489  (defmacro sxhash-simple-string (sequence)  (defmacro sxhash-simple-string (sequence)
490    `(%sxhash-simple-string ,sequence))    `(%sxhash-simple-string ,sequence))
# Line 478  Line 493 
493    (let ((data (gensym))    (let ((data (gensym))
494          (start (gensym))          (start (gensym))
495          (end (gensym)))          (end (gensym)))
496      `(with-array-data ((,data ,sequence)      `(with-array-data ((,data (the string ,sequence))
497                         (,start)                         (,start)
498                         (,end))                         (,end))
499         (if (zerop ,start)         (if (zerop ,start)
# Line 506  Line 521 
521    
522    
523  (defun internal-sxhash (s-expr depth)  (defun internal-sxhash (s-expr depth)
524      (declare (type index depth) (values hash))
525    (typecase s-expr    (typecase s-expr
526      ;; The pointers and immediate types.      ;; The pointers and immediate types.
527      (list (sxhash-list s-expr depth))      (list (sxhash-list s-expr depth))
528      (fixnum      (fixnum (logand s-expr (1- most-positive-fixnum)))
      (ldb sxhash-bits-byte s-expr))  
529      (instance      (instance
530       (if (typep s-expr 'structure-object)       (if (typep s-expr 'structure-object)
531           (internal-sxhash (class-name (layout-class (%instance-layout s-expr)))           (internal-sxhash (class-name (layout-class (%instance-layout s-expr)))
# Line 530  Line 545 
545         (double-float         (double-float
546          (let* ((val s-expr)          (let* ((val s-expr)
547                 (lo (double-float-low-bits val))                 (lo (double-float-low-bits val))
548                 (hi (double-float-high-bits val)))                 (hi (ldb sxhash-bits-byte (double-float-high-bits val))))
549            (ldb sxhash-bits-byte            (ldb sxhash-bits-byte
550                 (logxor (ash lo (- sxmash-rotate-bits))                 (logxor (ash lo (- sxmash-rotate-bits))
551                         (ash hi (- sxmash-rotate-bits))                         (ash hi (- sxmash-rotate-bits))
552                         lo hi))))                         lo hi))))
553         (ratio (the fixnum (+ (internal-sxhash (numerator s-expr) 0)         (ratio (logxor (internal-sxhash (numerator s-expr) 0)
554                               (internal-sxhash (denominator s-expr) 0))))                        (internal-sxhash (denominator s-expr) 0)))
555         (complex (the fixnum (+ (internal-sxhash (realpart s-expr) 0)         (complex (logxor (internal-sxhash (realpart s-expr) 0)
556                                 (internal-sxhash (imagpart s-expr) 0))))))                          (internal-sxhash (imagpart s-expr) 0)))))
557      (array      (array
558       (typecase s-expr       (typecase s-expr
559         (string (sxhash-string s-expr))         (string (sxhash-string s-expr))

Legend:
Removed from v.1.21.1.1  
changed lines
  Added in v.1.21.1.2

  ViewVC Help
Powered by ViewVC 1.1.5