test/tests-v2.lisp

   1 ;;;; -*- Mode: LISP; Syntax: ANSI-Common-lisp; Base: 10; Package: BORDEAUX-THREADS-2/TEST -*-
   2 ;;;; The above modeline is required for Genera. Do not change.
   3
   4 (in-package :bordeaux-threads-2/test)
   5
   6 (in-suite :bordeaux-threads-2)
   7
   8 ;;;
   9 ;;; Threads
  10 ;;;
  11
  12 (test join-thread.return-value
  13   (is (eql 0 (join-thread (make-thread (lambda () 0))))))
  14
  15 (test current-thread.not-null
  16   (is (current-thread)))
  17
  18 (test current-thread.eql
  19   (is (eql (current-thread)
  20            (current-thread))))
  21
  22 #+#.(bt2::implemented-p* 'bt2:join-thread)
  23 (test current-thread.identity
  24   (let ((thread (make-thread #'current-thread)))
  25     (is (eql thread (join-thread thread)))))
  26
  27 #+#.(bt2::implemented-p* 'bt2:join-thread)
  28 (test current-thread.special
  29   (let ((thread (make-thread (lambda () bt2::*current-thread*))))
  30     (is (eql thread (join-thread thread)))))
  31
  32 #+#.(bt2::implemented-p* 'bt2:join-thread)
  33 (test current-thread.error
  34   (let ((thread (make-thread (lambda ()
  35                                (error "FOOBAR"))
  36                              :trap-conditions t)))
  37     (signals abnormal-exit (join-thread thread))))
  38
  39 (test threadp.should-identify-threads
  40   (is (threadp (current-thread)))
  41   (is (threadp (make-thread (lambda () t))))
  42   (is (not (threadp (make-lock)))))
  43
  44 (test thread-name.should-retrieve-thread-name
  45   (is (equal "foo" (thread-name
  46                     (make-thread (lambda () t) :name "foo")))))
  47
  48 (test thread-name.all-strings
  49   (is (every #'(lambda (thread) (stringp (thread-name thread)))
  50              (all-threads))))
  51
  52 (defparameter *some-special* :global-value)
  53
  54 (test default-special-bindings.sees-global-bindings
  55   (let* ((*some-special* :local-value)
  56          (*default-special-bindings*
  57            `((*some-special* . (list :more *some-special*))
  58              ,@*default-special-bindings*))
  59          (thread (make-thread (lambda () *some-special*))))
  60     (is (equal '(:more :local-value) (join-thread thread)))))
  61
  62 (defparameter *shared* 0)
  63 (defparameter *lock* (make-lock))
  64
  65 #+#.(bt2::implemented-p* 'bt2:thread-yield)
  66 (test threads.interaction
  67   ;; this simple test generates N process. Each process grabs and
  68   ;; releases the lock until SHARED has some value, it then
  69   ;; increments SHARED. the outer code first sets shared 1 which
  70   ;; gets the thing running and then waits for SHARED to reach some
  71   ;; value. this should, i think, stress test locks.
  72   (setf *shared* 0)
  73   (flet ((worker (i)
  74            (loop
  75              do (with-lock-held (*lock*)
  76                   (when (= i *shared*)
  77                     (incf *shared*)
  78                     (return)))
  79                 (thread-yield)
  80                 (sleep 0.001))))
  81     (let* ((procs (loop
  82                     for i from 1 upto 2
  83                     ;; create a new binding to protect against implementations that
  84                     ;; mutate instead of binding the loop variable
  85                     collect (let ((i i))
  86                               (make-thread (lambda ()
  87                                              (funcall #'worker i))
  88                                            :name (format nil "threads.interaction Proc #~D" i))))))
  89       (with-lock-held (*lock*)
  90         (incf *shared*))
  91       (block test
  92         (loop
  93           until (with-lock-held (*lock*)
  94                   (= (1+ (length procs)) *shared*))
  95           do (with-lock-held (*lock*)
  96                (is (>= (1+ (length procs)) *shared*)))
  97              (thread-yield)
  98              (sleep 0.001))))))
  99
 100 (test all-threads.contains-threads
 101   (is (every #'threadp (all-threads))))
 102
 103 (test all-threads.contains-new-thread
 104   (let ((thread (make-thread (lambda () (sleep 60))
 105                              :name "all-threads.contains-new-thread")))
 106     (is (find thread (all-threads)))))
 107
 108 #+#.(bt2::implemented-p* 'bt2:interrupt-thread)
 109 (test interrupt-thread.throw
 110   (let ((thread (make-thread (lambda ()
 111                                (catch 'new-thread
 112                                  (sleep 60)
 113                                  'not-interrupted))
 114                              :name "interrupt-thread.throw")))
 115     (sleep 1)
 116     (is (threadp
 117          (interrupt-thread thread (lambda ()
 118                                     (throw 'new-thread 'interrupted)))))
 119     (is (eql 'interrupted (join-thread thread)))))
 120
 121 (test thread-alive-p.new-thread
 122   (is (thread-alive-p (make-thread (lambda () (sleep 60))
 123                                    :name "thread-alive-p.new-thread"))))
 124
 125 #+#.(bt2::implemented-p* 'bt2:join-thread)
 126 (test thread-termination.unwind-protect
 127   (setf *some-special* nil)
 128   #+abcl
 129   (skip "DESTROY-THREAD does not execute UNWIND-PROTECT cleanup forms.
 130          Filed https://github.com/armedbear/abcl/issues/430.")
 131   #-abcl
 132   (flet ((thread-fn ()
 133            (setf *some-special* :entered)
 134            (unwind-protect
 135                 (progn
 136                   (sleep 5)
 137                   (setf *some-special* :failed))
 138              (when (eq *some-special* :entered)
 139                (setf *some-special* :success)))))
 140     (let ((thread (make-thread #'thread-fn)))
 141       (sleep 1)
 142       (destroy-thread thread)
 143       (signals abnormal-exit
 144         (join-thread thread))
 145       (is (eq :success *some-special*)))))
 146
 147 (define-condition test-error (error) ())
 148
 149 #+#.(bt2::implemented-p* 'bt2:join-thread)
 150 (test thread-termination.handle-condition
 151   (flet ((thread-fn ()
 152            (error 'test-error)))
 153     (let ((thread (make-thread #'thread-fn :trap-conditions t)))
 154       (handler-case
 155           (join-thread thread)
 156         (abnormal-exit (e)
 157           (is (typep (abnormal-exit-condition e) 'test-error)))))))
 158
 159 #+#.(bt2::implemented-p* 'bt2:destroy-thread)
 160 (test destroy-thread.terminates
 161   (let ((thread (make-thread (lambda () (sleep 3))
 162                              :name "destroy-thread.terminates")))
 163     (is (threadp (destroy-thread thread)))
 164     (sleep 5)
 165     (is-false (thread-alive-p thread))))
 166
 167 #+#.(bt2::implemented-p* 'bt2:destroy-thread)
 168 (test join-thread.error-if-destroyed
 169   (let ((thread (make-thread (lambda () (sleep 3))
 170                              :name "join-thread.error-if-destroyed")))
 171     (destroy-thread thread)
 172     (signals abnormal-exit (join-thread thread))))
 173
 174 #+#.(bt2::implemented-p* 'bt2:destroy-thread)
 175 (test destroy-thread.error-if-exited
 176   (let ((thread (make-thread (lambda () (sleep 3))
 177                              :name "destroy-thread.error-if-exited")))
 178     (join-thread thread)
 179     (signals bordeaux-threads-error (destroy-thread thread))))
 180 \f
 181
 182 ;;;
 183 ;;; Non-recursive Locks
 184 ;;;
 185
 186 (test lock.constructor
 187   (let ((lock (make-lock :name "Name")))
 188     (is (lockp lock))
 189     (is (native-lock-p (lock-native-lock lock)))
 190     (is (equal "Name" (lock-name lock)))))
 191
 192 (test acquire-lock.no-contention
 193   (let ((lock (make-lock)))
 194     (is (acquire-lock lock :wait t))
 195     (is (lockp (release-lock lock)))
 196     (is (acquire-lock lock :wait nil))
 197     (is (lockp (release-lock lock)))))
 198
 199 (test acquire-lock.try-lock
 200   (let ((lock (make-lock)))
 201     (make-thread (lambda ()
 202                    (with-lock-held (lock)
 203                      (sleep 5)))
 204                  :name "acquire-lock.try-lock")
 205     (sleep 1)
 206     (is-false (acquire-lock lock :wait nil))))
 207
 208 (test acquire-lock.timeout-expires
 209   (let ((lock (make-lock)))
 210     (make-thread (lambda ()
 211                    (with-lock-held (lock)
 212                      (sleep 5)))
 213                  :name "acquire-lock.timeout-expires")
 214     (sleep 1)
 215     (is (null (acquire-lock lock :timeout .1)))))
 216
 217 #+#.(bt2::implemented-p* 'bt2:with-lock-held)
 218 (test with-lock-held.timeout-no-contention-acquired
 219   (let ((lock (make-lock)))
 220     (is (eql :ok (with-lock-held (lock :timeout .1) :ok)))))
 221
 222 #+#.(bt2::implemented-p* 'bt2:with-lock-held)
 223 (test with-lock-held.timeout-expires
 224   (let ((lock (make-lock)))
 225     (make-thread (lambda ()
 226                    (with-lock-held (lock)
 227                      (sleep 5)))
 228                  :name "with-lock-held.timeout-expires")
 229     (sleep 1)
 230     (is (eql :timeout
 231              (block ok
 232                (with-lock-held (lock :timeout .1)
 233                  (return-from ok :ok))
 234                :timeout)))))
 235
 236 ;;;
 237 ;;; Recursive Locks
 238 ;;;
 239
 240 #+#.(bt2::implemented-p* 'bt2:acquire-recursive-lock)
 241 (test acquire-recursive-lock
 242   (let ((test-lock (make-recursive-lock))
 243         (results (make-array 4 :adjustable t :fill-pointer 0))
 244         (results-lock (make-lock))
 245         (threads ()))
 246     (flet ((add-result (r)
 247              (with-lock-held (results-lock)
 248                (vector-push-extend r results))))
 249       (dotimes (i 2)
 250         (push (make-thread
 251                #'(lambda ()
 252                    (when (acquire-recursive-lock test-lock)
 253                      (unwind-protect
 254                           (progn
 255                             (add-result :enter)
 256                             (sleep 1)
 257                             (add-result :leave))
 258                        (release-recursive-lock test-lock))))
 259                :name (format nil "acquire-recursive-lock Proc #~D" i))
 260               threads)))
 261     (map 'nil #'join-thread threads)
 262     (is (equalp #(:enter :leave :enter :leave) results))))
 263
 264 #+#.(bt2::implemented-p* 'bt2:acquire-recursive-lock)
 265 (test acquire-recursive-lock.no-contention
 266   (let ((lock (make-recursive-lock)))
 267     (is (acquire-recursive-lock lock :wait t))
 268     (is (recursive-lock-p (release-recursive-lock lock)))
 269     (is (acquire-recursive-lock lock :wait nil))
 270     (is (recursive-lock-p (release-recursive-lock lock)))))
 271
 272 #+#.(bt2::implemented-p* 'bt2:with-recursive-lock-held)
 273 (test acquire-recursive-lock.try-lock
 274   (let ((lock (make-recursive-lock)))
 275     (make-thread (lambda ()
 276                    (with-recursive-lock-held (lock)
 277                      (sleep 5)))
 278                  :name "acquire-recursive-lock.try-lock")
 279     (sleep 1)
 280     (is (null (acquire-recursive-lock lock :wait nil)))))
 281
 282 #+#.(bt2::implemented-p* 'bt2:with-recursive-lock-held)
 283 (test acquire-recursive-lock.timeout-expires
 284   (let ((lock (make-recursive-lock)))
 285     (make-thread (lambda ()
 286                    (with-recursive-lock-held (lock)
 287                      (sleep 5)))
 288                  :name "acquire-recursive-lock.timeout-expires")
 289     (sleep 1)
 290     (is (null (acquire-recursive-lock lock :timeout .1)))))
 291
 292 #+#.(bt2::implemented-p* 'bt2:with-recursive-lock-held)
 293 (test with-recursive-lock-held.timeout-no-contention-acquired
 294   (let ((lock (make-recursive-lock)))
 295     (is (eql :ok (with-recursive-lock-held (lock :timeout .1) :ok)))))
 296
 297 #+#.(bt2::implemented-p* 'bt2:with-recursive-lock-held)
 298 (test with-recursive-lock-held.timeout-expires
 299   (let ((lock (make-recursive-lock)))
 300     (make-thread (lambda ()
 301                    (with-recursive-lock-held (lock)
 302                      (sleep 5)))
 303                  :name "with-recursive-lock-held.timeout-expires")
 304     (sleep 1)
 305     (is (eql :timeout
 306              (block ok
 307                (with-recursive-lock-held (lock :timeout .1)
 308                  (return-from ok :ok))
 309                :timeout)))))
 310 \f
 311
 312 ;;;
 313 ;;; Semaphores
 314 ;;;
 315
 316 #+#.(bt2::implemented-p* 'bt2:make-semaphore)
 317 (test semaphore.typed
 318   (is (typep (make-semaphore) 'semaphore))
 319   (is (semaphorep (make-semaphore)))
 320   (is (not (semaphorep (make-lock)))))
 321
 322 #+#.(bt2::implemented-p* 'bt2:signal-semaphore)
 323 (test semaphore.signal
 324   (let ((sem (make-semaphore)))
 325     (make-thread (lambda () (sleep 0.4) (signal-semaphore sem)))
 326     (is-true (wait-on-semaphore sem))
 327     (is-true (signal-semaphore sem))))
 328
 329 #+#.(bt2::implemented-p* 'bt2:wait-on-semaphore :timeout)
 330 (test semaphore.wait-on-nonzero-creation
 331   "Tests that `WAIT-ON-SEMAPHORE` correctly returns T
 332 on a smaphore that was initialized to a non-zero value.
 333 In other words, it tests that `SIGNAL-SEMAPHORE` is not
 334 the only cause that can wake a waiter."
 335   (let ((sem (make-semaphore :count 1)))
 336     (is-true (wait-on-semaphore sem :timeout 0))))
 337
 338 #+#.(bt2::implemented-p* 'bt2:wait-on-semaphore :timeout)
 339 (test semaphore.wait.timeout
 340   (let* ((sem (make-semaphore)))
 341     (is-false (wait-on-semaphore sem :timeout 0))
 342     (is-false (wait-on-semaphore sem :timeout 0.2))))
 343
 344 #+#.(bt2::implemented-p* 'bt2:wait-on-semaphore)
 345 (test semaphore.signal-n-of-m
 346   (let* ((sem (make-semaphore :count 1))
 347          (lock (make-lock))
 348          (count 0)
 349          (waiter (lambda ()
 350                    (wait-on-semaphore sem)
 351                    (with-lock-held (lock) (incf count)))))
 352     (make-thread (lambda ()
 353                    (sleep 0.2)
 354                    (signal-semaphore sem :count 3)))
 355     (dotimes (v 5) (make-thread waiter))
 356     (sleep 0.3)
 357     (is (= 4 count))
 358     ;; release other waiters
 359     (is (eql t (signal-semaphore sem :count 2)))
 360     (sleep 0.1)
 361     (is (= 5 count))))
 362 \f
 363
 364 ;;;
 365 ;;; Condition variables
 366 ;;;
 367
 368 #+#.(bt2::implemented-p* 'bt2:make-condition-variable)
 369 (test condition-variable.typed
 370   (is (typep (make-condition-variable) 'condition-variable))
 371   (is (condition-variable-p (make-condition-variable)))
 372   (is (not (condition-variable-p (make-lock)))))
 373
 374 #+#.(bt2::implemented-p* 'bt2:condition-broadcast)
 375 (test condition-variable.concurrency
 376   (setf *shared* 0)
 377   (let ((cv (make-condition-variable)))
 378     (flet ((worker (i)
 379              (with-lock-held (*lock*)
 380                (loop
 381                  until (= i *shared*)
 382                  do (condition-wait cv *lock*)
 383                     (sleep (random .1)))
 384                (incf *shared*))
 385              (condition-broadcast cv)))
 386       (let ((num-procs 30))
 387         (dotimes (i num-procs)
 388           (let ((i (- num-procs i 1)))
 389             (make-thread (lambda ()
 390                            (sleep (random 1))
 391                            (funcall #'worker i))
 392                          :name (format nil "Proc #~D" i))))
 393         (with-lock-held (*lock*)
 394           (loop
 395             until (= num-procs *shared*)
 396             do (condition-wait cv *lock*)))
 397         (is (equal num-procs *shared*))))))
 398
 399 #+#.(bt2::implemented-p* 'bt2:condition-wait :timeout)
 400 (test condition-wait.timeout
 401   (let ((lock (make-lock))
 402         (cv (make-condition-variable))
 403         (flag nil))
 404     (make-thread (lambda () (sleep 0.4) (setf flag t)))
 405     (with-lock-held (lock)
 406       (let ((success
 407               (condition-wait cv lock :timeout 0.2)))
 408         #+abcl
 409         (skip "ABCL's condition-wait always returns T")
 410         #-abcl
 411         (is-false success)
 412         (is (null flag))
 413         (sleep 0.4)
 414         (is (eq t flag))))))
 415
 416 #+#.(bt2::implemented-p* 'bt2:condition-wait :timeout)
 417 (test condition-wait.lock-held-on-timeout
 418   "Tests that even when `CONDITION-WAIT` times out, it reacquires the
 419 lock."
 420   (let ((lock (make-lock :name "Test lock"))
 421         (cv (make-condition-variable :name "Test condition variable")))
 422     (with-lock-held (lock)
 423       (let ((success
 424               (condition-wait cv lock :timeout 2)))
 425         #+abcl
 426         (skip "ABCL's condition-wait always returns T")
 427         #-abcl
 428         (is-false success)
 429         ;; We need to test if `lock` is locked, but it must be done in
 430         ;; another thread, otherwise it would be a recursive attempt.
 431         (let ((res-lock (make-lock :name "Result lock"))
 432               (res-cv (make-condition-variable :name "Result condition variable"))
 433               (lock-was-acquired-p nil))
 434           (make-thread (lambda ()
 435                          (with-lock-held (res-lock)
 436                            (setf lock-was-acquired-p (acquire-lock lock :wait nil)))
 437                          (condition-notify res-cv)))
 438           (with-lock-held (res-lock)
 439             (condition-wait res-cv res-lock)
 440             (is-false lock-was-acquired-p)))))))
 441
 442 #+#.(bt2::implemented-p* 'bt2:condition-notify)
 443 (test condition-notify.no-waiting-threads
 444   "Test that `CONDITION-NOTIFY` returns NIL whether or not there are
 445 threads waiting."
 446   (let ((lock (make-lock :name "Test lock"))
 447         (cv (make-condition-variable :name "Test condition variable")))
 448     (is-false (condition-notify cv))
 449     (make-thread (lambda ()
 450                    (with-lock-held (lock)
 451                      (condition-wait cv lock))))
 452     (is-false (condition-notify cv))))
 453
 454 #+#.(bt2::implemented-p* 'bt2:condition-broadcast)
 455 (test condition-broadcast.return-value
 456   "Test that `CONDITION-BROADCAST` returns NIL whether or not there
 457 are threads waiting."
 458   (let ((lock (make-lock :name "Test lock"))
 459         (cv (make-condition-variable :name "Test condition variable")))
 460     (is-false (condition-notify cv))
 461     (make-thread (lambda ()
 462                    (with-lock-held (lock)
 463                      (condition-wait cv lock)))
 464                  :name "Waiting thread 1")
 465     (make-thread (lambda ()
 466                    (with-lock-held (lock)
 467                      (condition-wait cv lock)))
 468                  :name "Waiting thread 2")
 469     (is-false (condition-broadcast cv))))
 470 \f
 471
 472 ;;;
 473 ;;; Timeouts
 474 ;;;
 475
 476 (test with-timeout.return-value
 477   (is (eql :foo (with-timeout (5) :foo))))
 478
 479 (test with-timeout.signals
 480   (signals timeout (with-timeout (1) (sleep 5))))
 481
 482 (test with-timeout.non-interference
 483   (flet ((sleep-with-timeout (s)
 484            (with-timeout (4) (sleep s))))
 485     (finishes
 486       (progn
 487         (sleep-with-timeout 3)
 488         (sleep-with-timeout 3)))))
 489 \f
 490
 491 ;;;
 492 ;;; Atomics
 493 ;;;
 494
 495 #+(or abcl allegro ccl clisp cmu ecl lispworks sbcl)
 496 (test atomic-integer-incf-decf.return-value
 497   (let ((aint (make-atomic-integer :value 0)))
 498     (is (= 5 (atomic-integer-incf aint 5)))
 499     (is (= 4 (atomic-integer-decf aint 1)))))
 500
 501 #+(or abcl allegro ccl clisp cmu ecl lispworks sbcl)
 502 (test atomic-integer-compare-and-swap.return-value
 503   (let ((aint (make-atomic-integer :value 4)))
 504     (is (null (atomic-integer-compare-and-swap aint 0 100)))
 505     (is (eql t (atomic-integer-compare-and-swap aint 4 7)))))
 506
 507 #+(or abcl allegro ccl clisp cmu ecl lispworks sbcl)
 508 (test atomic-integer.concurrency
 509   (let* ((aint (make-atomic-integer :value 1000000))
 510          (thread-inc
 511            (make-thread (lambda ()
 512                           (dotimes (i 1000000)
 513                             (atomic-integer-incf aint)))))
 514          (thread-dec
 515            (make-thread (lambda ()
 516                           (dotimes (i 1000000)
 517                             (atomic-integer-decf aint))))))
 518     (join-thread thread-inc)
 519     (join-thread thread-dec)
 520     (is (= 1000000 (atomic-integer-value aint)))))