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 (progn
 318   (test semaphore.typed
 319     (is (typep (make-semaphore) 'semaphore))
 320     (is (semaphorep (make-semaphore)))
 321     (is (not (semaphorep (make-lock)))))
 322
 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   (test semaphore.wait-on-nonzero-creation
 330     "Tests that `WAIT-ON-SEMAPHORE` correctly returns T
 331 on a smaphore that was initialized to a non-zero value.
 332 In other words, it tests that `SIGNAL-SEMAPHORE` is not
 333 the only cause that can wake a waiter."
 334     (let ((sem (make-semaphore :count 1)))
 335       (is-true (wait-on-semaphore sem :timeout 0))))
 336
 337   (test semaphore.wait.timeout
 338     (let* ((sem (make-semaphore)))
 339       (is-false (wait-on-semaphore sem :timeout 0))
 340       (is-false (wait-on-semaphore sem :timeout 0.2))))
 341
 342   (test semaphore.signal-n-of-m
 343     (let* ((sem (make-semaphore :count 1))
 344            (lock (make-lock))
 345            (count 0)
 346            (waiter (lambda ()
 347                      (wait-on-semaphore sem)
 348                      (with-lock-held (lock) (incf count)))))
 349       (make-thread (lambda ()
 350                      (sleep 0.2)
 351                      (signal-semaphore sem :count 3)))
 352       (dotimes (v 5) (make-thread waiter))
 353       (sleep 0.3)
 354       (is (= 4 count))
 355       ;; release other waiters
 356       (is (eql t (signal-semaphore sem :count 2)))
 357       (sleep 0.1)
 358       (is (= 5 count)))))
 359 \f
 360
 361 ;;;
 362 ;;; Condition variables
 363 ;;;
 364
 365 #+#.(bt2::implemented-p* 'bt2:make-condition-variable)
 366 (test condition-variable.typed
 367   (is (typep (make-condition-variable) 'condition-variable))
 368   (is (condition-variable-p (make-condition-variable)))
 369   (is (not (condition-variable-p (make-lock)))))
 370
 371 #+#.(bt2::implemented-p* 'bt2:make-condition-variable)
 372 (test condition-variable.concurrency
 373   (setf *shared* 0)
 374   (let ((cv (make-condition-variable)))
 375     (flet ((worker (i)
 376              (with-lock-held (*lock*)
 377                (loop
 378                  until (= i *shared*)
 379                  do (condition-wait cv *lock*)
 380                     (sleep (random .1)))
 381                (incf *shared*))
 382              (condition-broadcast cv)))
 383       (let ((num-procs 30))
 384         (dotimes (i num-procs)
 385           (let ((i (- num-procs i 1)))
 386             (make-thread (lambda ()
 387                            (sleep (random 1))
 388                            (funcall #'worker i))
 389                          :name (format nil "Proc #~D" i))))
 390         (with-lock-held (*lock*)
 391           (loop
 392             until (= num-procs *shared*)
 393             do (condition-wait cv *lock*)))
 394         (is (equal num-procs *shared*))))))
 395
 396 #+#.(bt2::implemented-p* 'bt2:condition-wait :timeout)
 397 (test condition-wait.timeout
 398   (let ((lock (make-lock))
 399         (cv (make-condition-variable))
 400         (flag nil))
 401     (make-thread (lambda () (sleep 0.4) (setf flag t)))
 402     (with-lock-held (lock)
 403       (let ((success
 404               (condition-wait cv lock :timeout 0.2)))
 405         #+abcl
 406         (skip "ABCL's condition-wait always returns T")
 407         #-abcl
 408         (is-false success)
 409         (is (null flag))
 410         (sleep 0.4)
 411         (is (eq t flag))))))
 412
 413 #+#.(bt2::implemented-p* 'bt2:condition-wait :timeout)
 414 (test condition-wait.lock-held-on-timeout
 415   "Tests that even when `CONDITION-WAIT` times out, it reacquires the
 416 lock."
 417   (let ((lock (make-lock :name "Test lock"))
 418         (cv (make-condition-variable :name "Test condition variable")))
 419     (with-lock-held (lock)
 420       (let ((success
 421               (condition-wait cv lock :timeout 2)))
 422         #+abcl
 423         (skip "ABCL's condition-wait always returns T")
 424         #-abcl
 425         (is-false success)
 426         ;; We need to test if `lock` is locked, but it must be done in
 427         ;; another thread, otherwise it would be a recursive attempt.
 428         (let ((res-lock (make-lock :name "Result lock"))
 429               (res-cv (make-condition-variable :name "Result condition variable"))
 430               (lock-was-acquired-p nil))
 431           (make-thread (lambda ()
 432                          (with-lock-held (res-lock)
 433                            (setf lock-was-acquired-p (acquire-lock lock :wait nil)))
 434                          (condition-notify res-cv)))
 435           (with-lock-held (res-lock)
 436             (condition-wait res-cv res-lock)
 437             (is-false lock-was-acquired-p)))))))
 438
 439 #+#.(bt2::implemented-p* 'bt2:make-condition-variable)
 440 (test condition-notify.no-waiting-threads
 441   "Test that `CONDITION-NOTIFY` returns NIL whether or not there are
 442 threads waiting."
 443   (let ((lock (make-lock :name "Test lock"))
 444         (cv (make-condition-variable :name "Test condition variable")))
 445     (is-false (condition-notify cv))
 446     (make-thread (lambda ()
 447                    (with-lock-held (lock)
 448                      (condition-wait cv lock))))
 449     (is-false (condition-notify cv))))
 450
 451 #+#.(bt2::implemented-p* 'bt2:make-condition-variable)
 452 (test condition-broadcast.return-value
 453   "Test that `CONDITION-BROADCAST` returns NIL whether or not there
 454 are threads waiting."
 455   (let ((lock (make-lock :name "Test lock"))
 456         (cv (make-condition-variable :name "Test condition variable")))
 457     (is-false (condition-notify cv))
 458     (make-thread (lambda ()
 459                    (with-lock-held (lock)
 460                      (condition-wait cv lock)))
 461                  :name "Waiting thread 1")
 462     (make-thread (lambda ()
 463                    (with-lock-held (lock)
 464                      (condition-wait cv lock)))
 465                  :name "Waiting thread 2")
 466     (is-false (condition-broadcast cv))))
 467 \f
 468
 469 ;;;
 470 ;;; Timeouts
 471 ;;;
 472
 473 (test with-timeout.return-value
 474   (is (eql :foo (with-timeout (5) :foo))))
 475
 476 (test with-timeout.signals
 477   (signals timeout (with-timeout (1) (sleep 5))))
 478
 479 (test with-timeout.non-interference
 480   (flet ((sleep-with-timeout (s)
 481            (with-timeout (4) (sleep s))))
 482     (finishes
 483       (progn
 484         (sleep-with-timeout 3)
 485         (sleep-with-timeout 3)))))
 486 \f
 487
 488 ;;;
 489 ;;; Atomics
 490 ;;;
 491
 492 #+(or abcl allegro ccl clisp ecl lispworks sbcl)
 493 (test atomic-integer-incf-decf.return-value
 494   (let ((aint (make-atomic-integer :value 0)))
 495     (is (= 5 (atomic-integer-incf aint 5)))
 496     (is (= 4 (atomic-integer-decf aint 1)))))
 497
 498 #+(or abcl allegro ccl clisp ecl lispworks sbcl)
 499 (test atomic-integer-cas.return-value
 500   (let ((aint (make-atomic-integer :value 4)))
 501     (is (null (atomic-integer-cas aint 0 100)))
 502     (is (eql t (atomic-integer-cas aint 4 7)))))
 503
 504 #+(or abcl allegro ccl clisp ecl lispworks sbcl)
 505 (test atomic-integer.concurrency
 506   (let* ((aint (make-atomic-integer :value 1000000))
 507          (thread-inc
 508            (make-thread (lambda ()
 509                           (dotimes (i 1000000)
 510                             (atomic-integer-incf aint)))))
 511          (thread-dec
 512            (make-thread (lambda ()
 513                           (dotimes (i 1000000)
 514                             (atomic-integer-decf aint))))))
 515     (join-thread thread-inc)
 516     (join-thread thread-dec)
 517     (is (= 1000000 (atomic-integer-value aint)))))