tests/hash.impure.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 (use-package :test-util)
  15 (use-package :assertoid)
  16
  17 (defstruct foo)
  18 (defstruct bar x y)
  19
  20 ;;; SXHASH and PSXHASH should distribute hash values well over the
  21 ;;; space of possible values, so that collisions between the hash
  22 ;;; values of unequal objects should be very uncommon. (Except of
  23 ;;; course the hash values must collide when the objects are EQUAL or
  24 ;;; EQUALP respectively!)
  25 (locally
  26   ;; In order to better test not-EQ-but-EQUAL and not-EQ-but-EQUALP,
  27   ;; we'd like to suppress some optimizations.
  28   (declare (notinline complex float coerce + - expt))
  29   (flet ((make-sxhash-subtests ()
  30            (list (cons 0 1)
  31                  (list 0 1)
  32                  (cons 1 0)
  33                  (cons (cons 1 0) (cons 0 0))
  34                  (cons (list 1 0) (list 0 0))
  35                  (list (cons 1 0) (list 0 0))
  36                  (list (cons 0 1) (list 0 0))
  37                  (list (cons 0 0) (cons 1 0))
  38                  (list (cons 0 0) (cons 0 1))
  39
  40                  44     (float 44)     (coerce 44 'double-float)
  41                  -44    (float -44)    (coerce -44 'double-float)
  42                  0      (float 0)      (coerce 0 'double-float)
  43                  -0     (- (float 0))  (- (coerce 0 'double-float))
  44                  -121   (float -121)   (coerce -121 'double-float)
  45                  3/4    (float 3/4)    (coerce 3/4 'double-float)
  46                  -3/4   (float -3/4)   (coerce -3/4 'double-float)
  47                  45     (float 45)     (coerce 45 'double-float)
  48                  441/10 (float 441/10) (coerce (float 441/10) 'double-float)
  49
  50                  (expt 2 33) (expt 2.0 33) (expt 2.0d0 33)
  51                  (- (expt 1/2 50)) (- (expt 0.5 50)) (- (expt 0.5d0 50))
  52                  (+ (expt 1/2 50)) (+ (expt 0.5 50)) (+ (expt 0.5d0 50))
  53
  54                  (complex 1.0 2.0) (complex 1.0d0 2.0)
  55                  (complex 1.5 -3/2) (complex 1.5 -1.5d0)
  56
  57                  #\x #\X #\*
  58
  59                  (copy-seq "foo") (copy-seq "foobar") (copy-seq "foobarbaz")
  60
  61                  (copy-seq #*)
  62                  (copy-seq #*0) (copy-seq #*1)
  63                  (copy-seq #*00) (copy-seq #*10)
  64                  (copy-seq #*01) (copy-seq #*11)
  65                  (copy-seq #*10010) (copy-seq #*100101) (bit-not #*01101)
  66                  (make-array 6 :fill-pointer 6
  67                              :element-type 'bit :initial-contents #*100101)
  68
  69                  #'allocate-instance #'no-applicable-method))
  70          (make-psxhash-extra-subtests ()
  71            (list (copy-seq "")
  72                  (copy-seq #*)
  73                  (copy-seq #())
  74                  (copy-seq ())
  75                  (copy-seq '(()))
  76                  (copy-seq #(()))
  77                  (copy-seq '(#()))
  78                  (make-array 3 :fill-pointer 0)
  79                  (make-array 7 :fill-pointer 0 :element-type 'bit)
  80                  (make-array 8 :fill-pointer 0 :element-type 'character)
  81                  (vector (cons 1 0) (cons 0 0))
  82                  (vector (cons 0 1) (cons 0 0))
  83                  (vector (cons 0 0) (cons 1 0))
  84                  (vector (cons 0 0) (cons 0 1))
  85                  (vector (cons 1 0) (cons 0 0))
  86                  (vector (cons 0 1) (cons 0 0))
  87                  (vector (list 0 0) (cons 1 0))
  88                  (vector (list 0 0) (list 0 1))
  89                  (vector (vector 1 0) (list 0 0))
  90                  (vector (vector 0 1) (list 0 0))
  91                  (vector (vector 0 0) (list 1 0))
  92                  (vector (vector 0 0) (list 0 1))
  93                  (vector #*00 #*10)
  94                  (vector (vector 0 0) (list 0 1.0d0))
  95                  (vector (vector -0.0d0 0) (list 1.0 0))
  96                  (vector 1 0 1 0)
  97                  (vector 0 0 0)
  98                  (copy-seq #*1010)
  99                  (copy-seq #*000)
 100                  (replace (make-array 101
 101                                       :element-type 'bit
 102                                       :fill-pointer 4)
 103                           #*1010)
 104                  (replace (make-array 14
 105                                       :element-type '(unsigned-byte 8)
 106                                       :fill-pointer 3)
 107                           #*000)
 108                  (replace (make-array 14
 109                                       :element-type t
 110                                       :fill-pointer 3)
 111                           #*000)
 112                  (copy-seq "abc")
 113                  (copy-seq "ABC")
 114                  (copy-seq "aBc")
 115                  (copy-seq "abcc")
 116                  (copy-seq "1001")
 117                  'abc
 118                  (vector #\a #\b #\c)
 119                  (vector 'a 'b 'c)
 120                  (vector "A" 'b 'c)
 121                  (replace (make-array 14
 122                                       :element-type 'character
 123                                       :fill-pointer 3)
 124                           "aBc")
 125                  (replace (make-array 11
 126                                       :element-type 'character
 127                                       :fill-pointer 4)
 128                           "1001")
 129                  (replace (make-array 12
 130                                       :element-type 'bit
 131                                       :fill-pointer 4)
 132                           #*1001)
 133                  (replace (make-array 13
 134                                       :element-type t
 135                                       :fill-pointer 4)
 136                           "1001")
 137                  (replace (make-array 13
 138                                       :element-type t
 139                                       :fill-pointer 4)
 140                           #*1001)
 141                  ;; FIXME: What about multi-dimensional arrays, hmm?
 142
 143                  (make-hash-table)
 144                  (make-hash-table :test 'equal)
 145
 146                  (make-foo)
 147                  (make-bar)
 148                  (make-bar :x (list 1))
 149                  (make-bar :y (list 1))))
 150          (t->boolean (x) (if x t nil)))
 151     (let* (;; Note:
 152            ;;   * The APPEND noise here is to help more strenuously test
 153            ;;     not-EQ-but-EQUAL and not-EQ-but-EQUALP cases.
 154            ;;   * It seems not to be worth the hassle testing SXHASH on
 155            ;;     values whose structure isn't understood by EQUAL, since
 156            ;;     we get too many false positives "SXHASHes are equal even
 157            ;;     though values aren't EQUAL, what a crummy hash function!"
 158            ;;     FIXME: Or am I misunderstanding the intent of the
 159            ;;     the SXHASH specification? Perhaps SXHASH is supposed to
 160            ;;     descend into the structure of objects even when EQUAL
 161            ;;     doesn't, in order to avoid hashing together things which
 162            ;;     are guaranteed not to be EQUAL? The definition of SXHASH
 163            ;;     seems to leave this completely unspecified: should
 164            ;;     "well-distributed" depend on substructure that EQUAL
 165            ;;     ignores? For our internal hash tables, the stricter
 166            ;;     descend-into-the-structure behavior might improve
 167            ;;     performance even though it's not specified by ANSI. But
 168            ;;     is it reasonable for users to expect it? Hmm..
 169            (sxhash-tests (append (make-sxhash-subtests)
 170                                  (make-sxhash-subtests)))
 171            (psxhash-tests (append sxhash-tests
 172                                   (make-psxhash-extra-subtests)
 173                                   (make-psxhash-extra-subtests))))
 174       ;; Check that SXHASH compiler transforms give the same results
 175       ;; as the out-of-line version of SXHASH.
 176       (let* ((fundef `(lambda ()
 177                         (list ,@(mapcar (lambda (value)
 178                                           `(sxhash ',value))
 179                                         sxhash-tests))))
 180              (fun (compile nil fundef)))
 181         (assert (equal (funcall fun)
 182                        (mapcar #'sxhash sxhash-tests))))
 183       ;; Note: The tests for SXHASH-equality iff EQUAL and
 184       ;; PSXHASH-equality iff EQUALP could fail because of an unlucky
 185       ;; random collision. That's not very likely (since there are
 186       ;; (EXPT 2 29) possible hash values and only on the order of 100
 187       ;; test cases, so even with the birthday paradox a collision has
 188       ;; probability only (/ (EXPT 100 2) (EXPT 2 29)), but it's
 189       ;; probably worth checking if you are getting a mystifying error
 190       ;; from this test. (SXHASH values and PSXHASH values don't
 191       ;; change from run to run, so the random chance of bogus failure
 192       ;; happens once every time the code is changed in such a way
 193       ;; that the SXHASH distribution changes, not once every time the
 194       ;; tests are run.)
 195       (dolist (i sxhash-tests)
 196         (declare (notinline funcall))
 197         (unless (typep (funcall #'sxhash i) '(and fixnum unsigned-byte))
 198           (error "bad SXHASH behavior for ~S" i))
 199         (dolist (j sxhash-tests)
 200           (unless (or (eq (t->boolean (equal i j))
 201                           (t->boolean (= (sxhash i) (sxhash j))))
 202                       (and (typep i 'number)
 203                            (typep j 'number)
 204                            (= i j)
 205                            (subtypep (type-of i) (type-of j))
 206                            (subtypep (type-of j) (type-of i))))
 207             ;; (If you get a surprising failure here, maybe you were
 208             ;; just very unlucky; see the notes above.)
 209             (error "bad SXHASH behavior for ~S ~S" i j))))
 210       (dolist (i psxhash-tests)
 211         (unless (typep (sb-int:psxhash i) '(and fixnum unsigned-byte))
 212           (error "bad PSXHASH behavior for ~S" i))
 213         (dolist (j psxhash-tests)
 214           (unless (eq (t->boolean (equalp i j))
 215                       (t->boolean (= (sb-int:psxhash i) (sb-int:psxhash j))))
 216             ;; (If you get a surprising failure here, maybe you were
 217             ;; just very unlucky; see the notes above.)
 218             (error "bad PSXHASH behavior for ~S ~S" i j))))
 219       )))
 220
 221 ;;; As of sbcl-0.6.12.10, writing hash tables readably should work.
 222 ;;; This isn't required by the ANSI standard, but it should be, since
 223 ;;; it's well-defined useful behavior which ANSI prohibits the users
 224 ;;; from implementing themselves. (ANSI says the users can't define
 225 ;;; their own their own PRINT-OBJECT (HASH-TABLE T) methods, and they
 226 ;;; can't even wiggle out of it by subclassing HASH-TABLE or STREAM.)
 227 (let ((original-ht (make-hash-table :test 'equal :size 111))
 228       (original-keys '(1 10 11 400030002 -100000000)))
 229   (dolist (key original-keys)
 230     (setf (gethash key original-ht)
 231           (expt key 4)))
 232   (let* ((written-ht (with-output-to-string (s)
 233                        (write original-ht :stream s :readably t)))
 234          (read-ht (with-input-from-string (s written-ht)
 235                     (read s))))
 236     (assert (= (hash-table-count read-ht)
 237                (hash-table-count original-ht)
 238                (length original-keys)))
 239     (assert (eql (hash-table-test original-ht) (hash-table-test read-ht)))
 240     (assert (eql (hash-table-size original-ht) (hash-table-size read-ht)))
 241     (dolist (key original-keys)
 242       (assert (eql (gethash key read-ht)
 243                    (gethash key original-ht))))))
 244
 245 ;;; NIL is both SYMBOL and LIST
 246 (dolist (fun '(sxhash sb-impl::psxhash))
 247   (assert (= (eval `(,fun nil))
 248              (funcall fun nil)
 249              (funcall (compile nil `(lambda (x)
 250                                       (declare (symbol x))
 251                                       (,fun x)))
 252                       nil)
 253              (funcall (compile nil `(lambda (x)
 254                                       (declare (list x))
 255                                       (,fun x)))
 256                       nil)
 257              (funcall (compile nil `(lambda (x)
 258                                       (declare (null x))
 259                                       (,fun x)))
 260                       nil))))
 261
 262 ;;; This test works reliably on non-conservative platforms and
 263 ;;; somewhat reliably on conservative platforms with threads.
 264 (progn
 265
 266 (defparameter *ht* nil)
 267
 268 (defvar *cons-here*)
 269
 270 (declaim (notinline args))
 271 (defun take (&rest args)
 272   (declare (ignore args)))
 273
 274 (defmacro alloc (&body body)
 275   "Execute BODY and try to reduce the chance of leaking a conservative root."
 276   #-sb-thread
 277   `(multiple-value-prog1
 278        (progn ,@body)
 279      (loop repeat 20000 do (setq *cons-here* (cons nil nil)))
 280      ;; KLUDGE: Clean the argument passing regs.
 281      (apply #'take (loop repeat 36 collect #'cons)))
 282   #+sb-thread
 283   (let ((values (gensym))
 284         (sem (gensym)))
 285     `(let ((,sem (sb-thread::make-semaphore))
 286            ,values)
 287        (make-join-thread (lambda ()
 288                            (setq ,values
 289                                  (multiple-value-list (progn ,@body)))
 290                            (sb-thread::signal-semaphore ,sem)))
 291        (sb-thread::wait-on-semaphore ,sem)
 292        (values-list ,values))))
 293
 294 (with-test (:name (:hash-table :weakness :eql :numbers) :skipped-on '(and :c-stack-is-control-stack (not :sb-thread)))
 295   (flet ((random-number ()
 296            (random 1000)))
 297     (loop for weakness in '(nil :key :value :key-and-value :key-or-value) do
 298           (let* ((ht (make-hash-table :weakness weakness))
 299                  (n (alloc (loop repeat 1000
 300                                  count (let ((key (random-number)))
 301                                          (if (gethash key ht)
 302                                              (setf (gethash key ht)
 303                                                    (random-number))))))))
 304             (gc :full t)
 305             (gc :full t)
 306             (assert (= n (hash-table-count ht)))))))
 307
 308 (defun add-removable-stuff (ht &key (n 100) (size 10))
 309   (flet ((unique-object ()
 310            (make-array size :fill-pointer 0)))
 311     (loop for i below n do
 312           (multiple-value-bind (key value)
 313               (ecase (hash-table-weakness ht)
 314                 ((:key) (values (unique-object) i))
 315                 ((:value) (values i (unique-object)))
 316                 ((:key-and-value)
 317                  (if (zerop (random 2))
 318                      (values (unique-object) i)
 319                      (values i (unique-object))))
 320                 ((:key-or-value)
 321                  (values (unique-object) (unique-object))))
 322             (setf (gethash key ht) value)))
 323     (values)))
 324
 325 (defun print-ht (ht &optional (stream t))
 326   (format stream "Weakness: ~S~%" (hash-table-weakness ht))
 327   (format stream "Table: ~S~%" (sb-impl::hash-table-table ht))
 328   (format stream "Next: ~S~%" (sb-impl::hash-table-next-vector ht))
 329   (format stream "Index: ~S~%" (sb-impl::hash-table-index-vector ht))
 330   (format stream "Hash: ~S~%" (sb-impl::hash-table-hash-vector ht))
 331   (force-output stream))
 332
 333 (with-test (:name (:hash-table :weakness :removal) :skipped-on '(and :c-stack-is-control-stack (not :sb-thread)))
 334   (loop for test in '(eq eql equal equalp) do
 335         ; (format t "test: ~A~%" test)
 336         (loop for weakness in '(:key :value :key-and-value :key-or-value)
 337               do
 338               ; (format t "weakness: ~A~%" weakness)
 339               (let ((ht (make-hash-table :test 'equal :weakness weakness)))
 340                 (alloc (add-removable-stuff ht :n 117 :size 1))
 341                 (loop for i upfrom 0
 342                       do ; (format t "~A. count: ~A~%" i (hash-table-count ht))
 343                       (force-output)
 344                       until (zerop (hash-table-count ht))
 345                       do
 346                       (when (= i 10)
 347                         (print-ht ht)
 348                         #-(or x86 x86-64)
 349                         (assert nil)
 350                         ;; With conservative gc the test may not be
 351                         ;; bullet-proof so it's not an outright
 352                         ;; failure but a warning.
 353                         #+(or x86 x86-64)
 354                         (progn
 355                           (warn "Weak hash removal test failed for weakness ~A"
 356                                 weakness)
 357                           (return)))
 358                       (gc :full t))))))
 359
 360 (with-test (:name (:hash-table :weakness :string-interning) :skipped-on '(and :c-stack-is-control-stack (not :sb-thread)))
 361   (let ((ht (make-hash-table :test 'equal :weakness :key))
 362         (s "a"))
 363     (setf (gethash s ht) s)
 364     (assert (eq (gethash s ht) s))
 365     (assert (eq (gethash (copy-seq s) ht) s))))
 366
 367 ;;; see if hash_vector is not written when there is none ...
 368 (with-test (:name (:hash-table :weakness :eq) :skipped-on '(and :c-stack-is-control-stack (not :sb-thread)))
 369   (loop repeat 10 do
 370         (let ((index (random 2000)))
 371           (let ((first (+ most-positive-fixnum (mod (* index 31) 9)))
 372                 (n 50000))
 373             (let ((hash-table (make-hash-table :weakness :key :test 'eq)))
 374               (dotimes (i n)
 375                 (setf (gethash (+ first i) hash-table) i))
 376               hash-table)))))
 377
 378 ;; used to crash in gc
 379 (with-test (:name (:hash-table :weakness :keep) :skipped-on '(and :c-stack-is-control-stack (not :sb-thread)))
 380   (loop repeat 2 do
 381         (let ((h1 (make-hash-table :weakness :key :test #'equal))
 382               (keep ()))
 383           (loop for i from 0 to 1000
 384                 for key = i
 385                 for value = (make-array 10000 :fill-pointer 0)
 386                 do
 387                 (push value keep)
 388                 (setf (gethash key h1) value))
 389           (sb-ext:gc :full t))))
 390
 391 )
 392
 393 ;;; DEFINE-HASH-TABLE-TEST
 394
 395 (defstruct custom-hash-key name)
 396 (defun custom-hash-test (x y)
 397   (equal (custom-hash-key-name x)
 398          (custom-hash-key-name y)))
 399 (defun custom-hash-hash (x)
 400   (sxhash (custom-hash-key-name x)))
 401 (define-hash-table-test custom-hash-test custom-hash-hash)
 402 (with-test (:name :define-hash-table-test.1)
 403   (let ((table (make-hash-table :test 'custom-hash-test)))
 404     (setf (gethash (make-custom-hash-key :name "foo") table) :foo)
 405     (setf (gethash (make-custom-hash-key :name "bar") table) :bar)
 406     (assert (eq :foo (gethash (make-custom-hash-key :name "foo") table)))
 407     (assert (eq :bar (gethash (make-custom-hash-key :name "bar") table)))
 408     (assert (eq 'custom-hash-test (hash-table-test table))))
 409   (let ((table (make-hash-table :test #'custom-hash-test)))
 410     (setf (gethash (make-custom-hash-key :name "foo") table) :foo)
 411     (setf (gethash (make-custom-hash-key :name "bar") table) :bar)
 412     (assert (eq :foo (gethash (make-custom-hash-key :name "foo") table)))
 413     (assert (eq :bar (gethash (make-custom-hash-key :name "bar") table)))
 414     (assert (eq 'custom-hash-test (hash-table-test table)))))
 415
 416
 417 (defun head-eql (x y)
 418   (every #'eql (subseq x 0 3) (subseq y 0 3)))
 419 (define-hash-table-test head-eql
 420     (lambda (x)
 421       (logand most-positive-fixnum
 422               (reduce #'+ (map 'list #'sxhash (subseq x 0 3))))))
 423 (with-test (:name :define-hash-table-test.2)
 424   (let ((table (make-hash-table :test 'head-eql)))
 425     (setf (gethash #(1 2 3 4) table) :|123|)
 426     (setf (gethash '(2 3 4 7) table) :|234|)
 427     (setf (gethash "foobar" table) :foo)
 428     (assert (eq :|123| (gethash '(1 2 3 ! 6) table)))
 429     (assert (eq :|234| (gethash #(2 3 4 0 2 1 a) table)))
 430     (assert (eq :foo (gethash '(#\f #\o #\o 1 2 3) table)))
 431     (assert (eq 'head-eql (hash-table-test table))))
 432   (let ((table (make-hash-table :test #'head-eql)))
 433     (setf (gethash #(1 2 3 4) table) :|123|)
 434     (setf (gethash '(2 3 4 7) table) :|234|)
 435     (setf (gethash "foobar" table) :foo)
 436     (assert (eq :|123| (gethash '(1 2 3 ! 6) table)))
 437     (assert (eq :|234| (gethash #(2 3 4 0 2 1 a) table)))
 438     (assert (eq :foo (gethash '(#\f #\o #\o 1 2 3) table)))
 439     (assert (eq 'head-eql (hash-table-test table)))))
 440
 441 (with-test (:name :make-hash-table/hash-fun)
 442   (let ((table (make-hash-table
 443                 :test #'=
 444                 :hash-function (lambda (x)
 445                                  (sxhash (coerce (abs x) 'double-float))))))
 446     (incf (gethash 1 table 0))
 447     (incf (gethash 1.0f0 table))
 448     (incf (gethash 1.0d0 table))
 449     (incf (gethash (complex 1.0f0 0.0f0) table))
 450     (incf (gethash (complex 1.0d0 0.0d0) table))
 451     (assert (= 5 (gethash 1 table)))
 452     (assert (eq '= (hash-table-test table)))))
 453
 454 ;;; success