tests/threads.pure.lisp

   1 ;;;; miscellaneous tests of thread stuff
   2
   3 ;;;; This software is part of the SBCL system. See the README file for
   4 ;;;; more information.
   5 ;;;;
   6 ;;;; While most of SBCL is derived from the CMU CL system, the test
   7 ;;;; files (like this one) were written from scratch after the fork
   8 ;;;; from CMU CL.
   9 ;;;
  10 ;;;; This software is in the public domain and is provided with
  11 ;;;; absoluely no warranty. See the COPYING and CREDITS files for
  12 ;;;; more information.
  13
  14 (in-package :cl-user)
  15
  16 (defpackage :thread-test
  17   (:use :cl :sb-thread))
  18
  19 (in-package :thread-test)
  20
  21 (use-package :test-util)
  22
  23 (with-test (:name mutex-owner)
  24   ;; Make sure basics are sane on unithreaded ports as well
  25   (let ((mutex (make-mutex)))
  26     (get-mutex mutex)
  27     (assert (eq *current-thread* (mutex-value mutex)))
  28     (handler-bind ((warning #'error))
  29       (release-mutex mutex))
  30     (assert (not (mutex-value mutex)))))
  31
  32 (with-test (:name spinlock-owner)
  33   ;; Make sure basics are sane on unithreaded ports as well
  34   (let ((spinlock (sb-thread::make-spinlock)))
  35     (sb-thread::get-spinlock spinlock)
  36     (assert (eq *current-thread* (sb-thread::spinlock-value spinlock)))
  37     (handler-bind ((warning #'error))
  38       (sb-thread::release-spinlock spinlock))
  39     (assert (not (sb-thread::spinlock-value spinlock)))))
  40
  41 ;;; Terminating a thread that's waiting for the terminal.
  42
  43 #+sb-thread
  44 (let ((thread (make-thread (lambda ()
  45                              (sb-thread::get-foreground)))))
  46   (sleep 1)
  47   (assert (thread-alive-p thread))
  48   (terminate-thread thread)
  49   (sleep 1)
  50   (assert (not (thread-alive-p thread))))
  51
  52 ;;; Condition-wait should not be interruptible under WITHOUT-INTERRUPTS
  53
  54 (with-test (:name without-interrupts+condition-wait
  55             :skipped-on '(not :sb-thread))
  56   (let* ((lock (make-mutex))
  57          (queue (make-waitqueue))
  58          (thread (make-thread (lambda ()
  59                                 (sb-sys:without-interrupts
  60                                   (with-mutex (lock)
  61                                     (condition-wait queue lock)))))))
  62     (sleep 1)
  63     (assert (thread-alive-p thread))
  64     (terminate-thread thread)
  65     (sleep 1)
  66     (assert (thread-alive-p thread))
  67     (condition-notify queue)
  68     (sleep 1)
  69     (assert (not (thread-alive-p thread)))))
  70
  71 ;;; GET-MUTEX should not be interruptible under WITHOUT-INTERRUPTS
  72
  73 (with-test (:name without-interrupts+get-mutex :skipped-on '(not :sb-thread))
  74   (let* ((lock (make-mutex))
  75          (bar (progn (get-mutex lock) nil))
  76          (thread (make-thread (lambda ()
  77                                 (sb-sys:without-interrupts
  78                                     (with-mutex (lock)
  79                                       (setf bar t)))))))
  80     (sleep 1)
  81     (assert (thread-alive-p thread))
  82     (terminate-thread thread)
  83     (sleep 1)
  84     (assert (thread-alive-p thread))
  85     (release-mutex lock)
  86     (sleep 1)
  87     (assert (not (thread-alive-p thread)))
  88     (assert (eq :aborted (join-thread thread :default :aborted)))
  89     (assert bar)))
  90
  91 (with-test (:name parallel-find-class :skipped-on '(not :sb-thread))
  92   (let* ((oops nil)
  93          (threads (loop repeat 10
  94                         collect (make-thread (lambda ()
  95                                                (handler-case
  96                                                    (loop repeat 10000
  97                                                          do (find-class (gensym) nil))
  98                                                  (serious-condition ()
  99                                                    (setf oops t))))))))
 100     (mapcar #'sb-thread:join-thread threads)
 101     (assert (not oops))))
 102
 103 (with-test (:name :semaphore-multiple-waiters :skipped-on '(not :sb-thread))
 104   (let ((semaphore (make-semaphore :name "test sem")))
 105     (labels ((make-readers (n i)
 106                (values
 107                 (loop for r from 0 below n
 108                       collect
 109                       (sb-thread:make-thread
 110                        (lambda ()
 111                          (let ((sem semaphore))
 112                            (dotimes (s i)
 113                              (sb-thread:wait-on-semaphore sem))))
 114                        :name "reader"))
 115                 (* n i)))
 116              (make-writers (n readers i)
 117                (let ((j (* readers i)))
 118                  (multiple-value-bind (k rem) (truncate j n)
 119                    (values
 120                     (let ((writers
 121                            (loop for w from 0 below n
 122                                  collect
 123                                  (sb-thread:make-thread
 124                                   (lambda ()
 125                                     (let ((sem semaphore))
 126                                       (dotimes (s k)
 127                                         (sb-thread:signal-semaphore sem))))
 128                                   :name "writer"))))
 129                       (assert (zerop rem))
 130                       writers)
 131                     (+ rem (* n k))))))
 132              (test (r w n)
 133                (multiple-value-bind (readers x) (make-readers r n)
 134                  (assert (= (length readers) r))
 135                  (multiple-value-bind (writers y) (make-writers w r n)
 136                    (assert (= (length writers) w))
 137                    (assert (= x y))
 138                    (mapc #'sb-thread:join-thread writers)
 139                    (mapc #'sb-thread:join-thread readers)
 140                    (assert (zerop (sb-thread:semaphore-count semaphore)))
 141                    (values)))))
 142       (assert
 143        (eq :ok
 144            (handler-case
 145                (sb-ext:with-timeout 10
 146                  (test 1 1 100)
 147                  (test 2 2 10000)
 148                  (test 4 2 10000)
 149                  (test 4 2 10000)
 150                  (test 10 10 10000)
 151                  (test 10 1 10000)
 152                  :ok)
 153              (sb-ext:timeout ()
 154                :timeout)))))))
 155
 156 ;;;; Printing waitqueues
 157
 158 (with-test (:name :waitqueue-circle-print :skipped-on '(not :sb-thread))
 159   (let* ((*print-circle* nil)
 160          (lock (sb-thread:make-mutex))
 161          (wq (sb-thread:make-waitqueue)))
 162     (sb-thread:with-recursive-lock (lock)
 163       (sb-thread:condition-notify wq))
 164     ;; Used to blow stack due to recursive structure.
 165     (assert (princ-to-string wq))))
 166
 167 ;;;; SYMBOL-VALUE-IN-THREAD
 168
 169 (with-test (:name symbol-value-in-thread.1)
 170   (let ((* (cons t t)))
 171     (assert (eq * (symbol-value-in-thread '* *current-thread*)))
 172     (setf (symbol-value-in-thread '* *current-thread*) 123)
 173     (assert (= 123 (symbol-value-in-thread '* *current-thread*)))
 174     (assert (= 123 *))))
 175
 176 (with-test (:name symbol-value-in-thread.2 :skipped-on '(not :sb-thread))
 177   (let* ((parent *current-thread*)
 178          (semaphore (make-semaphore))
 179          (child (make-thread (lambda ()
 180                                (wait-on-semaphore semaphore)
 181                                (let ((old (symbol-value-in-thread 'this-is-new parent)))
 182                                  (setf (symbol-value-in-thread 'this-is-new parent) :from-child)
 183                                  old)))))
 184     (progv '(this-is-new) '(42)
 185       (signal-semaphore semaphore)
 186       (assert (= 42 (join-thread child)))
 187       (assert (eq :from-child (symbol-value 'this-is-new))))))
 188
 189 ;;; Disabled on Darwin due to deadlocks caused by apparent OS specific deadlocks,
 190 ;;; wich _appear_ to be caused by malloc() and free() not being thread safe: an
 191 ;;; interrupted malloc in one thread can apparently block a free in another. There
 192 ;;; are also some indications that pthread_mutex_lock is not re-entrant.
 193 (with-test (:name symbol-value-in-thread.3
 194             :skipped-on '(not :sb-thread)
 195             :broken-on :darwin)
 196   (let* ((parent *current-thread*)
 197          (semaphore (make-semaphore))
 198          (running t)
 199          (noise (make-thread (lambda ()
 200                                (loop while running
 201                                      do (setf * (make-array 1024))
 202                                      ;; Busy-wait a bit so we don't TOTALLY flood the
 203                                      ;; system with GCs: a GC occurring in the middle of
 204                                      ;; S-V-I-T causes it to start over -- we want that
 205                                      ;; to occur occasionally, but not _all_ the time.
 206                                         (loop repeat (random 128)
 207                                               do (setf ** *)))))))
 208     (write-string "; ")
 209     (dotimes (i 15000)
 210       (when (zerop (mod i 200))
 211         (write-char #\.)
 212         (force-output))
 213       (let* ((mom-mark (cons t t))
 214              (kid-mark (cons t t))
 215              (child (make-thread (lambda ()
 216                                    (wait-on-semaphore semaphore)
 217                                    (let ((old (symbol-value-in-thread 'this-is-new parent)))
 218                                      (setf (symbol-value-in-thread 'this-is-new parent)
 219                                            (make-array 24 :initial-element kid-mark))
 220                                      old)))))
 221         (progv '(this-is-new) (list (make-array 24 :initial-element mom-mark))
 222           (signal-semaphore semaphore)
 223           (assert (eq mom-mark (aref (join-thread child) 0)))
 224           (assert (eq kid-mark (aref (symbol-value 'this-is-new) 0))))))
 225     (setf running nil)
 226     (join-thread noise)))
 227
 228 (with-test (:name symbol-value-in-thread.4 :skipped-on '(not :sb-thread))
 229   (let* ((parent *current-thread*)
 230          (semaphore (make-semaphore))
 231          (child (make-thread (lambda ()
 232                                (wait-on-semaphore semaphore)
 233                                (symbol-value-in-thread 'this-is-new parent nil)))))
 234     (signal-semaphore semaphore)
 235     (assert (equal '(nil nil) (multiple-value-list (join-thread child))))))
 236
 237 (with-test (:name symbol-value-in-thread.5 :skipped-on '(not :sb-thread))
 238   (let* ((parent *current-thread*)
 239          (semaphore (make-semaphore))
 240          (child (make-thread (lambda ()
 241                                (wait-on-semaphore semaphore)
 242                                (handler-case
 243                                    (symbol-value-in-thread 'this-is-new parent)
 244                                  (symbol-value-in-thread-error (e)
 245                                    (list (thread-error-thread e)
 246                                          (cell-error-name e)
 247                                          (sb-thread::symbol-value-in-thread-error-info e))))))))
 248     (signal-semaphore semaphore)
 249     (assert (equal (list *current-thread* 'this-is-new (list :read :unbound-in-thread))
 250                    (join-thread child)))))
 251
 252 (with-test (:name symbol-value-in-thread.6 :skipped-on '(not :sb-thread))
 253   (let* ((parent *current-thread*)
 254          (semaphore (make-semaphore))
 255          (name (gensym))
 256          (child (make-thread (lambda ()
 257                                (wait-on-semaphore semaphore)
 258                                (handler-case
 259                                    (setf (symbol-value-in-thread name parent) t)
 260                                  (symbol-value-in-thread-error (e)
 261                                    (list (thread-error-thread e)
 262                                          (cell-error-name e)
 263                                          (sb-thread::symbol-value-in-thread-error-info e))))))))
 264     (signal-semaphore semaphore)
 265     (let ((res (join-thread child))
 266           (want (list *current-thread* name (list :write :no-tls-value))))
 267       (unless (equal res want)
 268         (error "wanted ~S, got ~S" want res)))))
 269
 270 (with-test (:name symbol-value-in-thread.7 :skipped-on '(not :sb-thread))
 271   (let ((child (make-thread (lambda ())))
 272         (error-occurred nil))
 273     (join-thread child)
 274     (handler-case
 275         (symbol-value-in-thread 'this-is-new child)
 276       (symbol-value-in-thread-error (e)
 277         (setf error-occurred t)
 278         (assert (eq child (thread-error-thread e)))
 279         (assert (eq 'this-is-new (cell-error-name e)))
 280         (assert (equal (list :read :thread-dead)
 281                        (sb-thread::symbol-value-in-thread-error-info e)))))
 282     (assert error-occurred)))
 283
 284 (with-test (:name symbol-value-in-thread.8  :skipped-on '(not :sb-thread))
 285   (let ((child (make-thread (lambda ())))
 286         (error-occurred nil))
 287     (join-thread child)
 288     (handler-case
 289         (setf (symbol-value-in-thread 'this-is-new child) t)
 290       (symbol-value-in-thread-error (e)
 291         (setf error-occurred t)
 292         (assert (eq child (thread-error-thread e)))
 293         (assert (eq 'this-is-new (cell-error-name e)))
 294         (assert (equal (list :write :thread-dead)
 295                        (sb-thread::symbol-value-in-thread-error-info e)))))
 296     (assert error-occurred)))
 297
 298 (with-test (:name deadlock-detection.1  :skipped-on '(not :sb-thread))
 299   (loop
 300     repeat 1000
 301     do (flet ((test (ma mb sa sb)
 302                 (lambda ()
 303                   (handler-case
 304                       (sb-thread:with-mutex (ma)
 305                         (sb-thread:signal-semaphore sa)
 306                         (sb-thread:wait-on-semaphore sb)
 307                         (sb-thread:with-mutex (mb)
 308                           :ok))
 309                     (sb-thread:thread-deadlock (e)
 310                       (princ e)
 311                       :deadlock)))))
 312          (let* ((m1 (sb-thread:make-mutex :name "M1"))
 313                 (m2 (sb-thread:make-mutex :name "M2"))
 314                 (s1 (sb-thread:make-semaphore :name "S1"))
 315                 (s2 (sb-thread:make-semaphore :name "S2"))
 316                 (t1 (sb-thread:make-thread (test m1 m2 s1 s2) :name "T1"))
 317                 (t2 (sb-thread:make-thread (test m2 m1 s2 s1) :name "T2")))
 318            ;; One will deadlock, and the other will then complete normally.
 319            ;; ...except sometimes, when we get unlucky, and both will do
 320            ;; the deadlock detection in parallel and both signal.
 321            (let ((res (list (sb-thread:join-thread t1)
 322                             (sb-thread:join-thread t2))))
 323              (assert (or (equal '(:deadlock :ok) res)
 324                          (equal '(:ok :deadlock) res)
 325                          (equal '(:deadlock :deadlock) res))))))))
 326
 327 (with-test (:name deadlock-detection.2 :skipped-on '(not :sb-thread))
 328   (let* ((m1 (sb-thread:make-mutex :name "M1"))
 329          (m2 (sb-thread:make-mutex :name "M2"))
 330          (s1 (sb-thread:make-semaphore :name "S1"))
 331          (s2 (sb-thread:make-semaphore :name "S2"))
 332          (t1 (sb-thread:make-thread
 333               (lambda ()
 334                 (sb-thread:with-mutex (m1)
 335                   (sb-thread:signal-semaphore s1)
 336                   (sb-thread:wait-on-semaphore s2)
 337                   (sb-thread:with-mutex (m2)
 338                     :ok)))
 339               :name "T1")))
 340     (prog (err)
 341      :retry
 342        (handler-bind ((sb-thread:thread-deadlock
 343                        (lambda (e)
 344                          (unless err
 345                            ;; Make sure we can print the condition
 346                            ;; while it's active
 347                            (let ((*print-circle* nil))
 348                              (setf err (princ-to-string e)))
 349                            (go :retry)))))
 350          (when err
 351            (sleep 1))
 352          (assert (eq :ok (sb-thread:with-mutex (m2)
 353                            (unless err
 354                              (sb-thread:signal-semaphore s2)
 355                              (sb-thread:wait-on-semaphore s1)
 356                              (sleep 1))
 357                            (sb-thread:with-mutex (m1)
 358                              :ok)))))
 359        (assert (stringp err)))
 360     (assert (eq :ok (sb-thread:join-thread t1)))))
 361
 362 (with-test (:name deadlock-detection.3  :skipped-on '(not :sb-thread))
 363   (let* ((m1 (sb-thread:make-mutex :name "M1"))
 364          (m2 (sb-thread:make-mutex :name "M2"))
 365          (s1 (sb-thread:make-semaphore :name "S1"))
 366          (s2 (sb-thread:make-semaphore :name "S2"))
 367          (t1 (sb-thread:make-thread
 368               (lambda ()
 369                 (sb-thread:with-mutex (m1)
 370                   (sb-thread:signal-semaphore s1)
 371                   (sb-thread:wait-on-semaphore s2)
 372                   (sb-thread:with-mutex (m2)
 373                     :ok)))
 374               :name "T1")))
 375     ;; Currently we don't consider it a deadlock
 376     ;; if there is a timeout in the chain.
 377     (assert (eq :deadline
 378                 (handler-case
 379                     (sb-thread:with-mutex (m2)
 380                       (sb-thread:signal-semaphore s2)
 381                       (sb-thread:wait-on-semaphore s1)
 382                       (sleep 1)
 383                       (sb-sys:with-deadline (:seconds 0.1)
 384                         (sb-thread:with-mutex (m1)
 385                           :ok)))
 386                   (sb-sys:deadline-timeout ()
 387                     :deadline)
 388                   (sb-thread:thread-deadlock ()
 389                     :deadlock))))
 390     (assert (eq :ok (join-thread t1)))))
 391
 392 (with-test (:name deadlock-detection.4  :skipped-on '(not :sb-thread))
 393   (loop
 394     repeat 1000
 395     do (flet ((test (ma mb sa sb)
 396                 (lambda ()
 397                   (handler-case
 398                       (sb-thread::with-spinlock (ma)
 399                         (sb-thread:signal-semaphore sa)
 400                         (sb-thread:wait-on-semaphore sb)
 401                         (sb-thread::with-spinlock (mb)
 402                           :ok))
 403                     (sb-thread:thread-deadlock (e)
 404                       (princ e)
 405                       :deadlock)))))
 406          (let* ((m1 (sb-thread::make-spinlock :name "M1"))
 407                 (m2 (sb-thread::make-spinlock :name "M2"))
 408                 (s1 (sb-thread:make-semaphore :name "S1"))
 409                 (s2 (sb-thread:make-semaphore :name "S2"))
 410                 (t1 (sb-thread:make-thread (test m1 m2 s1 s2) :name "T1"))
 411                 (t2 (sb-thread:make-thread (test m2 m1 s2 s1) :name "T2")))
 412            ;; One will deadlock, and the other will then complete normally
 413            ;; ...except sometimes, when we get unlucky, and both will do
 414            ;; the deadlock detection in parallel and both signal.
 415            (let ((res (list (sb-thread:join-thread t1)
 416                             (sb-thread:join-thread t2))))
 417              (assert (or (equal '(:deadlock :ok) res)
 418                          (equal '(:ok :deadlock) res)
 419                          (equal '(:deadlock :deadlock) res))))))))
 420
 421 (with-test (:name deadlock-detection.5 :skipped-on '(not :sb-thread))
 422   (let* ((m1 (sb-thread::make-spinlock :name "M1"))
 423          (m2 (sb-thread::make-spinlock :name "M2"))
 424          (s1 (sb-thread:make-semaphore :name "S1"))
 425          (s2 (sb-thread:make-semaphore :name "S2"))
 426          (t1 (sb-thread:make-thread
 427               (lambda ()
 428                 (sb-thread::with-spinlock (m1)
 429                   (sb-thread:signal-semaphore s1)
 430                   (sb-thread:wait-on-semaphore s2)
 431                   (sb-thread::with-spinlock (m2)
 432                     :ok)))
 433               :name "T1")))
 434     (prog (err)
 435      :retry
 436        (handler-bind ((sb-thread:thread-deadlock
 437                        (lambda (e)
 438                          (unless err
 439                            ;; Make sure we can print the condition
 440                            ;; while it's active
 441                            (let ((*print-circle* nil))
 442                              (setf err (princ-to-string e)))
 443                            (go :retry)))))
 444          (when err
 445            (sleep 1))
 446          (assert (eq :ok (sb-thread::with-spinlock (m2)
 447                            (unless err
 448                              (sb-thread:signal-semaphore s2)
 449                              (sb-thread:wait-on-semaphore s1)
 450                              (sleep 1))
 451                            (sb-thread::with-spinlock (m1)
 452                              :ok)))))
 453        (assert (stringp err)))
 454     (assert (eq :ok (sb-thread:join-thread t1)))))
 455
 456 (with-test (:name deadlock-detection.7 :skipped-on '(not :sb-thread))
 457   (let* ((m1 (sb-thread::make-spinlock :name "M1"))
 458          (m2 (sb-thread::make-spinlock :name "M2"))
 459          (s1 (sb-thread:make-semaphore :name "S1"))
 460          (s2 (sb-thread:make-semaphore :name "S2"))
 461          (t1 (sb-thread:make-thread
 462               (lambda ()
 463                 (sb-thread::with-spinlock (m1)
 464                   (sb-thread:signal-semaphore s1)
 465                   (sb-thread:wait-on-semaphore s2)
 466                   (sb-thread::with-spinlock (m2)
 467                     :ok)))
 468               :name "T1")))
 469     (assert (eq :deadlock
 470                 (handler-case
 471                     (sb-thread::with-spinlock (m2)
 472                       (sb-thread:signal-semaphore s2)
 473                       (sb-thread:wait-on-semaphore s1)
 474                       (sleep 1)
 475                       (sb-sys:with-deadline (:seconds 0.1)
 476                         (sb-thread::with-spinlock (m1)
 477                           :ok)))
 478                   (sb-sys:deadline-timeout ()
 479                     :deadline)
 480                   (sb-thread:thread-deadlock ()
 481                     :deadlock))))
 482     (assert (eq :ok (join-thread t1)))))
 483
 484 #+sb-thread
 485 (with-test (:name :pass-arguments-to-thread)
 486   (assert (= 3 (join-thread (make-thread #'+ :arguments '(1 2))))))
 487
 488 #+sb-thread
 489 (with-test (:name :pass-atom-to-thread)
 490   (assert (= 1/2 (join-thread (make-thread #'/ :arguments 2)))))
 491
 492 #+sb-thread
 493 (with-test (:name :pass-nil-to-thread)
 494   (assert (= 1 (join-thread (make-thread #'* :arguments '())))))
 495
 496 #+sb-thread
 497 (with-test (:name :pass-nothing-to-thread)
 498   (assert (= 1 (join-thread (make-thread #'*)))))
 499
 500 #+sb-thread
 501 (with-test (:name :pass-improper-list-to-thread)
 502   (multiple-value-bind (value error)
 503       (ignore-errors (make-thread #'+ :arguments '(1 . 1)))
 504     (when value
 505       (join-thread value))
 506     (assert (and (null value)
 507                  error))))
 508
 509 (with-test (:name (:wait-for :basics))
 510   (assert (not (sb-ext:wait-for nil :timeout 0.1)))
 511   (assert (eql 42 (sb-ext:wait-for 42)))
 512   (let ((n 0))
 513     (assert (eql 100 (sb-ext:wait-for (when (= 100 (incf n))
 514                                         n))))))
 515
 516 (with-test (:name (:wait-for :deadline))
 517   (assert (eq :ok
 518               (sb-sys:with-deadline (:seconds 10)
 519                 (assert (not (sb-ext:wait-for nil :timeout 0.1)))
 520                 :ok)))
 521   (assert (eq :deadline
 522               (handler-case
 523                   (sb-sys:with-deadline (:seconds 0.1)
 524                     (sb-ext:wait-for nil :timeout 10)
 525                     (error "oops"))
 526                 (sb-sys:deadline-timeout () :deadline)))))
 527
 528 (with-test (:name (:condition-wait :timeout :one-thread))
 529   (let ((mutex (make-mutex))
 530         (waitqueue (make-waitqueue)))
 531     (assert (not (with-mutex (mutex)
 532                    (condition-wait waitqueue mutex :timeout 0.01))))))
 533
 534 (with-test (:name (:condition-wait :timeout :many-threads)
 535             :skipped-on '(not :sb-thread))
 536   (let* ((mutex (make-mutex))
 537          (waitqueue (make-waitqueue))
 538          (sem (make-semaphore))
 539          (data nil)
 540          (workers
 541            (loop repeat 100
 542                  collect (make-thread
 543                           (lambda ()
 544                             (wait-on-semaphore sem)
 545                             (block thread
 546                               (with-mutex (mutex)
 547                                 (loop until data
 548                                       do (or (condition-wait waitqueue mutex :timeout 0.01)
 549                                              (return-from thread nil)))
 550                                 (assert (eq t (pop data)))
 551                                 t)))))))
 552     (loop repeat 50
 553           do (with-mutex (mutex)
 554                (push t data)
 555                (condition-notify waitqueue)))
 556     (signal-semaphore sem 100)
 557     (let ((ok (count-if #'join-thread workers)))
 558       (unless (eql 50 ok)
 559         (error "Wanted 50, got ~S" ok)))))
 560
 561 (with-test (:name (:wait-on-semaphore :timeout :one-thread))
 562   (let ((sem (make-semaphore))
 563         (n 0))
 564     (signal-semaphore sem 10)
 565     (loop repeat 100
 566           do (when (wait-on-semaphore sem :timeout 0.001)
 567                (incf n)))
 568     (assert (= n 10))))
 569
 570 (with-test (:name (:wait-on-semaphore :timeout :many-threads)
 571             :skipped-on '(not :sb-thread))
 572   (let* ((sem (make-semaphore))
 573          (threads
 574            (progn
 575              (signal-semaphore sem 10)
 576              (loop repeat 100
 577                    collect (make-thread
 578                             (lambda ()
 579                               (sleep (random 0.02))
 580                               (wait-on-semaphore sem :timeout 0.01)))))))
 581     (loop repeat 5
 582           do (signal-semaphore sem 2))
 583     (let ((ok (count-if #'join-thread threads)))
 584       (unless (eql 20 ok)
 585         (error "Wanted 20, got ~S" ok)))))
 586
 587 (with-test (:name (:join-thread :timeout)
 588             :skipped-on '(not :sb-thread))
 589   (assert (eq :error
 590               (handler-case
 591                   (join-thread (make-thread (lambda () (sleep 10))) :timeout 0.01)
 592                 (join-thread-error ()
 593                   :error))))
 594   (let ((cookie (cons t t)))
 595     (assert (eq cookie
 596                 (join-thread (make-thread (lambda () (sleep 10)))
 597                              :timeout 0.01
 598                              :default cookie)))))