mirror of
git://git.code.sf.net/p/sbcl/sbcl
synced 2026-09-10 07:26:40 -04:00
272 lines
12 KiB
Common Lisp
272 lines
12 KiB
Common Lisp
;;; HASH TABLES
|
|
|
|
#-sb-thread (invoke-restart 'run-tests::skip-file)
|
|
(use-package "SB-THREAD")
|
|
(use-package "SB-SYS")
|
|
|
|
(defvar *table-under-test* nil)
|
|
|
|
;;; If *table-under-test* is bound to a hash-table, then cause it to have
|
|
;;; half as many buckets as it would ordinarily get after enlarging.
|
|
(sb-int:encapsulate 'sb-impl::recompute-ht-vector-sizes 'collision-inducement
|
|
(compile nil
|
|
'(lambda (fn tbl)
|
|
(multiple-value-bind (new-size new-n-buckets) (funcall fn tbl)
|
|
(values new-size
|
|
(ash new-n-buckets
|
|
(if (and (eq tbl *table-under-test*)
|
|
;; Not for flat tables though
|
|
;; because they use the number of
|
|
;; buckets as their size. See
|
|
;; SB-IMPL::GROW-HASH-TABLE.
|
|
(not (sb-impl::flat-hash-table-p tbl)))
|
|
-1
|
|
0)))))))
|
|
|
|
;;; Keep moving everything that can move during each GC
|
|
#+generational (setf (generation-number-of-gcs-before-promotion 0) 1000000)
|
|
|
|
(defvar *errors* nil)
|
|
|
|
(defun oops (e)
|
|
(setf *errors* e)
|
|
(format t "~&oops: ~A in ~S~%" e *current-thread*)
|
|
(sb-debug:print-backtrace)
|
|
(throw 'done nil))
|
|
|
|
(defglobal *terminate-now* nil)
|
|
(defmacro forever (&rest forms)
|
|
#+use-terminate-thread `(loop ,@forms)
|
|
#-use-terminate-thread
|
|
`(loop (barrier (:read))
|
|
(when *terminate-now* (return))
|
|
,@forms))
|
|
|
|
(defun end-all (threads)
|
|
#+use-terminate-thread (mapc #'terminate-thread threads)
|
|
#-use-terminate-thread
|
|
(progn (setq *terminate-now* t)
|
|
(barrier (:write))
|
|
(mapc #'join-thread threads)
|
|
(setq *terminate-now* nil)))
|
|
|
|
(with-test (:name (hash-table :unsynchronized)
|
|
;; FIXME: This test occasionally eats out craploads
|
|
;; of heap instead of expected error early. Not 100%
|
|
;; sure if it would finish as expected, but since it
|
|
;; hits swap on my system I'm not likely to find out
|
|
;; soon. Disabling for now. -- nikodemus
|
|
:broken-on :sbcl)
|
|
;; We expect a (probable) error here: concurrent readers and writers
|
|
;; on an unsynchronized hash-table are not expected to work.
|
|
(let* ((hash (make-hash-table))
|
|
(*errors* nil)
|
|
(threads (list (make-kill-thread
|
|
(lambda ()
|
|
(catch 'done
|
|
(handler-bind ((serious-condition 'oops))
|
|
(forever
|
|
;;(princ "1") (force-output)
|
|
(setf (gethash (random 100) hash) 'h)))))
|
|
:name "writer")
|
|
(make-kill-thread
|
|
(lambda ()
|
|
(catch 'done
|
|
(handler-bind ((serious-condition 'oops))
|
|
(forever
|
|
;;(princ "2") (force-output)
|
|
(remhash (random 100) hash)))))
|
|
:name "reader")
|
|
(make-kill-thread
|
|
(lambda ()
|
|
(catch 'done
|
|
(handler-bind ((serious-condition 'oops))
|
|
(forever
|
|
(sleep (random 1.0))
|
|
(sb-ext:gc)))))
|
|
:name "collector"))))
|
|
(unwind-protect
|
|
(sleep 10)
|
|
(end-all threads))))
|
|
|
|
|
|
;;; Structures are hashed by their address for any kind of standard hash-table
|
|
;;; other than an EQUALP. This makes them good candidates for exercising gethash-concurrency
|
|
;;; tests, because we can force a rehash that changes their hash.
|
|
(defstruct (teststruct (:constructor make-teststruct (val))) val)
|
|
|
|
;;; The new logic for concurrent GETHASH allows multiple threads each to decide to
|
|
;;; invoke a GC-provoked rehash, but since we do not want concurrent writers,
|
|
;;; only one thread actually rehashes and the other(s) perform linear search.
|
|
;;; This is strictly less work than multiple rehashes and should give improved throughput
|
|
;;; since no thread waits on rehash. The count of number of linear searches performed
|
|
;;; is no longer collected unless explicitly compiled in.
|
|
(defmacro with-test-setup ((array (table constructor)) &body body)
|
|
;; Using fixnums as hash-table keys does not engender a thorough enough test
|
|
;; as they will not cause the table to need rehash due to GC.
|
|
;; Using symbols won't work either because they hash stably under EQL
|
|
;; (but not under EQ) so let's use a bunch of cons cells.
|
|
`(let* ((,array (coerce (loop for i from 0 repeat 100
|
|
collect (if (oddp i) (make-teststruct i) (cons i i)))
|
|
'vector))
|
|
(,table ,constructor)
|
|
(*table-under-test* (if shrinkp ,table nil)))
|
|
(when shrinkp
|
|
;; start with half as many buckets as usual
|
|
(let ((v (sb-impl::hash-table-index-vector ,table)))
|
|
(setf (sb-impl::hash-table-index-vector ,table) (subseq v 0 (/ (length v) 2)))))
|
|
,@body
|
|
#+hash-table-metrics
|
|
(format t "~&::: INFO: GC-forced-rehash=~D rehash-invalid=~D stamp-changed=~D~%"
|
|
(sb-impl::hash-table-n-rehash+find ,table)
|
|
(sb-impl::hash-table-n-rehash-again ,table)
|
|
(sb-impl::hash-table-n-stamp-change ,table))))
|
|
|
|
;;; Do *NOT* use (gc :full) in the following tests - a full GC causes all objects
|
|
;;; to be promoted into the highest normal generation, which achieves nothing,
|
|
;;; and runs the collector less often (because it's slower) relative to the total
|
|
;;; test time, making the test less usesful. It's fine for everything in gen0
|
|
;;; to stay in gen0, which basically never promotes due to the ludicrously high
|
|
;;; threshold set for number of GCs between promotions.
|
|
|
|
(defparameter *sleep-delay-max* .025)
|
|
|
|
(with-test (:name (hash-table :synchronized))
|
|
(dolist (shrinkp '(nil t))
|
|
(with-test-setup (keys (hash (make-hash-table :synchronized t)))
|
|
(let* ((*errors* nil)
|
|
(threads
|
|
(list (make-join-thread
|
|
(lambda () (forever (setf (gethash (aref keys (random 100)) hash) 'h)))
|
|
:name "writer")
|
|
(make-join-thread
|
|
(lambda () (forever (remhash (aref keys (random 100)) hash)))
|
|
:name "remover")
|
|
(make-join-thread
|
|
(lambda ()
|
|
(forever (sleep (random *sleep-delay-max*))
|
|
(sb-ext:gc)))
|
|
:name "GC"))))
|
|
(unwind-protect (sleep 1)
|
|
(end-all threads))
|
|
(assert (not *errors*))))))
|
|
|
|
(defun test-concurrent-gethash (table-kind)
|
|
(dolist (shrinkp '(nil t))
|
|
(with-test-setup (keys (table (make-hash-table :test table-kind)))
|
|
(let ((*errors* nil)
|
|
(expected (make-array 100 :initial-element nil))
|
|
(actions (make-array 3 :element-type 'sb-ext:word :initial-element 0)))
|
|
(loop repeat 50
|
|
do (let ((i (random 100)))
|
|
(setf (gethash (aref keys i) table) i)
|
|
(setf (aref expected i) t)))
|
|
(labels
|
|
((reader (n random-state)
|
|
(catch 'done
|
|
(handler-bind ((serious-condition 'oops))
|
|
(forever
|
|
(let* ((i (random 100))
|
|
(x (gethash (aref keys i) table)))
|
|
(atomic-incf (aref actions n))
|
|
(when (and (zerop (random 100 random-state))
|
|
(not (sb-impl::flat-hash-table-p table)))
|
|
(let* ((kvv (sb-impl::hash-table-pairs table))
|
|
(epoch (svref kvv 1)))
|
|
;; Randomly force a rehash (as if by GC) so that we get "invalid" rehashes,
|
|
;; meaning that the ending state is still need-to-rehash.
|
|
(sb-ext:cas (svref kvv 1) epoch (logior epoch 1))))
|
|
(cond ((aref expected i) (assert (eq x i)))
|
|
(t (assert (not x)))))))))
|
|
(start-reader (n)
|
|
(make-kill-thread #'reader :name (format nil "reader ~d" (1+ n))
|
|
:arguments (list n (make-random-state t)))))
|
|
(let ((threads
|
|
(list (start-reader 0)
|
|
(start-reader 1)
|
|
(start-reader 2)
|
|
(make-kill-thread
|
|
(lambda ()
|
|
(catch 'done
|
|
(handler-bind ((serious-condition 'oops))
|
|
(forever (sleep (random *sleep-delay-max*))
|
|
(sb-ext:gc)))))
|
|
:name "collector"))))
|
|
(unwind-protect (sleep 1)
|
|
(end-all threads))
|
|
#+hash-table-metrics
|
|
(let ((n-gethash (reduce #'+ actions))
|
|
(n-lsearch (sb-impl::hash-table-n-lsearch table)))
|
|
(format t "~&::: INFO: GETHASH count = ~D = ~D, lsearch=~d (~f%)~%"
|
|
actions
|
|
n-gethash
|
|
;; With the GC frequency as high as it is for this test,
|
|
;; we can get more than 1 lookup in 10^5 needing linear scan.
|
|
;; A "normal" amount of GCing often sees this as low as 0.
|
|
n-lsearch (/ n-lsearch n-gethash)))
|
|
(assert (not *errors*))))))))
|
|
(compile 'test-concurrent-gethash)
|
|
|
|
(with-test (:name (hash-table :parallel-readers-eq-table))
|
|
(test-concurrent-gethash 'eq))
|
|
(with-test (:name (hash-table :parallel-readers-eql-table))
|
|
(test-concurrent-gethash 'eql))
|
|
(with-test (:name (hash-table :parallel-readers-equal-table))
|
|
(test-concurrent-gethash 'equal))
|
|
|
|
(with-test (:name (hash-table :single-accessor :parallel-gc))
|
|
(dolist (shrinkp '(nil t))
|
|
(with-test-setup (keys (hash (make-hash-table)))
|
|
(let ((*errors* nil))
|
|
(let ((threads
|
|
(list (make-kill-thread
|
|
(lambda ()
|
|
(handler-bind ((serious-condition 'oops))
|
|
(forever
|
|
(let* ((i (random 100))
|
|
(k (aref keys i))
|
|
(val (gethash k hash)))
|
|
(cond (val
|
|
(assert (eq val i))
|
|
(assert (remhash k hash)))
|
|
(t
|
|
(setf (gethash k hash) i)))))))
|
|
:name "accessor")
|
|
(make-kill-thread
|
|
(lambda ()
|
|
(handler-bind ((serious-condition 'oops))
|
|
(forever
|
|
(sleep (random *sleep-delay-max*))
|
|
(sb-ext:gc))))
|
|
:name "collector"))))
|
|
(unwind-protect (sleep 1)
|
|
(end-all threads))
|
|
(assert (not *errors*)))))))
|
|
|
|
;;; Stress GROW-HASH-TABLE's optimization wherein no rehashing may be
|
|
;;; done if the index vector is not growing.
|
|
(with-test (:name (hash-table :not-growing-index-vector :parallel-gc))
|
|
(let ((*errors* nil))
|
|
(let ((threads
|
|
(list (make-kill-thread
|
|
(lambda ()
|
|
(handler-bind ((serious-condition 'oops))
|
|
(forever
|
|
(let ((h (make-hash-table))
|
|
(l (loop for i below (random 200)
|
|
collect (make-teststruct i))))
|
|
(loop for x in l do (setf (gethash x h) x))
|
|
(loop for x in l
|
|
do (assert (eq (gethash x h) x)))))))
|
|
:name "worker")
|
|
(make-kill-thread
|
|
(lambda ()
|
|
(handler-bind ((serious-condition 'oops))
|
|
(forever
|
|
(sb-ext:gc :full t)
|
|
(sleep (random *sleep-delay-max*)))))
|
|
:name "collector"))))
|
|
(unwind-protect (sleep 1)
|
|
(end-all threads))
|
|
(assert (not *errors*)))))
|