;;;; This software is part of the SBCL system. See the README file for
;;;; more information.
;;;;
;;;; While most of SBCL is derived from the CMU CL system, the test
;;;; files (like this one) were written from scratch after the fork
;;;; from CMU CL.
;;;;
;;;; This software is in the public domain and is provided with
;;;; absolutely no warranty. See the COPYING and CREDITS files for
;;;; more information.

;;; The return value of SXHASH on non-string/bitvector arrays should not
;;; change when the contents of the array change.
(with-test (:name (sxhash array :independent-of-contents))
  (let* ((a (make-array '(1) :initial-element 1))
         (sxhash (sxhash a))
         (hash (make-hash-table :test 'equal)))
    (setf (gethash a hash) t)
    (setf (aref a 0) 0)
    (assert (= sxhash (sxhash a)))
    ;; Need to make another access to the hash to disable the
    ;; last-seen-element cache.
    (setf (gethash 'y hash) t)
    (assert (gethash a hash))))

;;; Minimum quality checks
(with-test (:name (sxhash :quality :minimum))
  (assert (/= (sxhash "foo") (sxhash "bar")))
  (assert (/= (sxhash (pathname "foo.txt")) (sxhash (pathname "bar.txt"))))
  (assert (/= (sxhash (list 1 2 3)) (sxhash (list 3 2 1))))
  (assert (/= (sxhash #*1010) (sxhash #*0101))))

;;; This test supposes that no un-accounted-for consing occurs.
(with-test (:name :address-based-hash-counter :skipped-on :interpreter)
  ;; It doesn't particularly matter what ADDRESS-BASED-COUNTER-VAL returns,
  ;; but it's best to verify the assumption that each cons bumps the count
  ;; by 1, lest it be violated in a way that affects the quality of CTYPE
  ;; hashes.
  (let ((win 0) (n-trials 10) (prev (sb-int:address-based-counter-val)))
    (dotimes (i n-trials)
      (declare (notinline cons)) ; it's flushable, but don't flush it
      (cons 1 2)
      (let ((ptr (sb-int:address-based-counter-val)))
        (when (= ptr (1+ prev))
          (incf win))
        (setq prev ptr)))
    ;; GC could occur in here. Just check that 9 out of 10 trials succeed.
    (assert (>= win 9))))

(with-test (:name (sxhash :bit-vector-sxhash-mask-to-length))
  (let ((bv (make-array 5 :element-type 'bit))
        (unsafely-set-bit
         (compile nil
                  '(lambda (bv i val)
                     (declare (optimize (sb-c::insert-array-bounds-checks 0)))
                     (setf (bit bv i) val)))))
    (replace bv '(1 0 1 1 1))
    (let ((hash (sxhash bv)))
      ;; touch all bits of the first data word as well as the padding word
      (loop for i from 5 below (* 2 sb-vm:n-word-bytes)
            do (funcall unsafely-set-bit bv i 1)
               (assert (eql (sxhash bv) hash))
               (funcall unsafely-set-bit bv i 0)))))

(defvar *sbv* (make-array 512 :element-type 'bit))
(defun sxhash-for-bv-test (test-bv)
  (let ((underlying *sbv*)
        (expected-hash (sxhash test-bv)))
    ;; Currently %SXHASH-BIT-VECTOR can only operate on non-simple vectors
    ;; if the displacement on bits aligns to a word boundary,
    ;; or possibly on a byte boundary for some CPUs.
    ;; Otherwise it just copies the non-simple vector as there's no point
    ;; to exercising varying values of displaced-index-offet for that.
    (loop for index-offset
          from 0 by 8 repeat 25
          do (let ((unsimple-bv (make-array 300
                                            :element-type 'bit
                                            :displaced-to underlying
                                            :displaced-index-offset index-offset
                                            :fill-pointer (length test-bv))))
               (flet ((check-unreplaced-bits (expect)
                        ;; make sure REPLACE didn't touch bits outside
                        ;; the expected range. This is a test of REPLACE
                        ;; more so than SXHASH, but is needed to establish
                        ;; that SXHASH of the nonsimple vector isn't
                        ;; looking at bits that it shouldn't.
                        (loop for i from 0 below index-offset
                              do (assert (= (bit underlying i) expect)))
                        (loop for i from (+ index-offset (length test-bv))
                              below (length underlying)
                              do (assert (= (bit underlying i) expect)))))
                 (fill underlying 0)
                 (replace unsimple-bv test-bv)
                 (check-unreplaced-bits 0)
                 (assert (eql (sxhash unsimple-bv) expected-hash))
                 (fill underlying 1)
                 (replace unsimple-bv test-bv)
                 (check-unreplaced-bits 1)
                 (assert (eql (sxhash unsimple-bv) expected-hash)))))
    expected-hash))

;;; The value of SXHASH on bit-vectors of length a multiple of the word
;;; size didn't depend on the contents of the last word, specifically
;;; making it a constant for bit-vectors of length equal to the word
;;; size.
;;; Here we test that at least two different hash codes occur per length.
(with-test (:name (sxhash :quality bit-vector :non-constant))
  (let (;; Up to which length to test.
        (max-length 200)
        ;; How many random bits to use before declaring a test failure.
        (random-bits-to-use 200))
    (loop for length from 1 to max-length do
          (let ((v (make-array length :element-type 'bit)))
            (flet ((randomize-v ()
                     (map-into v (lambda ()
                                   (random 2)))))
              (randomize-v)
              (let ((sxhash (sxhash-for-bv-test v))
                    (random-bits-used 0))
                (loop
                  (randomize-v)
                  (when (/= (sxhash-for-bv-test v) sxhash)
                    (return))
                  (incf random-bits-used length)
                  (when (>= random-bits-used random-bits-to-use)
                    (error "SXHASH is constant on bit-vectors of length ~a."
                           length)))))))))

;;; See the comment at the previous test.
;;; Here we test that the hash code depends on any of the last N-WORD-BITS
;;; bits.
(with-test (:name (sxhash :quality bit-vector :dependent-on-final-bits))
  (let (;; Up to which length to test.
        (max-length 200)
        ;; How many random bits to use before declaring a test failure.
        (random-bits-to-use 200))
    ;; The previous test covers lengths up to the word size, so start
    ;; above that.
    (loop for length from (1+ sb-vm:n-word-bits) to max-length do
          (let ((v (make-array length :element-type 'bit :initial-element 0)))
            (flet ((randomize-v ()
                     (loop for i downfrom (1- length)
                           repeat sb-vm:n-word-bits
                           do (setf (aref v i) (random 2)))))
              (randomize-v)
              (let ((sxhash (sxhash-for-bv-test v)))
                (dotimes (i (ceiling random-bits-to-use sb-vm:n-word-bits)
                          (error "SXHASH on bit-vectors of length ~a ~
                                  does not depend on the final ~a bits."
                                 length sb-vm:n-word-bits))
                  (randomize-v)
                  (when (/= (sxhash-for-bv-test v) sxhash)
                    (return)))))))))

(with-test (:name :maphash-multiple-evaluation)
  (assert (null
           (check-function-evaluation-order
            (maphash
             (constantly nil)
             (make-hash-table))))))

(with-test (:name :equalp-hash-float-infinity)
  (let ((table (make-hash-table :test 'equalp)))
    (setf (gethash sb-ext:double-float-positive-infinity table) 1
          (gethash sb-ext:double-float-negative-infinity table) -1)
    (dolist (v (list sb-ext:single-float-positive-infinity
                     sb-ext:double-float-positive-infinity
                     (complex sb-ext:single-float-positive-infinity 0)
                     (complex sb-ext:double-float-positive-infinity 0)))
      (assert (eql (gethash v table) 1)))
    (dolist (v (list sb-ext:single-float-negative-infinity
                     sb-ext:double-float-negative-infinity
                     (complex sb-ext:single-float-negative-infinity 0)
                     (complex sb-ext:double-float-negative-infinity 0)))
      (assert (eql (gethash v table) -1)))))

(with-test (:name (:hash equalp pathname))
  (let* ((map (make-hash-table :test 'equalp))
         (key  #P"some/path/"))
    (setf (gethash key map) "my-value")
    (format (make-broadcast-stream) "Printing: ~A~%" key)
    (assert (remhash key map))
    (assert (= 0 (hash-table-count map)))))

(with-test (:name :clrhash-clears-rehash-p)
  (let ((tbl (make-hash-table)))
    (dotimes (i 10)
      (setf (gethash (cons 'foo (gensym)) tbl) 1))
    (gc)
    ;; The need-to-rehash bit is set
    (assert (eql 1 (svref (sb-impl::hash-table-pairs tbl) 1)))
    (clrhash tbl)
    ;; The need-to-rehash bit is not set
    (assert (eql 0 (svref (sb-impl::hash-table-pairs tbl) 1)))))

(with-test (:name :sxhash-signed-floating-point-zeros)
  (assert (not (eql (sxhash -0f0) (sxhash 0f0))))
  (assert (not (eql (sxhash -0d0) (sxhash 0d0)))))

(with-test (:name :sxhash-simple-bit-vector)
  (let (hashes)
    (let ((v (make-array sb-vm:n-word-bits :element-type 'bit)))
      (dotimes (i sb-vm:n-word-bits)
        (setf (aref v i) 1)
        (push (sxhash v) hashes)
        (setf (aref v i) 0)))
    (assert (= (length (remove-duplicates hashes)) sb-vm:n-word-bits))))

(with-test (:name :eq-hash-nonpointers-not-address-sensitive)
  (let ((tbl (make-hash-table :test 'eq)))
    (setf (gethash #\a tbl) 1)
    #+64-bit (setf (gethash 1.0f0 tbl) 1) ; single-float is a nonpointer
    (let ((data (sb-kernel:get-header-data (sb-impl::hash-table-pairs tbl))))
      (assert (not (logtest data sb-vm:vector-addr-hashing-subtype))))))

(with-test (:name (hash-table :small-rehash-size))
  (let ((ht (make-hash-table :rehash-size 2)))
    (dotimes (i 100)
      (setf (gethash (gensym) ht) 10)))
  (let ((ht (make-hash-table :rehash-size 1.0001)))
    (dotimes (i 100)
      (setf (gethash (gensym) ht) 10))))

(with-test (:name (hash-table :custom-hashfun-with-standard-test))
  (flet ((kv-flag-bits (ht)
           (sb-kernel:get-header-data (sb-impl::hash-table-pairs ht))))
    ;; verify that EQ hashing on symbols is address-sensitive
    (let ((h (make-hash-table :test 'eq)))
      (setf (gethash 'foo h) 1)
      (assert (logtest (kv-flag-bits h) sb-vm:vector-addr-hashing-subtype)))
    (let ((h (make-hash-table :test 'eq :hash-function 'sb-kernel:symbol-hash)))
      (setf (gethash 'foo h) 1)
      (assert (not (logtest (kv-flag-bits h) sb-vm:vector-addr-hashing-subtype))))

    ;; Verify that any standard hash-function on a function is address-sensitive,
    ;; but a custom hash function makes it not so.
    ;; Require 64-bit since this uses %CODE-SERIALNO as the hash,
    ;; and that function doesn't exist on 32-bit (but should!)
    #+64-bit
    (dolist (test '(eq eql equal equalp))
      (let ((h (make-hash-table :test test)))
        (setf (gethash #'car h) 1)
        (assert (logtest (kv-flag-bits h) sb-vm:vector-addr-hashing-subtype)))
      (let ((h (make-hash-table :test test :hash-function
                                (lambda (x)
                                  (sb-kernel:%code-serialno
                                   (sb-kernel:fun-code-header x))))))
        (setf (gethash #'car h) 1)
        (assert (not (logtest (kv-flag-bits h) sb-vm:vector-addr-hashing-subtype)))))))

(defun hash-table-freelist (tbl)
  (sb-int:named-let chain ((index (sb-impl::hash-table-next-free-kv tbl)))
    (when (plusp index)
      (nconc (list index)
             (chain (aref (sb-impl::hash-table-next-vector tbl) index))))))

(defvar *tbl* (make-hash-table :weakness :key))

(import 'sb-impl::hash-table-smashed-cells)
;;; We have a bunch of tests of weakness, but this is testing the new algorithm
;;; which has two different freelists - one of cells that REMHASH has made available
;;; and one of cells that GC has marked as empty. Since we no longer inhibit GC
;;; during table operations, we need to give GC a list of its own to manipulate.
(with-test (:name (hash-table :gc-smashed-cell-list))
  (flet ((f ()
           (dotimes (i 20000) (setf (gethash i *tbl*) (- i)))
           (setf (gethash (cons 1 2) *tbl*) 'foolz)
           (assert (= (sb-impl::kv-vector-high-water-mark (sb-impl::hash-table-pairs *tbl*))
                      20001))
           (loop for i from 10 by 10 repeat 20 do (remhash i *tbl*))))
    ;; Ensure the values remain outside of the stack pointer for scrub-control-stack to work
    (declare (notinline f))
    (f))
  (sb-sys:scrub-control-stack)
  (gc)
  ;; There were 20 items REMHASHed plus the freelist contains a pointer
  ;; to a cell which is one past the high-water-mark, for 21 cells in all.
  (assert (= (length (hash-table-freelist *tbl*)) 21))
  ;; The (1 . 2) cons was removed
  (assert (= (length (hash-table-smashed-cells *tbl*)) 1))
  ;; And its representation in the list of smashed cells doesn't
  ;; fit in a packed integer (because the cell index is 20001)
  (assert (and (consp (hash-table-smashed-cells *tbl*))
               (consp (car (hash-table-smashed-cells *tbl*)))))
  (setf (gethash 'jeebus *tbl*) 9)
  ;; Freelist should not have changed at all.
  (assert (= (length (hash-table-freelist *tbl*)) 21))
  ;; And the smashed cell was used.
  (assert (null (hash-table-smashed-cells *tbl*)))
  (setf (gethash (make-symbol "SANDWICH") *tbl*) 8)
  ;; Now one item should have been popped
  (assert (= (length (hash-table-freelist *tbl*)) 20))
  ;; should have used up the smashed cell
  (sb-sys:scrub-control-stack)
  (gc)
  ;; Should have smashed the uninterned symbol
  (assert (hash-table-smashed-cells *tbl*)))

;;; Immediate values are address-based but not motion-sensitive.
;;; The hash function returns address-based = NIL.
;;; The specialized function GETHASH/EQ never compares hashes,
;;; but the generalized FINDHASH-WEAK forgot to not compare them.
(with-test (:name (hash-table :weak-eq-table-fixnum-key))
  (let ((table (make-hash-table :test 'eq :weakness :key)))
    (setf (gethash 42 table) t)
    (gethash 42 table)))

(with-test (:name :write-hash-table-readably)
  (let ((h1 (make-hash-table)))
    (setf (gethash :a h1) 1
          (gethash :b h1) 2
          (gethash :c h1) 3)
    (let* ((s1 (write-to-string h1 :readably t))
           (h2 (read-from-string s1))
           (s2 (write-to-string h2 :readably t)))
      ;; S1 and S2 used to be STRING/= prior to making
      ;; %HASH-TABLE-ALIST iterate backwards.
      (assert (string= s1 s2)))))

(defun test-this-object (table-kind object)
  (let ((store (make-hash-table :test table-kind)))
    (setf (gethash object store) '(1 2 3))
    (assert (equal (gethash object store) '(1 2 3)))
    (assert (remhash object store))
    (assert (= (hash-table-count store) 0))))

;; https://bugs.launchpad.net/sbcl/+bug/1865094
(with-test (:name :remhash-eq-comparable-in-equal-table)
  ;; These objects are all hashed by their address,
  ;; so their stored hash value is the magic marker.
  (test-this-object 'equal (make-hash-table))
  (test-this-object 'equal (sb-kernel:find-defstruct-description 'sb-c::node))
  (test-this-object 'equal #'car)
  (test-this-object 'equal (sb-sys:int-sap 0))
  ;; a CLASS is not hashed address-sensitively, so this wasn't
  ;; actually subject to the bug. Try it anyway.
  (test-this-object 'equal (find-class 'class)))

(with-test (:name :remhash-eq-comparable-in-equalp-table)
  ;; EQUALP tables worked a little better, because more objects have
  ;; are hashed non-address-sensitively by EQUALP-HASH relative to EQUAL-HASH,
  ;; and those objects have comparators that descend.
  ;; However, there are still some things hashed by address:
  (test-this-object 'equalp (make-weak-pointer "bleep"))
  (test-this-object 'equalp (sb-kernel::find-fdefn 'cons))
  (test-this-object 'equalp #'car)
  (test-this-object 'equalp (constantly 5))
  (test-this-object 'equal (sb-sys:int-sap 0)))

;;; I don't like that we call SXHASH on layouts, but there was a horrible
;;; regression in which we returned (SXHASH (LAYOUT-OF X)) if X was a layout,
;;; which essentially meant that all layouts hashed to LAYOUT's hash.
;;; This affected the performance of TYPECASE.
(with-test (:name :sxhash-on-layout)
  (dolist (x '(pathname cons array))
    (let ((l (sb-kernel:find-layout x)))
      (assert (= (sxhash l) (sb-kernel::layout-clos-hash l))))))

(with-test (:name :equalp-table-fixnum-equal-to-float)
  (let ((table (make-hash-table :test #'equalp)))
    (assert (eql (setf (gethash 3d0 table) 1)
                 (gethash 3   table)))))

(with-test (:name :transform-sxhash-string-and-bv)
  (let ((f (compile
            nil
            '(lambda (x y)
               (logxor (ash (sxhash (truly-the (or string null) x)) -3)
                       (sxhash (truly-the (or bit-vector null) y))))))
        (fdefn1 (sb-kernel::find-fdefn 'sb-kernel:%sxhash-string))
        (fdefn2 (sb-kernel::find-fdefn 'sb-kernel:%sxhash-bit-vector)))
    (every (lambda (x) (member x `(,fdefn1 ,fdefn2)))
           (ctu:find-code-constants f))))

(with-test (:name :sxhash-on-displaced-string
            :fails-on :sbcl)
  (let* ((adjustable-string
          (make-array 100 :element-type 'character :adjustable t))
         (displaced-string
          (make-array 50 :element-type 'character :displaced-to adjustable-string
                      :displaced-index-offset 19)))
    (adjust-array adjustable-string 68)
    (assert-error (aref displaced-string 0)) ; should not work
    ;; This should fail, but instead it computes the hash of a string of
    ;; length 0 which is what we turn displaced-string into after adjustable-string
    ;; is changed to be too small to hold displaced-string.
    ;; As a possible fix, we could distinguish between safe and unsafe code,
    ;; never do the sxhash transforms in safe code, and have the full call to
    ;; sxhash always check for "obsolete" strings.
    ;; I would guess that all sorts of string transforms are similarly
    ;; suspect in this edge case.
    ;; On the one hand, this is undefined behavior as per CLHS:
    ;;  "If A is displaced to B, the consequences are unspecified if B is adjusted
    ;;   in such a way that it no longer has enough elements to satisfy A."
    ;; But on the other, we always try to be maximally helpful,
    ;; and it's extremely dubious that we're totally silent here.
    ;; Also the same issue exists with bit-vectors.
    (assert-error (sxhash displaced-string))))
