tests/threads.pure.lisp

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