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 (cl:defpackage #:thread-test
  15   (:use #:cl #:sb-thread #:sb-ext #:test-util #:assertoid))
  16
  17 (cl:in-package #:thread-test)
  18
  19 (with-test (:name atomic-update
  20             :skipped-on '(not :sb-thread))
  21   (let ((x (cons :count 0))
  22         (nthreads (ecase sb-vm:n-word-bits (32 100) (64 1000))))
  23     (mapc #'join-thread
  24           (loop repeat nthreads
  25              collect (make-thread (lambda ()
  26                                     (loop repeat 1000
  27                                        do (atomic-update (cdr x) #'1+)
  28                                          (sleep 0.00001))))))
  29     (assert (equal x `(:count ,@(* 1000 nthreads))))))
  30
  31 (with-test (:name mutex-owner)
  32   ;; Make sure basics are sane on unithreaded ports as well
  33   (let ((mutex (make-mutex)))
  34     (grab-mutex mutex)
  35     (assert (eq *current-thread* (mutex-value mutex)))
  36     (handler-bind ((warning #'error))
  37       (release-mutex mutex))
  38     (assert (not (mutex-value mutex)))))
  39
  40 ;;; Terminating a thread that's waiting for the terminal.
  41
  42 #+sb-thread
  43 (let ((thread (make-thread (lambda ()
  44                              (sb-thread::get-foreground)))))
  45   (sleep 1)
  46   (assert (thread-alive-p thread))
  47   (terminate-thread thread)
  48   (sleep 1)
  49   (assert (not (thread-alive-p thread))))
  50
  51 ;;; Condition-wait should not be interruptible under WITHOUT-INTERRUPTS
  52
  53 (with-test (:name :without-interrupts+condition-wait
  54             :skipped-on '(not :sb-thread)
  55             :fails-on '(and :win32 :sb-futex))
  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 ;;; GRAB-MUTEX should not be interruptible under WITHOUT-INTERRUPTS
  72
  73 (with-test (:name :without-interrupts+grab-mutex :skipped-on '(not :sb-thread))
  74   (let* ((lock (make-mutex))
  75          (bar (progn (grab-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     (mapc #'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                       (make-thread
 110                        (lambda ()
 111                          (let ((sem semaphore))
 112                            (dotimes (s i)
 113                              (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                                  (make-thread
 124                                   (lambda ()
 125                                     (let ((sem semaphore))
 126                                       (dotimes (s k)
 127                                         (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 #'join-thread writers)
 139                    (mapc #'join-thread readers)
 140                    (assert (zerop (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 (make-mutex))
 161          (wq (make-waitqueue)))
 162     (with-recursive-lock (lock)
 163       (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.
 192 (with-test (:name :symbol-value-in-thread.3
 193             :skipped-on '(not :sb-thread))
 194   (let* ((parent *current-thread*)
 195          (semaphore (make-semaphore))
 196          (running t)
 197          (noise (make-thread (lambda ()
 198                                (loop while running
 199                                      do (setf * (make-array 1024))
 200                                      ;; Busy-wait a bit so we don't TOTALLY flood the
 201                                      ;; system with GCs: a GC occurring in the middle of
 202                                      ;; S-V-I-T causes it to start over -- we want that
 203                                      ;; to occur occasionally, but not _all_ the time.
 204                                         (loop repeat (random 128)
 205                                               do (setf ** *)))))))
 206     (write-string "; ")
 207     (dotimes (i #+(or win32 openbsd) 2000
 208                 #-(or win32 openbsd) 15000)
 209       (when (zerop (mod i 200))
 210         (write-char #\.)
 211         (force-output))
 212       (let* ((mom-mark (cons t t))
 213              (kid-mark (cons t t))
 214              (child (make-thread (lambda ()
 215                                    (wait-on-semaphore semaphore)
 216                                    (let ((old (symbol-value-in-thread 'this-is-new parent)))
 217                                      (setf (symbol-value-in-thread 'this-is-new parent)
 218                                            (make-array 24 :initial-element kid-mark))
 219                                      old)))))
 220         (progv '(this-is-new) (list (make-array 24 :initial-element mom-mark))
 221           (signal-semaphore semaphore)
 222           (assert (eq mom-mark (aref (join-thread child) 0)))
 223           (assert (eq kid-mark (aref (symbol-value 'this-is-new) 0))))))
 224     (setf running nil)
 225     (join-thread noise)))
 226
 227 (with-test (:name :symbol-value-in-thread.4 :skipped-on '(not :sb-thread))
 228   (let* ((parent *current-thread*)
 229          (semaphore (make-semaphore))
 230          (child (make-thread (lambda ()
 231                                (wait-on-semaphore semaphore)
 232                                (symbol-value-in-thread 'this-is-new parent nil)))))
 233     (signal-semaphore semaphore)
 234     (assert (equal '(nil nil) (multiple-value-list (join-thread child))))))
 235
 236 (with-test (:name :symbol-value-in-thread.5 :skipped-on '(not :sb-thread))
 237   (let* ((parent *current-thread*)
 238          (semaphore (make-semaphore))
 239          (child (make-thread (lambda ()
 240                                (wait-on-semaphore semaphore)
 241                                (handler-case
 242                                    (symbol-value-in-thread 'this-is-new parent)
 243                                  (symbol-value-in-thread-error (e)
 244                                    (list (thread-error-thread e)
 245                                          (cell-error-name e)
 246                                          (sb-thread::symbol-value-in-thread-error-info e))))))))
 247     (signal-semaphore semaphore)
 248     (assert (equal (list *current-thread* 'this-is-new (list :read :unbound-in-thread))
 249                    (join-thread child)))))
 250
 251 (with-test (:name :symbol-value-in-thread.6 :skipped-on '(not :sb-thread))
 252   (let* ((parent *current-thread*)
 253          (semaphore (make-semaphore))
 254          (name (gensym))
 255          (child (make-thread (lambda ()
 256                                (wait-on-semaphore semaphore)
 257                                (handler-case
 258                                    (setf (symbol-value-in-thread name parent) t)
 259                                  (symbol-value-in-thread-error (e)
 260                                    (list (thread-error-thread e)
 261                                          (cell-error-name e)
 262                                          (sb-thread::symbol-value-in-thread-error-info e))))))))
 263     (signal-semaphore semaphore)
 264     (let ((res (join-thread child))
 265           (want (list *current-thread* name (list :write :no-tls-value))))
 266       (unless (equal res want)
 267         (error "wanted ~S, got ~S" want res)))))
 268
 269 (with-test (:name :symbol-value-in-thread.7 :skipped-on '(not :sb-thread))
 270   (let ((child (make-thread (lambda ())))
 271         (error-occurred nil))
 272     (join-thread child)
 273     (handler-case
 274         (symbol-value-in-thread 'this-is-new child)
 275       (symbol-value-in-thread-error (e)
 276         (setf error-occurred t)
 277         (assert (eq child (thread-error-thread e)))
 278         (assert (eq 'this-is-new (cell-error-name e)))
 279         (assert (equal (list :read :thread-dead)
 280                        (sb-thread::symbol-value-in-thread-error-info e)))))
 281     (assert error-occurred)))
 282
 283 (with-test (:name :symbol-value-in-thread.8 :skipped-on '(not :sb-thread))
 284   (let ((child (make-thread (lambda ())))
 285         (error-occurred nil))
 286     (join-thread child)
 287     (handler-case
 288         (setf (symbol-value-in-thread 'this-is-new child) t)
 289       (symbol-value-in-thread-error (e)
 290         (setf error-occurred t)
 291         (assert (eq child (thread-error-thread e)))
 292         (assert (eq 'this-is-new (cell-error-name e)))
 293         (assert (equal (list :write :thread-dead)
 294                        (sb-thread::symbol-value-in-thread-error-info e)))))
 295     (assert error-occurred)))
 296
 297 (with-test (:name :deadlock-detection.1 :skipped-on '(not :sb-thread))
 298   (loop
 299     repeat 1000
 300     do (flet ((test (ma mb sa sb)
 301                 (lambda ()
 302                   (handler-case
 303                       (with-mutex (ma)
 304                         (signal-semaphore sa)
 305                         (wait-on-semaphore sb)
 306                         (with-mutex (mb)
 307                           :ok))
 308                     (thread-deadlock (e)
 309                       ;; (assert (plusp (length ...))) prevents
 310                       ;; flushing.
 311                       (assert (plusp (length (princ-to-string e))))
 312                       :deadlock)))))
 313          (let* ((m1 (make-mutex :name "M1"))
 314                 (m2 (make-mutex :name "M2"))
 315                 (s1 (make-semaphore :name "S1"))
 316                 (s2 (make-semaphore :name "S2"))
 317                 (t1 (make-thread (test m1 m2 s1 s2) :name "T1"))
 318                 (t2 (make-thread (test m2 m1 s2 s1) :name "T2")))
 319            ;; One will deadlock, and the other will then complete normally.
 320            (let ((res (list (join-thread t1)
 321                             (join-thread t2))))
 322              (assert (or (equal '(:deadlock :ok) res)
 323                          (equal '(:ok :deadlock) res))))))))
 324
 325 (with-test (:name :deadlock-detection.2 :skipped-on '(not :sb-thread))
 326   (let* ((m1 (make-mutex :name "M1"))
 327          (m2 (make-mutex :name "M2"))
 328          (s1 (make-semaphore :name "S1"))
 329          (s2 (make-semaphore :name "S2"))
 330          (t1 (make-thread
 331               (lambda ()
 332                 (with-mutex (m1)
 333                   (signal-semaphore s1)
 334                   (wait-on-semaphore s2)
 335                   (with-mutex (m2)
 336                     :ok)))
 337               :name "T1")))
 338     (prog (err)
 339      :retry
 340        (handler-bind ((thread-deadlock
 341                        (lambda (e)
 342                          (unless err
 343                            ;; Make sure we can print the condition
 344                            ;; while it's active
 345                            (let ((*print-circle* nil))
 346                              (setf err (princ-to-string e)))
 347                            (go :retry)))))
 348          (when err
 349            (sleep 1))
 350          (assert (eq :ok (with-mutex (m2)
 351                            (unless err
 352                              (signal-semaphore s2)
 353                              (wait-on-semaphore s1)
 354                              (sleep 1))
 355                            (with-mutex (m1)
 356                              :ok)))))
 357        (assert (stringp err)))
 358     (assert (eq :ok (join-thread t1)))))
 359
 360 (with-test (:name :deadlock-detection.3  :skipped-on '(not :sb-thread))
 361   (let* ((m1 (make-mutex :name "M1"))
 362          (m2 (make-mutex :name "M2"))
 363          (s1 (make-semaphore :name "S1"))
 364          (s2 (make-semaphore :name "S2"))
 365          (t1 (make-thread
 366               (lambda ()
 367                 (with-mutex (m1)
 368                   (signal-semaphore s1)
 369                   (wait-on-semaphore s2)
 370                   (with-mutex (m2)
 371                     :ok)))
 372               :name "T1")))
 373     ;; Currently we don't consider it a deadlock
 374     ;; if there is a timeout in the chain.
 375     (assert (eq :deadline
 376                 (handler-case
 377                     (with-mutex (m2)
 378                       (signal-semaphore s2)
 379                       (wait-on-semaphore s1)
 380                       (sleep 1)
 381                       (sb-sys:with-deadline (:seconds 0.1)
 382                         (with-mutex (m1)
 383                           :ok)))
 384                   (sb-sys:deadline-timeout ()
 385                     :deadline)
 386                   (thread-deadlock ()
 387                     :deadlock))))
 388     (assert (eq :ok (join-thread t1)))))
 389
 390 #+sb-thread
 391 (with-test (:name :pass-arguments-to-thread)
 392   (assert (= 3 (join-thread (make-thread #'+ :arguments '(1 2))))))
 393
 394 #+sb-thread
 395 (with-test (:name :pass-atom-to-thread)
 396   (assert (= 1/2 (join-thread (make-thread #'/ :arguments 2)))))
 397
 398 #+sb-thread
 399 (with-test (:name :pass-nil-to-thread)
 400   (assert (= 1 (join-thread (make-thread #'* :arguments '())))))
 401
 402 #+sb-thread
 403 (with-test (:name :pass-nothing-to-thread)
 404   (assert (= 1 (join-thread (make-thread #'*)))))
 405
 406 #+sb-thread
 407 (with-test (:name :pass-improper-list-to-thread)
 408   (multiple-value-bind (value error)
 409       (ignore-errors (make-thread #'+ :arguments '(1 . 1)))
 410     (when value
 411       (join-thread value))
 412     (assert (and (null value)
 413                  error))))
 414
 415 (with-test (:name (:wait-for :basics))
 416   (assert (not (sb-ext:wait-for nil :timeout 0.1)))
 417   (assert (eql 42 (sb-ext:wait-for 42)))
 418   (let ((n 0))
 419     (assert (eql 100 (sb-ext:wait-for (when (= 100 (incf n))
 420                                         n))))))
 421
 422 (with-test (:name (:wait-for :deadline))
 423   (assert (eq :ok
 424               (sb-sys:with-deadline (:seconds 10)
 425                 (assert (not (sb-ext:wait-for nil :timeout 0.1)))
 426                 :ok)))
 427   (assert (eq :deadline
 428               (handler-case
 429                   (sb-sys:with-deadline (:seconds 0.1)
 430                     (sb-ext:wait-for nil :timeout 10)
 431                     (error "oops"))
 432                 (sb-sys:deadline-timeout () :deadline)))))
 433
 434 (with-test (:name (:condition-wait :timeout :one-thread))
 435   (let ((mutex (make-mutex))
 436         (waitqueue (make-waitqueue)))
 437     (assert (not (with-mutex (mutex)
 438                    (condition-wait waitqueue mutex :timeout 0.01))))))
 439
 440 (with-test (:name (:condition-wait :timeout :many-threads)
 441             :skipped-on '(not :sb-thread))
 442   (let* ((mutex (make-mutex))
 443          (waitqueue (make-waitqueue))
 444          (sem (make-semaphore))
 445          (data nil)
 446          (workers
 447            (loop repeat 100
 448                  collect (make-thread
 449                           (lambda ()
 450                             (wait-on-semaphore sem)
 451                             (block thread
 452                               (with-mutex (mutex)
 453                                 (loop until data
 454                                       do (or (condition-wait waitqueue mutex :timeout 0.01)
 455                                              (return-from thread nil)))
 456                                 (assert (eq t (pop data)))
 457                                 t)))))))
 458     (loop repeat 50
 459           do (with-mutex (mutex)
 460                (push t data)
 461                (condition-notify waitqueue)))
 462     (signal-semaphore sem 100)
 463     (let ((ok (count-if #'join-thread workers)))
 464       (unless (eql 50 ok)
 465         (error "Wanted 50, got ~S" ok)))))
 466
 467 (with-test (:name (wait-on-semaphore :timeout :one-thread))
 468   (let ((count 10)
 469         (semaphore (make-semaphore)))
 470     (signal-semaphore semaphore count)
 471     (let ((values (loop repeat 100
 472                      collect (wait-on-semaphore semaphore :timeout 0.001)))
 473           (expected (loop for i from 9 downto 0 collect i)))
 474       (assert (equal (remove nil values) expected)))))
 475
 476 (with-test (:name (wait-on-semaphore :timeout :many-threads)
 477             :skipped-on '(not :sb-thread))
 478   (let* ((count 10)
 479          (semaphore (make-semaphore)))
 480     ;; Add 10 tokens right away.
 481     (signal-semaphore semaphore count)
 482     ;; 100 threads try to decrement the semaphore by 1.
 483     (let ((threads
 484            (loop repeat 100
 485               collect (make-thread
 486                        (lambda ()
 487                          (sleep (random 0.02))
 488                          (wait-on-semaphore semaphore :timeout 0.5))))))
 489       ;; Add 10 more tokens while threads may already be waiting and
 490       ;; decrementing.
 491       (loop repeat (floor count 2) do (signal-semaphore semaphore 2))
 492       ;; 20 threads should have been able to decrement the semaphore
 493       ;; and obtain an updated count.
 494       (let ((values (mapcar #'join-thread threads)))
 495         ;; 20 threads should succeed waiting for the semaphore.
 496         (assert (= (* 2 count) (count-if-not #'null values)))
 497         ;; The updated semaphore count should be in [0,19] at all
 498         ;; times.
 499         (assert (every (lambda (value) (<= 0 value (1- (* 2 count))))
 500                        (remove nil values)))
 501         ;; (At least) one thread should decrease the count to 0.
 502         (assert (find 0 values))))))
 503
 504 (with-test (:name (:join-thread :timeout)
 505                   :skipped-on '(not :sb-thread))
 506   (assert-error
 507    (join-thread (make-join-thread (lambda () (sleep 10))) :timeout 0.01)
 508    join-thread-error)
 509   (let ((cookie (cons t t)))
 510     (assert (eq cookie
 511                 (join-thread (make-join-thread (lambda () (sleep 10)))
 512                              :timeout 0.01
 513                              :default cookie)))))
 514
 515 (with-test (:name (wait-on-semaphore semaphore-notification :lp-1038034)
 516             :skipped-on '(not :sb-thread)
 517             :fails-on :sb-thread)
 518   ;; Test robustness of semaphore acquisition and notification with
 519   ;; asynchronous thread termination...  Which we know is currently
 520   ;; fragile.
 521   (dotimes (run 180)
 522     (let ((sem (make-semaphore)))
 523       ;; In CRITICAL, WAIT-ON-SEMAPHORE and SLEEP can be interrupted
 524       ;; by TERMINATE-THREAD below. But the SIGNAL-SEMAPHORE cleanup
 525       ;; cannot be interrupted.
 526       (flet ((critical (sleep)
 527                (let ((note (make-semaphore-notification)))
 528                  (sb-sys:without-interrupts
 529                      (unwind-protect
 530                           (sb-sys:with-local-interrupts
 531                             (wait-on-semaphore sem :notification note)
 532                             (sleep sleep))
 533                        ;; Re-increment on exit if we decremented it.
 534                        (when (semaphore-notification-status note)
 535                          (signal-semaphore sem)))))))
 536         ;; Create /parallel/ threads trying to acquire and then signal
 537         ;; the semaphore. Try to asynchronously abort T2 just as T1 is
 538         ;; exiting.
 539         (destructuring-bind (t1 t2 t3)
 540             (loop for i from 1
 541                for sleep in '(0.01 0.02 0.02)
 542                collect (make-thread #'critical :arguments sleep
 543                                     :name (format nil "T~A" i)))
 544           (signal-semaphore sem)
 545           (sleep 0.01)
 546           (ignore-errors
 547             (terminate-thread t2))
 548           (flet ((safe-join-thread (thread &key timeout)
 549                    (assert timeout)
 550                    (when (eq :timeout
 551                              (join-thread thread
 552                                           :timeout timeout
 553                                           :default :timeout))
 554                      (error "Hang in (join-thread ~A) ?" thread))))
 555             (safe-join-thread t1 :timeout 10)
 556             (safe-join-thread t3 :timeout 10)))))
 557     (when (zerop (mod run 60))
 558       (fresh-line)
 559       (write-string "; "))
 560     (write-char #\.)
 561     (force-output)))
 562
 563 (with-test (:name (wait-on-semaphore semaphore-notification)
 564             :skipped-on '(not :sb-thread))
 565   (let ((sem (make-semaphore))
 566         (ok nil)
 567         (n 0))
 568     (flet ((critical ()
 569              (let ((note (make-semaphore-notification)))
 570                (sb-sys:without-interrupts
 571                  (unwind-protect
 572                       (progn
 573                         (sb-sys:with-local-interrupts
 574                           (wait-on-semaphore sem :notification note)
 575                           (sleep (random 0.1)))
 576                         (incf n))
 577                    ;; Re-increment on exit if we decremented it.
 578                    (when (semaphore-notification-status note)
 579                      (signal-semaphore sem))
 580                    ;; KLUDGE: Prevent interrupts after this point from
 581                    ;; unwinding us, so that we can reason about the counts.
 582                    #+sb-thread
 583                    (sb-thread::block-deferrable-signals))))))
 584       (let* ((threads (loop for i from 1 upto 100
 585                             collect (make-join-thread #'critical :name (format nil "T~A" i))))
 586              (safe nil)
 587              (unsafe nil)
 588              (interruptor (make-thread (lambda ()
 589                                          (loop until ok)
 590                                          (let (x)
 591                                            (dolist (thread threads)
 592                                              (cond (x
 593                                                     (push thread unsafe)
 594                                                     (sleep (random 0.1))
 595                                                     (ignore-errors
 596                                                      (terminate-thread thread)))
 597                                                    (t
 598                                                     (push thread safe)))
 599                                              (setf x (not x))))))))
 600         (signal-semaphore sem)
 601         (setf ok t)
 602         (join-thread interruptor)
 603         (mapc #'join-thread safe)
 604         (let ((k (count-if (lambda (th)
 605                              (join-thread th :default nil))
 606                            unsafe)))
 607           (assert (= n (+ k (length safe))))
 608           (assert unsafe))))))
 609
 610 (with-test (:name (wait-on-semaphore :n))
 611   (let ((semaphore (make-semaphore :count 3)))
 612     (assert (= 1 (wait-on-semaphore semaphore :n 2)))
 613     (assert (= 1 (semaphore-count semaphore)))))
 614
 615 (with-test (:name (try-semaphore semaphore-notification)
 616             :skipped-on '(not :sb-thread))
 617   (let* ((sem (make-semaphore))
 618          (note (make-semaphore-notification)))
 619     (assert (eql nil (try-semaphore sem 1 note)))
 620     (assert (not (semaphore-notification-status note)))
 621     (signal-semaphore sem)
 622     (assert (eql 0 (try-semaphore sem 1 note)))
 623     (assert (semaphore-notification-status note))))
 624
 625 (with-test (:name (return-from-thread :normal-thread)
 626             :skipped-on '(not :sb-thread))
 627   (let ((thread (make-thread (lambda ()
 628                                (return-from-thread (values 1 2 3))
 629                                :foo))))
 630     (assert (equal '(1 2 3) (multiple-value-list (join-thread thread))))))
 631
 632 (with-test (:name (return-from-thread :main-thread))
 633   (assert (main-thread-p))
 634   (assert-error (return-from-thread t) thread-error))
 635
 636 (with-test (:name (abort-thread :normal-thread)
 637             :skipped-on '(not :sb-thread))
 638   (let ((thread (make-thread (lambda ()
 639                                (abort-thread)
 640                                :foo))))
 641     (assert (equal '(:aborted! :abort)
 642                    (multiple-value-list
 643                     (join-thread thread :default :aborted!))))))
 644
 645 (with-test (:name (abort-thread :main-thread))
 646   (assert (main-thread-p))
 647   (assert-error (abort-thread) thread-error))
 648
 649 ;; SB-THREAD:MAKE-THREAD used to lock SB-THREAD:*MAKE-THREAD-LOCK*
 650 ;; before entering WITHOUT-INTERRUPTS. When a thread which was
 651 ;; executing SB-THREAD:MAKE-THREAD was interrupted with code which
 652 ;; also called SB-THREAD:MAKE-THREAD, it could happen that the first
 653 ;; thread already owned SB-THREAD:*MAKE-THREAD-LOCK* and the
 654 ;; interrupting code thus made a recursive lock attempt.
 655 ;;
 656 ;; See (:TIMER :DISPATCH-THREAD :MAKE-THREAD :BUG-1180102) in
 657 ;; timer.impure.lisp.
 658 (with-test (:name (make-thread :interrupt-with make-thread :bug-1180102)
 659             :skipped-on '(not :sb-thread))
 660   (fresh-line)
 661   (write-string "; ")
 662   (force-output)
 663   (dotimes (i 100)
 664     (let ((threads '())
 665           (parent *current-thread*))
 666       (dotimes (i 100)
 667         (push (make-thread
 668                (lambda ()
 669                  (interrupt-thread
 670                   parent
 671                   (lambda () (push (make-thread (lambda ())) threads)))))
 672               threads)
 673         (push (make-thread (lambda ())) threads))
 674       (mapc #'join-thread threads))
 675     (write-char #\.)
 676     (force-output)))