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 (with-test (:name (:terminate-thread :get-foreground)
  43                   :skipped-on (not :sb-thread)
  44                   :broken-on :win32)
  45  (let ((thread (make-thread (lambda ()
  46                               (sb-thread::get-foreground)))))
  47    (sleep 1)
  48    (assert (thread-alive-p thread))
  49    (terminate-thread thread)
  50    (sleep 1)
  51    (assert (not (thread-alive-p thread)))))
  52
  53 ;;; Condition-wait should not be interruptible under WITHOUT-INTERRUPTS
  54
  55 (with-test (:name :without-interrupts+condition-wait
  56             :skipped-on (not :sb-thread)
  57             :broken-on :win32)
  58   (let* ((lock (make-mutex))
  59          (queue (make-waitqueue))
  60          (thread (make-thread (lambda ()
  61                                 (sb-sys:without-interrupts
  62                                   (with-mutex (lock)
  63                                     (condition-wait queue lock)))))))
  64     (sleep 1)
  65     (assert (thread-alive-p thread))
  66     (terminate-thread thread)
  67     (sleep 1)
  68     (assert (thread-alive-p thread))
  69     (condition-notify queue)
  70     (sleep 1)
  71     (assert (not (thread-alive-p thread)))))
  72
  73 ;;; GRAB-MUTEX should not be interruptible under WITHOUT-INTERRUPTS
  74
  75 (with-test (:name :without-interrupts+grab-mutex
  76             :skipped-on (not :sb-thread)
  77             :broken-on :win32)
  78   (let* ((lock (make-mutex))
  79          (bar (progn (grab-mutex lock) nil))
  80          (thread (make-thread (lambda ()
  81                                 (sb-sys:without-interrupts
  82                                     (with-mutex (lock)
  83                                       (setf bar t)))))))
  84     (sleep 1)
  85     (assert (thread-alive-p thread))
  86     (terminate-thread thread)
  87     (sleep 1)
  88     (assert (thread-alive-p thread))
  89     (release-mutex lock)
  90     (sleep 1)
  91     (assert (not (thread-alive-p thread)))
  92     (assert (eq :aborted (join-thread thread :default :aborted)))
  93     (assert bar)))
  94
  95 (with-test (:name :parallel-find-class :skipped-on (not :sb-thread))
  96   (let* ((oops nil)
  97          (threads (loop repeat 10
  98                         collect (make-thread (lambda ()
  99                                                (handler-case
 100                                                    (loop repeat 10000
 101                                                          do (find-class (gensym) nil))
 102                                                  (serious-condition ()
 103                                                    (setf oops t))))))))
 104     (mapc #'join-thread threads)
 105     (assert (not oops))))
 106
 107 (with-test (:name :semaphore-multiple-waiters :skipped-on (not :sb-thread))
 108   (let ((semaphore (make-semaphore :name "test sem")))
 109     (labels ((make-readers (n i)
 110                (values
 111                 (loop for r from 0 below n
 112                       collect
 113                       (make-thread
 114                        (lambda ()
 115                          (let ((sem semaphore))
 116                            (dotimes (s i)
 117                              (wait-on-semaphore sem))))
 118                        :name "reader"))
 119                 (* n i)))
 120              (make-writers (n readers i)
 121                (let ((j (* readers i)))
 122                  (multiple-value-bind (k rem) (truncate j n)
 123                    (values
 124                     (let ((writers
 125                            (loop for w from 0 below n
 126                                  collect
 127                                  (make-thread
 128                                   (lambda ()
 129                                     (let ((sem semaphore))
 130                                       (dotimes (s k)
 131                                         (signal-semaphore sem))))
 132                                   :name "writer"))))
 133                       (assert (zerop rem))
 134                       writers)
 135                     (+ rem (* n k))))))
 136              (test (r w n)
 137                (multiple-value-bind (readers x) (make-readers r n)
 138                  (assert (= (length readers) r))
 139                  (multiple-value-bind (writers y) (make-writers w r n)
 140                    (assert (= (length writers) w))
 141                    (assert (= x y))
 142                    (mapc #'join-thread writers)
 143                    (mapc #'join-thread readers)
 144                    (assert (zerop (semaphore-count semaphore)))
 145                    (values)))))
 146       (assert
 147        (eq :ok
 148            (handler-case
 149                (sb-ext:with-timeout 10
 150                  (test 1 1 100)
 151                  (test 2 2 10000)
 152                  (test 4 2 10000)
 153                  (test 4 2 10000)
 154                  (test 10 10 10000)
 155                  (test 10 1 10000)
 156                  :ok)
 157              (sb-ext:timeout ()
 158                :timeout)))))))
 159
 160 ;;;; Printing waitqueues
 161
 162 (with-test (:name :waitqueue-circle-print :skipped-on (not :sb-thread))
 163   (let* ((*print-circle* nil)
 164          (lock (make-mutex))
 165          (wq (make-waitqueue)))
 166     (with-recursive-lock (lock)
 167       (condition-notify wq))
 168     ;; Used to blow stack due to recursive structure.
 169     (assert (princ-to-string wq))))
 170
 171 ;;;; SYMBOL-VALUE-IN-THREAD
 172
 173 (with-test (:name :symbol-value-in-thread.1)
 174   (let ((* (cons t t)))
 175     (assert (eq * (symbol-value-in-thread '* *current-thread*)))
 176     (setf (symbol-value-in-thread '* *current-thread*) 123)
 177     (assert (= 123 (symbol-value-in-thread '* *current-thread*)))
 178     (assert (= 123 *))))
 179
 180 (with-test (:name :symbol-value-in-thread.2 :skipped-on (not :sb-thread))
 181   (let* ((parent *current-thread*)
 182          (semaphore (make-semaphore))
 183          (child (make-thread (lambda ()
 184                                (wait-on-semaphore semaphore)
 185                                (let ((old (symbol-value-in-thread 'this-is-new parent)))
 186                                  (setf (symbol-value-in-thread 'this-is-new parent) :from-child)
 187                                  old)))))
 188     (progv '(this-is-new) '(42)
 189       (signal-semaphore semaphore)
 190       (assert (= 42 (join-thread child)))
 191       (assert (eq :from-child (symbol-value 'this-is-new))))))
 192
 193 ;;; Disabled on Darwin due to deadlocks caused by apparent OS specific deadlocks,
 194 ;;; wich _appear_ to be caused by malloc() and free() not being thread safe: an
 195 ;;; interrupted malloc in one thread can apparently block a free in another.
 196 (with-test (:name :symbol-value-in-thread.3
 197             :skipped-on (not :sb-thread))
 198   (let* ((parent *current-thread*)
 199          (semaphore (make-semaphore))
 200          (running t)
 201          (noise (make-thread (lambda ()
 202                                (loop while running
 203                                      do (setf * (make-array 1024))
 204                                      ;; Busy-wait a bit so we don't TOTALLY flood the
 205                                      ;; system with GCs: a GC occurring in the middle of
 206                                      ;; S-V-I-T causes it to start over -- we want that
 207                                      ;; to occur occasionally, but not _all_ the time.
 208                                         (loop repeat (random 128)
 209                                               do (setf ** *)))))))
 210     (write-string "; ")
 211     (dotimes (i #+(or win32 openbsd) 2000
 212                 #-(or win32 openbsd) 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                       (with-mutex (ma)
 308                         (signal-semaphore sa)
 309                         (wait-on-semaphore sb)
 310                         (with-mutex (mb)
 311                           :ok))
 312                     (thread-deadlock (e)
 313                       ;; (assert (plusp (length ...))) prevents
 314                       ;; flushing.
 315                       (assert (plusp (length (princ-to-string e))))
 316                       :deadlock)))))
 317          (let* ((m1 (make-mutex :name "M1"))
 318                 (m2 (make-mutex :name "M2"))
 319                 (s1 (make-semaphore :name "S1"))
 320                 (s2 (make-semaphore :name "S2"))
 321                 (t1 (make-thread (test m1 m2 s1 s2) :name "T1"))
 322                 (t2 (make-thread (test m2 m1 s2 s1) :name "T2")))
 323            ;; One will deadlock, and the other will then complete normally.
 324            (let ((res (list (join-thread t1)
 325                             (join-thread t2))))
 326              (assert (or (equal '(:deadlock :ok) res)
 327                          (equal '(:ok :deadlock) res))))))))
 328
 329 (with-test (:name :deadlock-detection.2 :skipped-on (not :sb-thread))
 330   (let* ((m1 (make-mutex :name "M1"))
 331          (m2 (make-mutex :name "M2"))
 332          (s1 (make-semaphore :name "S1"))
 333          (s2 (make-semaphore :name "S2"))
 334          (t1 (make-thread
 335               (lambda ()
 336                 (with-mutex (m1)
 337                   (signal-semaphore s1)
 338                   (wait-on-semaphore s2)
 339                   (with-mutex (m2)
 340                     :ok)))
 341               :name "T1")))
 342     (prog (err)
 343      :retry
 344        (handler-bind ((thread-deadlock
 345                        (lambda (e)
 346                          (unless err
 347                            ;; Make sure we can print the condition
 348                            ;; while it's active
 349                            (let ((*print-circle* nil))
 350                              (setf err (princ-to-string e)))
 351                            (go :retry)))))
 352          (when err
 353            (sleep 1))
 354          (assert (eq :ok (with-mutex (m2)
 355                            (unless err
 356                              (signal-semaphore s2)
 357                              (wait-on-semaphore s1)
 358                              (sleep 1))
 359                            (with-mutex (m1)
 360                              :ok)))))
 361        (assert (stringp err)))
 362     (assert (eq :ok (join-thread t1)))))
 363
 364 (with-test (:name :deadlock-detection.3  :skipped-on (not :sb-thread))
 365   (let* ((m1 (make-mutex :name "M1"))
 366          (m2 (make-mutex :name "M2"))
 367          (s1 (make-semaphore :name "S1"))
 368          (s2 (make-semaphore :name "S2"))
 369          (t1 (make-thread
 370               (lambda ()
 371                 (with-mutex (m1)
 372                   (signal-semaphore s1)
 373                   (wait-on-semaphore s2)
 374                   (with-mutex (m2)
 375                     :ok)))
 376               :name "T1")))
 377     ;; Currently we don't consider it a deadlock
 378     ;; if there is a timeout in the chain.
 379     (assert (eq :deadline
 380                 (handler-case
 381                     (with-mutex (m2)
 382                       (signal-semaphore s2)
 383                       (wait-on-semaphore s1)
 384                       (sleep 1)
 385                       (sb-sys:with-deadline (:seconds 0.1)
 386                         (with-mutex (m1)
 387                           :ok)))
 388                   (sb-sys:deadline-timeout ()
 389                     :deadline)
 390                   (thread-deadlock ()
 391                     :deadlock))))
 392     (assert (eq :ok (join-thread t1)))))
 393
 394 #+sb-thread
 395 (with-test (:name :pass-arguments-to-thread)
 396   (assert (= 3 (join-thread (make-thread #'+ :arguments '(1 2))))))
 397
 398 #+sb-thread
 399 (with-test (:name :pass-atom-to-thread)
 400   (assert (= 1/2 (join-thread (make-thread #'/ :arguments 2)))))
 401
 402 #+sb-thread
 403 (with-test (:name :pass-nil-to-thread)
 404   (assert (= 1 (join-thread (make-thread #'* :arguments '())))))
 405
 406 #+sb-thread
 407 (with-test (:name :pass-nothing-to-thread)
 408   (assert (= 1 (join-thread (make-thread #'*)))))
 409
 410 #+sb-thread
 411 (with-test (:name :pass-improper-list-to-thread)
 412   (multiple-value-bind (value error)
 413       (ignore-errors (make-thread #'+ :arguments '(1 . 1)))
 414     (when value
 415       (join-thread value))
 416     (assert (and (null value)
 417                  error))))
 418
 419 (with-test (:name (:wait-for :basics))
 420   (assert (not (sb-ext:wait-for nil :timeout 0.1)))
 421   (assert (eql 42 (sb-ext:wait-for 42)))
 422   (let ((n 0))
 423     (assert (eql 100 (sb-ext:wait-for (when (= 100 (incf n))
 424                                         n))))))
 425
 426 (with-test (:name (:wait-for :deadline))
 427   (assert (eq :ok
 428               (sb-sys:with-deadline (:seconds 10)
 429                 (assert (not (sb-ext:wait-for nil :timeout 0.1)))
 430                 :ok)))
 431   (assert (eq :deadline
 432               (handler-case
 433                   (sb-sys:with-deadline (:seconds 0.1)
 434                     (sb-ext:wait-for nil :timeout 10)
 435                     (error "oops"))
 436                 (sb-sys:deadline-timeout () :deadline)))))
 437
 438 (with-test (:name (:condition-wait :timeout :one-thread))
 439   (let ((mutex (make-mutex))
 440         (waitqueue (make-waitqueue)))
 441     (assert (not (with-mutex (mutex)
 442                    (condition-wait waitqueue mutex :timeout 0.01))))))
 443
 444 (with-test (:name (:condition-wait :timeout :many-threads)
 445             :skipped-on (not :sb-thread))
 446   (let* ((mutex (make-mutex))
 447          (waitqueue (make-waitqueue))
 448          (sem (make-semaphore))
 449          (data nil)
 450          (workers
 451            (loop repeat 100
 452                  collect (make-thread
 453                           (lambda ()
 454                             (wait-on-semaphore sem)
 455                             (block thread
 456                               (with-mutex (mutex)
 457                                 (loop until data
 458                                       do (or (condition-wait waitqueue mutex :timeout 0.01)
 459                                              (return-from thread nil)))
 460                                 (assert (eq t (pop data)))
 461                                 t)))))))
 462     (loop repeat 50
 463           do (with-mutex (mutex)
 464                (push t data)
 465                (condition-notify waitqueue)))
 466     (signal-semaphore sem 100)
 467     (let ((ok (count-if #'join-thread workers)))
 468       (unless (eql 50 ok)
 469         (error "Wanted 50, got ~S" ok)))))
 470
 471 (with-test (:name (wait-on-semaphore :timeout :one-thread))
 472   (let ((count 10)
 473         (semaphore (make-semaphore)))
 474     (signal-semaphore semaphore count)
 475     (let ((values (loop repeat 100
 476                      collect (wait-on-semaphore semaphore :timeout 0.001)))
 477           (expected (loop for i from 9 downto 0 collect i)))
 478       (assert (equal (remove nil values) expected)))))
 479
 480 (with-test (:name (wait-on-semaphore :timeout :many-threads)
 481             :skipped-on (not :sb-thread))
 482   (let* ((count 10)
 483          (semaphore (make-semaphore)))
 484     ;; Add 10 tokens right away.
 485     (signal-semaphore semaphore count)
 486     ;; 100 threads try to decrement the semaphore by 1.
 487     (let ((threads
 488            (loop repeat 100
 489               collect (make-thread
 490                        (lambda ()
 491                          (sleep (random 0.02))
 492                          (wait-on-semaphore semaphore :timeout 0.5))))))
 493       ;; Add 10 more tokens while threads may already be waiting and
 494       ;; decrementing.
 495       (loop repeat (floor count 2) do (signal-semaphore semaphore 2))
 496       ;; 20 threads should have been able to decrement the semaphore
 497       ;; and obtain an updated count.
 498       (let ((values (mapcar #'join-thread threads)))
 499         ;; 20 threads should succeed waiting for the semaphore.
 500         (assert (= (* 2 count) (count-if-not #'null values)))
 501         ;; The updated semaphore count should be in [0,19] at all
 502         ;; times.
 503         (assert (every (lambda (value) (<= 0 value (1- (* 2 count))))
 504                        (remove nil values)))
 505         ;; (At least) one thread should decrease the count to 0.
 506         (assert (find 0 values))))))
 507
 508 (with-test (:name (:join-thread :timeout)
 509                   :skipped-on (not :sb-thread))
 510   (assert-error
 511    (join-thread (make-join-thread (lambda () (sleep 10))) :timeout 0.01)
 512    join-thread-error)
 513   (let ((cookie (cons t t)))
 514     (assert (eq cookie
 515                 (join-thread (make-join-thread (lambda () (sleep 10)))
 516                              :timeout 0.01
 517                              :default cookie)))))
 518
 519 (with-test (:name (wait-on-semaphore semaphore-notification :lp-1038034)
 520             :skipped-on (not :sb-thread)
 521             :fails-on :sb-thread
 522             :broken-on :win32)
 523   ;; Test robustness of semaphore acquisition and notification with
 524   ;; asynchronous thread termination...  Which we know is currently
 525   ;; fragile.
 526   (dotimes (run 180)
 527     (let ((sem (make-semaphore)))
 528       ;; In CRITICAL, WAIT-ON-SEMAPHORE and SLEEP can be interrupted
 529       ;; by TERMINATE-THREAD below. But the SIGNAL-SEMAPHORE cleanup
 530       ;; cannot be interrupted.
 531       (flet ((critical (sleep)
 532                (let ((note (make-semaphore-notification)))
 533                  (sb-sys:without-interrupts
 534                      (unwind-protect
 535                           (sb-sys:with-local-interrupts
 536                             (wait-on-semaphore sem :notification note)
 537                             (sleep sleep))
 538                        ;; Re-increment on exit if we decremented it.
 539                        (when (semaphore-notification-status note)
 540                          (signal-semaphore sem)))))))
 541         ;; Create /parallel/ threads trying to acquire and then signal
 542         ;; the semaphore. Try to asynchronously abort T2 just as T1 is
 543         ;; exiting.
 544         (destructuring-bind (t1 t2 t3)
 545             (loop for i from 1
 546                for sleep in '(0.01 0.02 0.02)
 547                collect (make-thread #'critical :arguments sleep
 548                                     :name (format nil "T~A" i)))
 549           (signal-semaphore sem)
 550           (sleep 0.01)
 551           (ignore-errors
 552             (terminate-thread t2))
 553           (flet ((safe-join-thread (thread &key timeout)
 554                    (assert timeout)
 555                    (when (eq :timeout
 556                              (join-thread thread
 557                                           :timeout timeout
 558                                           :default :timeout))
 559                      (error "Hang in (join-thread ~A) ?" thread))))
 560             (safe-join-thread t1 :timeout 10)
 561             (safe-join-thread t3 :timeout 10)))))
 562     (when (zerop (mod run 60))
 563       (fresh-line)
 564       (write-string "; "))
 565     (write-char #\.)
 566     (force-output)))
 567
 568 (with-test (:name (wait-on-semaphore semaphore-notification)
 569             :skipped-on (not :sb-thread)
 570             :broken-on :win32)
 571   (let ((sem (make-semaphore))
 572         (ok nil)
 573         (n 0))
 574     (flet ((critical ()
 575              (let ((note (make-semaphore-notification)))
 576                (sb-sys:without-interrupts
 577                  (unwind-protect
 578                       (progn
 579                         (sb-sys:with-local-interrupts
 580                           (wait-on-semaphore sem :notification note)
 581                           (sleep (random 0.1)))
 582                         (incf n))
 583                    ;; Re-increment on exit if we decremented it.
 584                    (when (semaphore-notification-status note)
 585                      (signal-semaphore sem))
 586                    ;; KLUDGE: Prevent interrupts after this point from
 587                    ;; unwinding us, so that we can reason about the counts.
 588                    #+sb-thread
 589                    (sb-thread::block-deferrable-signals))))))
 590       (let* ((threads (loop for i from 1 upto 100
 591                             collect (make-join-thread #'critical :name (format nil "T~A" i))))
 592              (safe nil)
 593              (unsafe nil)
 594              (interruptor (make-thread (lambda ()
 595                                          (loop until ok)
 596                                          (let (x)
 597                                            (dolist (thread threads)
 598                                              (cond (x
 599                                                     (push thread unsafe)
 600                                                     (sleep (random 0.1))
 601                                                     (ignore-errors
 602                                                      (terminate-thread thread)))
 603                                                    (t
 604                                                     (push thread safe)))
 605                                              (setf x (not x))))))))
 606         (signal-semaphore sem)
 607         (setf ok t)
 608         (join-thread interruptor)
 609         (mapc #'join-thread safe)
 610         (let ((k (count-if (lambda (th)
 611                              (join-thread th :default nil))
 612                            unsafe)))
 613           (assert (= n (+ k (length safe))))
 614           (assert unsafe))))))
 615
 616 (with-test (:name (wait-on-semaphore :n))
 617   (let ((semaphore (make-semaphore :count 3)))
 618     (assert (= 1 (wait-on-semaphore semaphore :n 2)))
 619     (assert (= 1 (semaphore-count semaphore)))))
 620
 621 (with-test (:name (try-semaphore semaphore-notification)
 622             :skipped-on (not :sb-thread))
 623   (let* ((sem (make-semaphore))
 624          (note (make-semaphore-notification)))
 625     (assert (eql nil (try-semaphore sem 1 note)))
 626     (assert (not (semaphore-notification-status note)))
 627     (signal-semaphore sem)
 628     (assert (eql 0 (try-semaphore sem 1 note)))
 629     (assert (semaphore-notification-status note))))
 630
 631 (with-test (:name (return-from-thread :normal-thread)
 632             :skipped-on (not :sb-thread))
 633   (let ((thread (make-thread (lambda ()
 634                                (return-from-thread (values 1 2 3))
 635                                :foo))))
 636     (assert (equal '(1 2 3) (multiple-value-list (join-thread thread))))))
 637
 638 (with-test (:name (return-from-thread :main-thread))
 639   (assert (main-thread-p))
 640   (assert-error (return-from-thread t) thread-error))
 641
 642 (with-test (:name (abort-thread :normal-thread)
 643             :skipped-on (not :sb-thread))
 644   (let ((thread (make-thread (lambda ()
 645                                (abort-thread)
 646                                :foo))))
 647     (assert (equal '(:aborted! :abort)
 648                    (multiple-value-list
 649                     (join-thread thread :default :aborted!))))))
 650
 651 (with-test (:name (abort-thread :main-thread))
 652   (assert (main-thread-p))
 653   (assert-error (abort-thread) thread-error))
 654
 655 ;; SB-THREAD:MAKE-THREAD used to lock SB-THREAD:*MAKE-THREAD-LOCK*
 656 ;; before entering WITHOUT-INTERRUPTS. When a thread which was
 657 ;; executing SB-THREAD:MAKE-THREAD was interrupted with code which
 658 ;; also called SB-THREAD:MAKE-THREAD, it could happen that the first
 659 ;; thread already owned SB-THREAD:*MAKE-THREAD-LOCK* and the
 660 ;; interrupting code thus made a recursive lock attempt.
 661 ;;
 662 ;; See (:TIMER :DISPATCH-THREAD :MAKE-THREAD :BUG-1180102) in
 663 ;; timer.impure.lisp.
 664 (with-test (:name (make-thread :interrupt-with make-thread :bug-1180102)
 665             :skipped-on (not :sb-thread)
 666             :broken-on :win32)
 667   (fresh-line)
 668   (write-string "; ")
 669   (force-output)
 670   (dotimes (i 100)
 671     (let ((threads '())
 672           (parent *current-thread*))
 673       (dotimes (i 100)
 674         (push (make-thread
 675                (lambda ()
 676                  (interrupt-thread
 677                   parent
 678                   (lambda () (push (make-thread (lambda ())) threads)))))
 679               threads)
 680         (push (make-thread (lambda ())) threads))
 681       (mapc #'join-thread threads))
 682     (write-char #\.)
 683     (force-output)))