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 :sb-ext))
  18
  19 (in-package :thread-test)
  20
  21 (use-package :test-util)
  22
  23 (with-test (:name atomic-update
  24             :skipped-on '(not :sb-thread))
  25   (let ((x (cons :count 0))
  26         (nthreads (ecase sb-vm:n-word-bits (32 100) (64 1000))))
  27     (mapc #'sb-thread:join-thread
  28           (loop repeat nthreads
  29                 collect (sb-thread:make-thread
  30                          (lambda ()
  31                            (loop repeat 1000
  32                                  do (atomic-update (cdr x) #'1+)
  33                                     (sleep 0.00001))))))
  34     (assert (equal x `(:count ,@(* 1000 nthreads))))))
  35
  36 (with-test (:name mutex-owner)
  37   ;; Make sure basics are sane on unithreaded ports as well
  38   (let ((mutex (make-mutex)))
  39     (grab-mutex mutex)
  40     (assert (eq *current-thread* (mutex-value mutex)))
  41     (handler-bind ((warning #'error))
  42       (release-mutex mutex))
  43     (assert (not (mutex-value mutex)))))
  44
  45 ;;; Terminating a thread that's waiting for the terminal.
  46
  47 #+sb-thread
  48 (let ((thread (make-thread (lambda ()
  49                              (sb-thread::get-foreground)))))
  50   (sleep 1)
  51   (assert (thread-alive-p thread))
  52   (terminate-thread thread)
  53   (sleep 1)
  54   (assert (not (thread-alive-p thread))))
  55
  56 ;;; Condition-wait should not be interruptible under WITHOUT-INTERRUPTS
  57
  58 (with-test (:name :without-interrupts+condition-wait
  59             :skipped-on '(not :sb-thread)
  60             :fails-on '(and :win32 :sb-futex))
  61   (let* ((lock (make-mutex))
  62          (queue (make-waitqueue))
  63          (thread (make-thread (lambda ()
  64                                 (sb-sys:without-interrupts
  65                                   (with-mutex (lock)
  66                                     (condition-wait queue lock)))))))
  67     (sleep 1)
  68     (assert (thread-alive-p thread))
  69     (terminate-thread thread)
  70     (sleep 1)
  71     (assert (thread-alive-p thread))
  72     (condition-notify queue)
  73     (sleep 1)
  74     (assert (not (thread-alive-p thread)))))
  75
  76 ;;; GRAB-MUTEX should not be interruptible under WITHOUT-INTERRUPTS
  77
  78 (with-test (:name :without-interrupts+grab-mutex :skipped-on '(not :sb-thread))
  79   (let* ((lock (make-mutex))
  80          (bar (progn (grab-mutex lock) nil))
  81          (thread (make-thread (lambda ()
  82                                 (sb-sys:without-interrupts
  83                                     (with-mutex (lock)
  84                                       (setf bar t)))))))
  85     (sleep 1)
  86     (assert (thread-alive-p thread))
  87     (terminate-thread thread)
  88     (sleep 1)
  89     (assert (thread-alive-p thread))
  90     (release-mutex lock)
  91     (sleep 1)
  92     (assert (not (thread-alive-p thread)))
  93     (assert (eq :aborted (join-thread thread :default :aborted)))
  94     (assert bar)))
  95
  96 (with-test (:name :parallel-find-class :skipped-on '(not :sb-thread))
  97   (let* ((oops nil)
  98          (threads (loop repeat 10
  99                         collect (make-thread (lambda ()
 100                                                (handler-case
 101                                                    (loop repeat 10000
 102                                                          do (find-class (gensym) nil))
 103                                                  (serious-condition ()
 104                                                    (setf oops t))))))))
 105     (mapcar #'sb-thread:join-thread threads)
 106     (assert (not oops))))
 107
 108 (with-test (:name :semaphore-multiple-waiters :skipped-on '(not :sb-thread))
 109   (let ((semaphore (make-semaphore :name "test sem")))
 110     (labels ((make-readers (n i)
 111                (values
 112                 (loop for r from 0 below n
 113                       collect
 114                       (sb-thread:make-thread
 115                        (lambda ()
 116                          (let ((sem semaphore))
 117                            (dotimes (s i)
 118                              (sb-thread:wait-on-semaphore sem))))
 119                        :name "reader"))
 120                 (* n i)))
 121              (make-writers (n readers i)
 122                (let ((j (* readers i)))
 123                  (multiple-value-bind (k rem) (truncate j n)
 124                    (values
 125                     (let ((writers
 126                            (loop for w from 0 below n
 127                                  collect
 128                                  (sb-thread:make-thread
 129                                   (lambda ()
 130                                     (let ((sem semaphore))
 131                                       (dotimes (s k)
 132                                         (sb-thread:signal-semaphore sem))))
 133                                   :name "writer"))))
 134                       (assert (zerop rem))
 135                       writers)
 136                     (+ rem (* n k))))))
 137              (test (r w n)
 138                (multiple-value-bind (readers x) (make-readers r n)
 139                  (assert (= (length readers) r))
 140                  (multiple-value-bind (writers y) (make-writers w r n)
 141                    (assert (= (length writers) w))
 142                    (assert (= x y))
 143                    (mapc #'sb-thread:join-thread writers)
 144                    (mapc #'sb-thread:join-thread readers)
 145                    (assert (zerop (sb-thread:semaphore-count semaphore)))
 146                    (values)))))
 147       (assert
 148        (eq :ok
 149            (handler-case
 150                (sb-ext:with-timeout 10
 151                  (test 1 1 100)
 152                  (test 2 2 10000)
 153                  (test 4 2 10000)
 154                  (test 4 2 10000)
 155                  (test 10 10 10000)
 156                  (test 10 1 10000)
 157                  :ok)
 158              (sb-ext:timeout ()
 159                :timeout)))))))
 160
 161 ;;;; Printing waitqueues
 162
 163 (with-test (:name :waitqueue-circle-print :skipped-on '(not :sb-thread))
 164   (let* ((*print-circle* nil)
 165          (lock (sb-thread:make-mutex))
 166          (wq (sb-thread:make-waitqueue)))
 167     (sb-thread:with-recursive-lock (lock)
 168       (sb-thread:condition-notify wq))
 169     ;; Used to blow stack due to recursive structure.
 170     (assert (princ-to-string wq))))
 171
 172 ;;;; SYMBOL-VALUE-IN-THREAD
 173
 174 (with-test (:name :symbol-value-in-thread.1)
 175   (let ((* (cons t t)))
 176     (assert (eq * (symbol-value-in-thread '* *current-thread*)))
 177     (setf (symbol-value-in-thread '* *current-thread*) 123)
 178     (assert (= 123 (symbol-value-in-thread '* *current-thread*)))
 179     (assert (= 123 *))))
 180
 181 (with-test (:name :symbol-value-in-thread.2 :skipped-on '(not :sb-thread))
 182   (let* ((parent *current-thread*)
 183          (semaphore (make-semaphore))
 184          (child (make-thread (lambda ()
 185                                (wait-on-semaphore semaphore)
 186                                (let ((old (symbol-value-in-thread 'this-is-new parent)))
 187                                  (setf (symbol-value-in-thread 'this-is-new parent) :from-child)
 188                                  old)))))
 189     (progv '(this-is-new) '(42)
 190       (signal-semaphore semaphore)
 191       (assert (= 42 (join-thread child)))
 192       (assert (eq :from-child (symbol-value 'this-is-new))))))
 193
 194 ;;; Disabled on Darwin due to deadlocks caused by apparent OS specific deadlocks,
 195 ;;; wich _appear_ to be caused by malloc() and free() not being thread safe: an
 196 ;;; interrupted malloc in one thread can apparently block a free in another.
 197 (with-test (:name :symbol-value-in-thread.3
 198             :skipped-on '(not :sb-thread))
 199   (let* ((parent *current-thread*)
 200          (semaphore (make-semaphore))
 201          (running t)
 202          (noise (make-thread (lambda ()
 203                                (loop while running
 204                                      do (setf * (make-array 1024))
 205                                      ;; Busy-wait a bit so we don't TOTALLY flood the
 206                                      ;; system with GCs: a GC occurring in the middle of
 207                                      ;; S-V-I-T causes it to start over -- we want that
 208                                      ;; to occur occasionally, but not _all_ the time.
 209                                         (loop repeat (random 128)
 210                                               do (setf ** *)))))))
 211     (write-string "; ")
 212     (dotimes (i #+win32 2000 #-win32 15000)
 213       (when (zerop (mod i 200))
 214         (write-char #\.)
 215         (force-output))
 216       (let* ((mom-mark (cons t t))
 217              (kid-mark (cons t t))
 218              (child (make-thread (lambda ()
 219                                    (wait-on-semaphore semaphore)
 220                                    (let ((old (symbol-value-in-thread 'this-is-new parent)))
 221                                      (setf (symbol-value-in-thread 'this-is-new parent)
 222                                            (make-array 24 :initial-element kid-mark))
 223                                      old)))))
 224         (progv '(this-is-new) (list (make-array 24 :initial-element mom-mark))
 225           (signal-semaphore semaphore)
 226           (assert (eq mom-mark (aref (join-thread child) 0)))
 227           (assert (eq kid-mark (aref (symbol-value 'this-is-new) 0))))))
 228     (setf running nil)
 229     (join-thread noise)))
 230
 231 (with-test (:name :symbol-value-in-thread.4 :skipped-on '(not :sb-thread))
 232   (let* ((parent *current-thread*)
 233          (semaphore (make-semaphore))
 234          (child (make-thread (lambda ()
 235                                (wait-on-semaphore semaphore)
 236                                (symbol-value-in-thread 'this-is-new parent nil)))))
 237     (signal-semaphore semaphore)
 238     (assert (equal '(nil nil) (multiple-value-list (join-thread child))))))
 239
 240 (with-test (:name :symbol-value-in-thread.5 :skipped-on '(not :sb-thread))
 241   (let* ((parent *current-thread*)
 242          (semaphore (make-semaphore))
 243          (child (make-thread (lambda ()
 244                                (wait-on-semaphore semaphore)
 245                                (handler-case
 246                                    (symbol-value-in-thread 'this-is-new parent)
 247                                  (symbol-value-in-thread-error (e)
 248                                    (list (thread-error-thread e)
 249                                          (cell-error-name e)
 250                                          (sb-thread::symbol-value-in-thread-error-info e))))))))
 251     (signal-semaphore semaphore)
 252     (assert (equal (list *current-thread* 'this-is-new (list :read :unbound-in-thread))
 253                    (join-thread child)))))
 254
 255 (with-test (:name :symbol-value-in-thread.6 :skipped-on '(not :sb-thread))
 256   (let* ((parent *current-thread*)
 257          (semaphore (make-semaphore))
 258          (name (gensym))
 259          (child (make-thread (lambda ()
 260                                (wait-on-semaphore semaphore)
 261                                (handler-case
 262                                    (setf (symbol-value-in-thread name parent) t)
 263                                  (symbol-value-in-thread-error (e)
 264                                    (list (thread-error-thread e)
 265                                          (cell-error-name e)
 266                                          (sb-thread::symbol-value-in-thread-error-info e))))))))
 267     (signal-semaphore semaphore)
 268     (let ((res (join-thread child))
 269           (want (list *current-thread* name (list :write :no-tls-value))))
 270       (unless (equal res want)
 271         (error "wanted ~S, got ~S" want res)))))
 272
 273 (with-test (:name :symbol-value-in-thread.7 :skipped-on '(not :sb-thread))
 274   (let ((child (make-thread (lambda ())))
 275         (error-occurred nil))
 276     (join-thread child)
 277     (handler-case
 278         (symbol-value-in-thread 'this-is-new child)
 279       (symbol-value-in-thread-error (e)
 280         (setf error-occurred t)
 281         (assert (eq child (thread-error-thread e)))
 282         (assert (eq 'this-is-new (cell-error-name e)))
 283         (assert (equal (list :read :thread-dead)
 284                        (sb-thread::symbol-value-in-thread-error-info e)))))
 285     (assert error-occurred)))
 286
 287 (with-test (:name :symbol-value-in-thread.8  :skipped-on '(not :sb-thread))
 288   (let ((child (make-thread (lambda ())))
 289         (error-occurred nil))
 290     (join-thread child)
 291     (handler-case
 292         (setf (symbol-value-in-thread 'this-is-new child) t)
 293       (symbol-value-in-thread-error (e)
 294         (setf error-occurred t)
 295         (assert (eq child (thread-error-thread e)))
 296         (assert (eq 'this-is-new (cell-error-name e)))
 297         (assert (equal (list :write :thread-dead)
 298                        (sb-thread::symbol-value-in-thread-error-info e)))))
 299     (assert error-occurred)))
 300
 301 (with-test (:name :deadlock-detection.1  :skipped-on '(not :sb-thread))
 302   (loop
 303     repeat 1000
 304     do (flet ((test (ma mb sa sb)
 305                 (lambda ()
 306                   (handler-case
 307                       (sb-thread:with-mutex (ma)
 308                         (sb-thread:signal-semaphore sa)
 309                         (sb-thread:wait-on-semaphore sb)
 310                         (sb-thread:with-mutex (mb)
 311                           :ok))
 312                     (sb-thread:thread-deadlock (e)
 313                       (princ e)
 314                       :deadlock)))))
 315          (let* ((m1 (sb-thread:make-mutex :name "M1"))
 316                 (m2 (sb-thread:make-mutex :name "M2"))
 317                 (s1 (sb-thread:make-semaphore :name "S1"))
 318                 (s2 (sb-thread:make-semaphore :name "S2"))
 319                 (t1 (sb-thread:make-thread (test m1 m2 s1 s2) :name "T1"))
 320                 (t2 (sb-thread:make-thread (test m2 m1 s2 s1) :name "T2")))
 321            ;; One will deadlock, and the other will then complete normally.
 322            (let ((res (list (sb-thread:join-thread t1)
 323                             (sb-thread:join-thread t2))))
 324              (assert (or (equal '(:deadlock :ok) res)
 325                          (equal '(:ok :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 #+sb-thread
 393 (with-test (:name :pass-arguments-to-thread)
 394   (assert (= 3 (join-thread (make-thread #'+ :arguments '(1 2))))))
 395
 396 #+sb-thread
 397 (with-test (:name :pass-atom-to-thread)
 398   (assert (= 1/2 (join-thread (make-thread #'/ :arguments 2)))))
 399
 400 #+sb-thread
 401 (with-test (:name :pass-nil-to-thread)
 402   (assert (= 1 (join-thread (make-thread #'* :arguments '())))))
 403
 404 #+sb-thread
 405 (with-test (:name :pass-nothing-to-thread)
 406   (assert (= 1 (join-thread (make-thread #'*)))))
 407
 408 #+sb-thread
 409 (with-test (:name :pass-improper-list-to-thread)
 410   (multiple-value-bind (value error)
 411       (ignore-errors (make-thread #'+ :arguments '(1 . 1)))
 412     (when value
 413       (join-thread value))
 414     (assert (and (null value)
 415                  error))))
 416
 417 (with-test (:name (:wait-for :basics))
 418   (assert (not (sb-ext:wait-for nil :timeout 0.1)))
 419   (assert (eql 42 (sb-ext:wait-for 42)))
 420   (let ((n 0))
 421     (assert (eql 100 (sb-ext:wait-for (when (= 100 (incf n))
 422                                         n))))))
 423
 424 (with-test (:name (:wait-for :deadline))
 425   (assert (eq :ok
 426               (sb-sys:with-deadline (:seconds 10)
 427                 (assert (not (sb-ext:wait-for nil :timeout 0.1)))
 428                 :ok)))
 429   (assert (eq :deadline
 430               (handler-case
 431                   (sb-sys:with-deadline (:seconds 0.1)
 432                     (sb-ext:wait-for nil :timeout 10)
 433                     (error "oops"))
 434                 (sb-sys:deadline-timeout () :deadline)))))
 435
 436 (with-test (:name (:condition-wait :timeout :one-thread))
 437   (let ((mutex (make-mutex))
 438         (waitqueue (make-waitqueue)))
 439     (assert (not (with-mutex (mutex)
 440                    (condition-wait waitqueue mutex :timeout 0.01))))))
 441
 442 (with-test (:name (:condition-wait :timeout :many-threads)
 443             :skipped-on '(not :sb-thread))
 444   (let* ((mutex (make-mutex))
 445          (waitqueue (make-waitqueue))
 446          (sem (make-semaphore))
 447          (data nil)
 448          (workers
 449            (loop repeat 100
 450                  collect (make-thread
 451                           (lambda ()
 452                             (wait-on-semaphore sem)
 453                             (block thread
 454                               (with-mutex (mutex)
 455                                 (loop until data
 456                                       do (or (condition-wait waitqueue mutex :timeout 0.01)
 457                                              (return-from thread nil)))
 458                                 (assert (eq t (pop data)))
 459                                 t)))))))
 460     (loop repeat 50
 461           do (with-mutex (mutex)
 462                (push t data)
 463                (condition-notify waitqueue)))
 464     (signal-semaphore sem 100)
 465     (let ((ok (count-if #'join-thread workers)))
 466       (unless (eql 50 ok)
 467         (error "Wanted 50, got ~S" ok)))))
 468
 469 (with-test (:name (:wait-on-semaphore :timeout :one-thread))
 470   (let ((sem (make-semaphore))
 471         (n 0))
 472     (signal-semaphore sem 10)
 473     (loop repeat 100
 474           do (when (wait-on-semaphore sem :timeout 0.001)
 475                (incf n)))
 476     (assert (= n 10))))
 477
 478 (with-test (:name (:wait-on-semaphore :timeout :many-threads)
 479             :skipped-on '(not :sb-thread))
 480   (let* ((sem (make-semaphore))
 481          (threads
 482            (progn
 483              (signal-semaphore sem 10)
 484              (loop repeat 100
 485                    collect (make-thread
 486                             (lambda ()
 487                               (sleep (random 0.02))
 488                               (wait-on-semaphore sem :timeout 0.5)))))))
 489     (loop repeat 5
 490           do (signal-semaphore sem 2))
 491     (let ((ok (count-if #'join-thread threads)))
 492       (unless (eql 20 ok)
 493         (error "Wanted 20, got ~S" ok)))))
 494
 495 (with-test (:name (:join-thread :timeout)
 496             :skipped-on '(not :sb-thread))
 497   (assert (eq :error
 498               (handler-case
 499                   (join-thread (make-join-thread (lambda () (sleep 10))) :timeout 0.01)
 500                 (join-thread-error ()
 501                   :error))))
 502   (let ((cookie (cons t t)))
 503     (assert (eq cookie
 504                 (join-thread (make-join-thread (lambda () (sleep 10)))
 505                              :timeout 0.01
 506                              :default cookie)))))
 507
 508 (with-test (:name (:semaphore-notification :wait-on-semaphore :lp-1038034)
 509             :skipped-on '(not :sb-thread)
 510             :fails-on :sb-thread)
 511   ;; Test robustness of semaphore acquisition and notification with
 512   ;; asynchronous thread termination...  Which we know is currently
 513   ;; fragile.
 514   (dotimes (run 180)
 515     (let ((sem (make-semaphore)))
 516       ;; In CRITICAL, WAIT-ON-SEMAPHORE and SLEEP can be interrupted
 517       ;; by TERMINATE-THREAD below. But the SIGNAL-SEMAPHORE cleanup
 518       ;; cannot be interrupted.
 519       (flet ((critical (sleep)
 520                (let ((note (make-semaphore-notification)))
 521                  (sb-sys:without-interrupts
 522                      (unwind-protect
 523                           (sb-sys:with-local-interrupts
 524                             (wait-on-semaphore sem :notification note)
 525                             (sleep sleep))
 526                        ;; Re-increment on exit if we decremented it.
 527                        (when (semaphore-notification-status note)
 528                          (signal-semaphore sem)))))))
 529         ;; Create /parallel/ threads trying to acquire and then signal
 530         ;; the semaphore. Try to asynchronously abort T2 just as T1 is
 531         ;; exiting.
 532         (destructuring-bind (t1 t2 t3)
 533             (loop for i from 1
 534                for sleep in '(0.01 0.02 0.02)
 535                collect (make-thread #'critical :arguments sleep
 536                                     :name (format nil "T~A" i)))
 537           (signal-semaphore sem)
 538           (sleep 0.01)
 539           (ignore-errors
 540             (terminate-thread t2))
 541           (flet ((safe-join-thread (thread &key timeout)
 542                    (assert timeout)
 543                    (when (eq :timeout
 544                              (join-thread thread
 545                                           :timeout timeout
 546                                           :default :timeout))
 547                      (error "Hang in (join-thread ~A) ?" thread))))
 548             (safe-join-thread t1 :timeout 10)
 549             (safe-join-thread t3 :timeout 10)))))
 550     (when (zerop (mod run 60))
 551       (fresh-line)
 552       (write-string "; "))
 553     (write-char #\.)
 554     (force-output)))
 555
 556 (with-test (:name (:semaphore-notification :wait-on-semaphore)
 557             :skipped-on '(not :sb-thread))
 558   (let ((sem (make-semaphore))
 559         (ok nil)
 560         (n 0))
 561     (flet ((critical ()
 562              (let ((note (make-semaphore-notification)))
 563                (sb-sys:without-interrupts
 564                  (unwind-protect
 565                       (progn
 566                         (sb-sys:with-local-interrupts
 567                           (wait-on-semaphore sem :notification note)
 568                           (sleep (random 0.1)))
 569                         (incf n))
 570                    ;; Re-increment on exit if we decremented it.
 571                    (when (semaphore-notification-status note)
 572                      (signal-semaphore sem))
 573                    ;; KLUDGE: Prevent interrupts after this point from
 574                    ;; unwinding us, so that we can reason about the counts.
 575                    #+sb-thread
 576                    (sb-thread::block-deferrable-signals))))))
 577       (let* ((threads (loop for i from 1 upto 100
 578                             collect (make-join-thread #'critical :name (format nil "T~A" i))))
 579              (safe nil)
 580              (unsafe nil)
 581              (interruptor (make-thread (lambda ()
 582                                          (loop until ok)
 583                                          (let (x)
 584                                            (dolist (thread threads)
 585                                              (cond (x
 586                                                     (push thread unsafe)
 587                                                     (sleep (random 0.1))
 588                                                     (ignore-errors
 589                                                      (terminate-thread thread)))
 590                                                    (t
 591                                                     (push thread safe)))
 592                                              (setf x (not x))))))))
 593         (signal-semaphore sem)
 594         (setf ok t)
 595         (join-thread interruptor)
 596         (mapc #'join-thread safe)
 597         (let ((k (count-if (lambda (th)
 598                              (join-thread th :default nil))
 599                            unsafe)))
 600           (assert (= n (+ k (length safe))))
 601           (assert unsafe))))))
 602
 603 (with-test (:name (:semaphore-notification :try-sempahore)
 604             :skipped-on '(not :sb-thread))
 605   (let* ((sem (make-semaphore))
 606          (note (make-semaphore-notification)))
 607     (try-semaphore sem 1 note)
 608     (assert (not (semaphore-notification-status note)))
 609     (signal-semaphore sem)
 610     (try-semaphore sem 1 note)
 611     (assert (semaphore-notification-status note))))
 612
 613 (with-test (:name (:return-from-thread :normal-thread)
 614             :skipped-on '(not :sb-thread))
 615   (let* ((thread (make-thread (lambda ()
 616                                 (return-from-thread (values 1 2 3))
 617                                 :foo)))
 618          (values (multiple-value-list (join-thread thread))))
 619     (unless (equal (list 1 2 3) values)
 620       (error "got ~S, wanted (1 2 3)" values))))
 621
 622 (with-test (:name (:return-from-thread :main-thread))
 623   (assert (main-thread-p))
 624   (assert (eq :oops
 625               (handler-case
 626                   (return-from-thread t)
 627                 (thread-error ()
 628                   :oops)))))
 629
 630 (with-test (:name (:abort-thread :normal-thread)
 631             :skipped-on '(not :sb-thread))
 632   (let ((thread (make-thread (lambda ()
 633                                (abort-thread)
 634                                :foo))))
 635     (assert (eq :aborted! (join-thread thread :default :aborted!)))))
 636
 637 (with-test (:name (:abort-thread :main-thread))
 638   (assert (main-thread-p))
 639   (assert (eq :oops
 640               (handler-case
 641                   (abort-thread)
 642                 (thread-error ()
 643                   :oops)))))
 644
 645 ;; SB-THREAD:MAKE-THREAD used to lock SB-THREAD:*MAKE-THREAD-LOCK*
 646 ;; before entering WITHOUT-INTERRUPTS. When a thread which was
 647 ;; executing SB-THREAD:MAKE-THREAD was interrupted with code which
 648 ;; also called SB-THREAD:MAKE-THREAD, it could happen that the first
 649 ;; thread already owned SB-THREAD:*MAKE-THREAD-LOCK* and the
 650 ;; interrupting code thus made a recursive lock attempt.
 651 ;;
 652 ;; See (:TIMER :DISPATCH-THREAD :MAKE-THREAD :BUG-1180102) in
 653 ;; timer.impure.lisp.
 654 (with-test (:name (make-thread :interrupt-with make-thread :bug-1180102)
 655             :skipped-on '(not :sb-thread))
 656   (dotimes (i 100)
 657     (let ((threads '())
 658           (parent *current-thread*))
 659       (dotimes (i 100)
 660         (push (make-thread
 661                (lambda ()
 662                  (interrupt-thread
 663                   parent
 664                   (lambda () (push (make-thread (lambda ())) threads)))))
 665               threads)
 666         (push (make-thread (lambda ())) threads))
 667       (mapc #'join-thread threads))))