tests/hash-table.impure.lisp

   1 ;;; HASH TABLES
   2
   3 ;;; Keep moving everything that can move during each GC
   4 #+generational (setf (generation-number-of-gcs-before-promotion 0) 1000000)
   5
   6 ;;; Check for GC invariant loss during weak table creation.
   7 ;;; This didn't always fail, but might have, and now shouldn't.
   8 (defglobal *number-of-weak-tables* 0)
   9 (defun make-weak-key-table () (make-hash-table :weakness :key))
  10 (defun something-useless (x) (list x))
  11 (defun weak-table-allocation-test ()
  12   (let ((thread
  13          (sb-thread:make-thread
  14            (lambda ()
  15              (loop
  16                (sleep .0001)
  17                (gc)
  18                (sb-thread:barrier (:read))
  19                (when (> *number-of-weak-tables* 1000) (return)))))))
  20     (loop repeat 1001 do
  21       (something-useless (make-weak-key-table))
  22       (incf *number-of-weak-tables*)
  23       (sb-thread:barrier (:write)))
  24     (sb-thread:join-thread thread)))
  25 ;;; Interpreted code is probably too slow to be useful in this test
  26 (compile 'weak-table-allocation-test)
  27
  28 (with-test (:name :weak-table-gc-invariant :skipped-on (not :sb-thread))
  29   (weak-table-allocation-test))
  30
  31 (defun vector-flag-bits (v)
  32   (logand (ash (sb-kernel:get-header-data v) (- sb-vm:array-flags-data-position)) #xFF))
  33
  34 (defun is-address-sensitive (tbl)
  35   (logtest (vector-flag-bits (sb-impl::hash-table-pairs tbl))
  36            sb-vm:vector-addr-hashing-flag))
  37
  38 (with-test (:name (hash-table :eql-hash-symbol-not-eq-based))
  39   ;; If you ask for #'EQ as the test, then everything is address-sensitive,
  40   ;; though this is not technically a requirement.
  41   (let ((ht (make-hash-table :test 'eq)))
  42     (setf (gethash (make-symbol "GOO") ht) 1)
  43     (assert (is-address-sensitive ht)))
  44   ;; EQUAL tables don't use SYMBOL-HASH
  45   (dolist (test '(eql equalp))
  46     (let ((ht (make-hash-table :test test)))
  47       (setf (gethash (make-symbol "GOO") ht) 1)
  48       (assert (not (is-address-sensitive ht))))))
  49
  50 (defclass ship () ())
  51
  52 (with-test (:name (hash-table :equal-hash-std-object-not-eq-based))
  53   (dolist (test '(eq eql))
  54     (let ((ht (make-hash-table :test test)))
  55       (setf (gethash (make-instance 'ship) ht) 1)
  56       (assert (is-address-sensitive ht))))
  57   ;; EQUAL tables don't use INSTANCES-SXHASH
  58   (dolist (test '(equalp))
  59     (let ((ht (make-hash-table :test test)))
  60       (setf (gethash (make-instance 'ship) ht) 1)
  61       (assert (not (is-address-sensitive ht))))))
  62
  63 (defvar *gc-after-rehash-me* nil)
  64 (defvar *rehash+gc-count* 0)
  65
  66 (sb-int:encapsulate
  67  'sb-impl::rehash
  68  'force-gc-after-rehash
  69  (compile nil '(lambda (f kvv hv iv nv tbl)
  70                 (prog1 (funcall f kvv hv iv nv tbl)
  71                   (when (eq tbl *gc-after-rehash-me*)
  72                     (incf *rehash+gc-count*)
  73                     (sb-ext:gc))))))
  74
  75 ;;; Check that when growing a weak hash-table we don't try to
  76 ;;; reference kvv -> table -> hash-vector
  77 ;;; until the hash-vector is correct with respect to the KV vector.
  78 ;;; For this test, we need address-sensitive keys in a table with a
  79 ;;; hash-vector. EQ tables don't have a hash-vector, so that's no good.
  80 ;;; EQL tables don't hash symbols address-sensitively,
  81 ;;; so use a bunch of cons cells.
  82 (with-test (:name :gc-while-growing-weak-hash-table
  83             :skipped-on (or :mark-region-gc :gc-stress))
  84   (let ((h (make-hash-table :weakness :key)))
  85     (setq *gc-after-rehash-me* h)
  86     (dotimes (i 50) (setf (gethash (list (gensym)) h) i))
  87     (setf (gethash (cons 1 2) h) 'foolz))
  88   (assert (>= *rehash+gc-count* 10)))
  89
  90 (defstruct this x)
  91 (defstruct that x)
  92 (with-test (:name :struct-in-list-equal-hash)
  93   (let ((ht (make-hash-table :test 'equal)))
  94     (dotimes (i 100)
  95       (let ((key (cons (make-this :x i) (make-that :x i))))
  96         (setf (gethash key ht)  i)))
  97     ;; This used to degenerate the hash table into a linked list,
  98     ;; because all instances of THIS hashed to the same random fixnum
  99     ;; and all instances of THAT hashed to the same random fixnum
 100     ;; (different from THIS, not that it mattered), and the hash
 101     ;; of the cons was therefore the same.
 102     (let ((bins-used
 103             (count-if #'plusp (sb-impl::hash-table-index-vector ht))))
 104       ;; It's probably even better spread out than this many bins,
 105       ;; but let's not be too sensitive to the exact bin count in use.
 106       ;; It's a heck of a lot better than everything in 1 bin.
 107       (assert (> bins-used 40)))))
 108
 109 (with-test (:name :rehash-no-spurious-address-sensitivity)
 110   (let ((h (make-hash-table :test 'eq)))
 111     (dotimes (i 100)
 112       (setf (gethash i h) (- i)))
 113     (assert (= (vector-flag-bits (sb-impl::hash-table-pairs h))
 114                sb-vm:vector-hashing-flag))))
 115
 116 (defmacro kv-vector-needs-rehash (x) `(svref ,x 1))
 117 ;;; EQL tables no longer get a hash vector, so the GC has to decide
 118 ;;; for itself whether key movement forces rehash.
 119 ;;; Let's make sure that works.
 120 ;;; I don't love the idea of skipping this, because mark-region *can* move keys
 121 ;;; though it generally doesn't. After I started to hack up the test to query
 122 ;;; whether keys moved, it looked pretty disastrous. Need to think of way.
 123 (with-test (:name :address-insensitive-eql-hash
 124                   :skipped-on :mark-region-gc)
 125   (let ((tbl (make-hash-table :size 20)))
 126     (dotimes (i 5)
 127       (let ((key (coerce i 'double-float)))
 128         (setf (gethash key tbl) (sb-kernel:get-lisp-obj-address key)))
 129       (let ((key (coerce i '(complex single-float))))
 130         (setf (gethash key tbl) (sb-kernel:get-lisp-obj-address key)))
 131       (let ((key (make-symbol (make-string (1+ i) :initial-element #\a))))
 132         (setf (gethash key tbl) (sb-kernel:get-lisp-obj-address key))))
 133     (assert (= (vector-flag-bits (sb-impl::hash-table-pairs tbl))
 134                sb-vm:vector-hashing-flag)) ; noo address-based key
 135     (let ((foo (cons 0 0)))
 136       (setf (gethash foo tbl) foo)
 137       (remhash foo tbl))
 138     ;; now we've added an address-based key (but removed it)
 139     (assert (= (vector-flag-bits (sb-impl::hash-table-pairs tbl))
 140                (+ sb-vm:vector-addr-hashing-flag
 141                   sb-vm:vector-hashing-flag)))
 142     (gc)
 143     (let ((n-keys-moved 0))
 144       (maphash (lambda (key value)
 145                  (unless (= value (sb-kernel:get-lisp-obj-address key))
 146                    (incf n-keys-moved)))
 147                tbl)
 148       (assert (plusp n-keys-moved))
 149       ;; keys were moved, the table is marked as address-based,
 150       ;; but no key that moved forced a rehash
 151       (assert (zerop (kv-vector-needs-rehash
 152                       (sb-impl::hash-table-pairs tbl)))))
 153     ;; the vector type is unchanged
 154     (assert (= (vector-flag-bits (sb-impl::hash-table-pairs tbl))
 155                (+ sb-vm:vector-addr-hashing-flag
 156                   sb-vm:vector-hashing-flag)))
 157     (setf (gethash (cons 1 2) tbl) 'one)
 158     (setf (gethash (cons 3 4) tbl) 'two)
 159     (setf (gethash (cons 5 6) tbl) 'three)
 160     (gc)
 161     ;; now some key should have moved and forced a rehash
 162     (assert (not (zerop (kv-vector-needs-rehash
 163                          (sb-impl::hash-table-pairs tbl)))))
 164     ;; This next thing is impossible to test without some hacks -
 165     ;; we want to see that the addr-hashing flag can be cleared
 166     ;; if, on rehash, there is currently no address-sensitive key
 167     ;; in the table.
 168     ;; This could happen in the real world, but it's actually very
 169     ;; difficult to construct an example because it requires controlling
 170     ;; the addresses of objects.  But the 'rehash' bit had to first get
 171     ;; set, and then any key that could cause the bit to get set
 172     ;; has to be removed, which means we had to have successfully found
 173     ;; and removed address-sensitive keys despite having obsolete hashes.
 174     ;; That could only happen by random chance.
 175     ;; However, by stomping on a few keys, we can simulate it.
 176     (let ((pairs (sb-impl::hash-table-pairs tbl)))
 177       (loop for i from 2 below (length pairs) by 2
 178             when (consp (aref pairs i))
 179             do (setf (aref pairs i) i))) ; highly illegal!
 180     ;; try to find an address-sensitive key
 181     (assert (not (gethash '(foo) tbl)))
 182     (assert (= (vector-flag-bits (sb-impl::hash-table-pairs tbl))
 183                ;; Table is no longer address-sensitive
 184                sb-vm:vector-hashing-flag))))
 185
 186 (defun actually-address-sensitive-p (ht)
 187   (let* ((hashfun (sb-impl::hash-table-hash-fun ht))
 188          (some-actually-address-sensitive-key))
 189     (maphash (lambda (key value)
 190                (declare (ignore value))
 191                (multiple-value-bind (hash address-sensitive)
 192                    (funcall hashfun key)
 193                  (declare (ignore hash))
 194                  (when address-sensitive
 195                    (setf some-actually-address-sensitive-key t))))
 196              ht)
 197     some-actually-address-sensitive-key))
 198
 199 (with-test (:name :unsynchronized-clrhash-no-lock)
 200   (let ((ht (make-hash-table)))
 201     (setf (gethash 1 ht) 2)
 202     (clrhash ht)
 203     (assert (not (sb-impl::hash-table-%lock ht)))))
 204
 205 ;;; Prove that our completely assinine API with regard to locking works,
 206 ;;; which is to say, if the user explicitly locks an implicitly locked table,
 207 ;;; there is no "Recursive lock attempt" error.
 208 ;;; In general, we can't discern between a lock that preserves table invariants
 209 ;;; at the implementation level, or the user level. But I guess with "system" locks
 210 ;;; it's sort of OK because reentrance isn't really possible, and internally
 211 ;;; the table considers the lock to be a "system" lock.
 212 (with-test (:name :weak-hash-table-with-explicit-lock)
 213   (let ((h (make-hash-table :weakness :key)))
 214     (with-locked-hash-table (h) (setf (gethash 'foo h) 1))))
 215
 216 (with-test (:name :hash-table-iterator-no-notes
 217                   :fails-on (:or :arm :ppc :ppc64))
 218   (let ((f
 219          (checked-compile
 220           '(lambda (h)
 221             (declare (optimize speed))
 222             (let ((n 0))
 223               (declare (fixnum n))
 224               ;; Silly test - count items, unrolling by 2
 225               (with-hash-table-iterator (iter h)
 226                 (loop
 227                   (let ((a (iter)))
 228                     (unless a (return)))
 229                   (let ((a (iter)))
 230                     (unless a
 231                       (incf n)
 232                       (return)))
 233                   (incf n 2)))
 234               n))
 235           :allow-notes nil)))
 236     ;; Test F
 237     (maphash (lambda (classoid layout)
 238                (declare (ignore layout))
 239                (let ((subclasses
 240                       (sb-kernel:classoid-subclasses classoid)))
 241                  (when (hash-table-p subclasses)
 242                    (assert (= (hash-table-count subclasses)
 243                               (funcall f subclasses))))))
 244              (sb-kernel:classoid-subclasses (sb-kernel:find-classoid 't)))))