tests/hash.pure.lisp

   1 ;;;; This software is part of the SBCL system. See the README file for
   2 ;;;; more information.
   3 ;;;;
   4 ;;;; While most of SBCL is derived from the CMU CL system, the test
   5 ;;;; files (like this one) were written from scratch after the fork
   6 ;;;; from CMU CL.
   7 ;;;;
   8 ;;;; This software is in the public domain and is provided with
   9 ;;;; absolutely no warranty. See the COPYING and CREDITS files for
  10 ;;;; more information.
  11
  12 (in-package :cl-user)
  13
  14 ;;; +MAGIC-HASH-VECTOR-VALUE+ is used to mark empty entries in the slot
  15 ;;; HASH-VECTOR of hash tables. It must be a value outside of the range
  16 ;;; of SXHASH. The range of SXHASH is the non-negative fixnums.
  17 (with-test (:name :magic-hash-vector-value)
  18   (assert (not (typep sb-impl::+magic-hash-vector-value+
  19                       '(and fixnum unsigned-byte)))))
  20
  21 ;;; The return value of SXHASH on non-string/bitvector arrays should not
  22 ;;; change when the contents of the array change.
  23 (with-test (:name (sxhash array :independent-of-contents))
  24   (let* ((a (make-array '(1) :initial-element 1))
  25          (sxhash (sxhash a))
  26          (hash (make-hash-table :test 'equal)))
  27     (setf (gethash a hash) t)
  28     (setf (aref a 0) 0)
  29     (assert (= sxhash (sxhash a)))
  30     ;; Need to make another access to the hash to disable the
  31     ;; last-seen-element cache.
  32     (setf (gethash 'y hash) t)
  33     (assert (gethash a hash))))
  34
  35 ;;; Minimum quality checks
  36 (with-test (:name (sxhash :quality :minimum))
  37   (assert (/= (sxhash "foo") (sxhash "bar")))
  38   (assert (/= (sxhash (pathname "foo.txt")) (sxhash (pathname "bar.txt"))))
  39   (assert (/= (sxhash (list 1 2 3)) (sxhash (list 3 2 1))))
  40   (assert (/= (sxhash #*1010) (sxhash #*0101))))
  41
  42 ;;; This test supposes that no un-accounted-for consing occurs.
  43 (with-test (:name :address-based-hash-counter :skipped-on :interpreter)
  44   ;; It doesn't particularly matter what ADDRESS-BASED-COUNTER-VAL returns,
  45   ;; but it's best to verify the assumption that each cons bumps the count
  46   ;; by 1, lest it be violated in a way that affects the quality of CTYPE
  47   ;; hashes.
  48   (let ((win 0) (n-trials 10) (prev (sb-impl::address-based-counter-val)))
  49     (dotimes (i n-trials)
  50       (declare (notinline cons)) ; it's flushable, but don't flush it
  51       (cons 1 2)
  52       (let ((ptr (sb-impl::address-based-counter-val)))
  53         (when (= ptr (1+ prev))
  54           (incf win))
  55         (setq prev ptr)))
  56     ;; GC could occur in here. Just check that 9 out of 10 trials succeed.
  57     (assert (>= win 9))))
  58
  59 ;;; The value of SXHASH on bit-vectors of length a multiple of the word
  60 ;;; size didn't depend on the contents of the last word, specifically
  61 ;;; making it a constant for bit-vectors of length equal to the word
  62 ;;; size.
  63 ;;; Here we test that at least two different hash codes occur per length.
  64 (with-test (:name (sxhash :quality bit-vector :non-constant))
  65   (let (;; Up to which length to test.
  66         (max-length 200)
  67         ;; How many random bits to use before declaring a test failure.
  68         (random-bits-to-use 200))
  69     (loop for length from 1 to max-length do
  70           (let ((v (make-array length :element-type 'bit)))
  71             (flet ((randomize-v ()
  72                      (map-into v (lambda ()
  73                                    (random 2)))))
  74               (randomize-v)
  75               (let ((sxhash (sxhash v))
  76                     (random-bits-used 0))
  77                 (loop
  78                   (randomize-v)
  79                   (when (/= (sxhash v) sxhash)
  80                     (return))
  81                   (incf random-bits-used length)
  82                   (when (>= random-bits-used random-bits-to-use)
  83                     (error "SXHASH is constant on bit-vectors of length ~a."
  84                            length)))))))))
  85
  86 ;;; See the comment at the previous test.
  87 ;;; Here we test that the hash code depends on any of the last N-WORD-BITS
  88 ;;; bits.
  89 (with-test (:name (sxhash :quality bit-vector :dependent-on-final-bits))
  90   (let (;; Up to which length to test.
  91         (max-length 200)
  92         ;; How many random bits to use before declaring a test failure.
  93         (random-bits-to-use 200))
  94     ;; The previous test covers lengths up to the word size, so start
  95     ;; above that.
  96     (loop for length from (1+ sb-vm:n-word-bits) to max-length do
  97           (let ((v (make-array length :element-type 'bit :initial-element 0)))
  98             (flet ((randomize-v ()
  99                      (loop for i downfrom (1- length)
 100                            repeat sb-vm:n-word-bits
 101                            do (setf (aref v i) (random 2)))))
 102               (randomize-v)
 103               (let ((sxhash (sxhash v)))
 104                 (dotimes (i (ceiling random-bits-to-use sb-vm:n-word-bits)
 105                           (error "SXHASH on bit-vectors of length ~a ~
 106                                   does not depend on the final ~a bits."
 107                                  length sb-vm:n-word-bits))
 108                   (randomize-v)
 109                   (when (/= (sxhash v) sxhash)
 110                     (return)))))))))
 111
 112 (with-test (:name :maphash-multiple-evaluation)
 113   (assert (null
 114            (check-function-evaluation-order
 115             (maphash
 116              (constantly nil)
 117              (make-hash-table))))))
 118
 119 (with-test (:name :equalp-hash-float-infinity)
 120   (let ((table (make-hash-table :test 'equalp)))
 121     (setf (gethash sb-ext:double-float-positive-infinity table) 1
 122           (gethash sb-ext:double-float-negative-infinity table) -1)
 123     (dolist (v (list sb-ext:single-float-positive-infinity
 124                      sb-ext:double-float-positive-infinity
 125                      (complex sb-ext:single-float-positive-infinity 0)
 126                      (complex sb-ext:double-float-positive-infinity 0)))
 127       (assert (eql (gethash v table) 1)))
 128     (dolist (v (list sb-ext:single-float-negative-infinity
 129                      sb-ext:double-float-negative-infinity
 130                      (complex sb-ext:single-float-negative-infinity 0)
 131                      (complex sb-ext:double-float-negative-infinity 0)))
 132       (assert (eql (gethash v table) -1)))))