tests/threads.pure.lisp

   1 ;;;; miscellaneous tests of thread stuff
   2
   3 ;;;; This software is part of the SBCL system. See the README file for
   4 ;;;; more information.
   5 ;;;;
   6 ;;;; While most of SBCL is derived from the CMU CL system, the test
   7 ;;;; files (like this one) were written from scratch after the fork
   8 ;;;; from CMU CL.
   9 ;;;
  10 ;;;; This software is in the public domain and is provided with
  11 ;;;; absoluely no warranty. See the COPYING and CREDITS files for
  12 ;;;; more information.
  13
  14 (in-package :cl-user)
  15
  16 (defpackage :thread-test
  17   (:use :cl :sb-thread))
  18
  19 (in-package :thread-test)
  20
  21 (use-package :test-util)
  22
  23 (with-test (:name mutex-owner)
  24   ;; Make sure basics are sane on unithreaded ports as well
  25   (let ((mutex (make-mutex)))
  26     (get-mutex mutex)
  27     (assert (eq *current-thread* (mutex-value mutex)))
  28     (handler-bind ((warning #'error))
  29       (release-mutex mutex))
  30     (assert (not (mutex-value mutex)))))
  31
  32 (with-test (:name spinlock-owner)
  33   ;; Make sure basics are sane on unithreaded ports as well
  34   (let ((spinlock (sb-thread::make-spinlock)))
  35     (sb-thread::get-spinlock spinlock)
  36     (assert (eq *current-thread* (sb-thread::spinlock-value spinlock)))
  37     (handler-bind ((warning #'error))
  38       (sb-thread::release-spinlock spinlock))
  39     (assert (not (sb-thread::spinlock-value spinlock)))))
  40
  41 ;;; Terminating a thread that's waiting for the terminal.
  42
  43 #+sb-thread
  44 (let ((thread (make-thread (lambda ()
  45                              (sb-thread::get-foreground)))))
  46   (sleep 1)
  47   (assert (thread-alive-p thread))
  48   (terminate-thread thread)
  49   (sleep 1)
  50   (assert (not (thread-alive-p thread))))
  51
  52 ;;; Condition-wait should not be interruptible under WITHOUT-INTERRUPTS
  53
  54 (with-test (:name without-interrupts+condition-wait
  55             :fails-on :sb-lutex
  56             :skipped-on '(not :sb-thread))
  57   (let* ((lock (make-mutex))
  58          (queue (make-waitqueue))
  59          (thread (make-thread (lambda ()
  60                                 (sb-sys:without-interrupts
  61                                   (with-mutex (lock)
  62                                     (condition-wait queue lock)))))))
  63     (sleep 1)
  64     (assert (thread-alive-p thread))
  65     (terminate-thread thread)
  66     (sleep 1)
  67     (assert (thread-alive-p thread))
  68     (condition-notify queue)
  69     (sleep 1)
  70     (assert (not (thread-alive-p thread)))))
  71
  72 ;;; GET-MUTEX should not be interruptible under WITHOUT-INTERRUPTS
  73
  74 (with-test (:name without-interrupts+get-mutex :skipped-on '(not :sb-thread))
  75   (let* ((lock (make-mutex))
  76          (bar (progn (get-mutex lock) nil))
  77          (thread (make-thread (lambda ()
  78                                 (sb-sys:without-interrupts
  79                                     (with-mutex (lock)
  80                                       (setf bar t)))))))
  81     (sleep 1)
  82     (assert (thread-alive-p thread))
  83     (terminate-thread thread)
  84     (sleep 1)
  85     (assert (thread-alive-p thread))
  86     (release-mutex lock)
  87     (sleep 1)
  88     (assert (not (thread-alive-p thread)))
  89     (assert (eq :aborted (join-thread thread :default :aborted)))
  90     (assert bar)))
  91
  92 (with-test (:name parallel-find-class :skipped-on '(not :sb-thread))
  93   (let* ((oops nil)
  94          (threads (loop repeat 10
  95                         collect (make-thread (lambda ()
  96                                                (handler-case
  97                                                    (loop repeat 10000
  98                                                          do (find-class (gensym) nil))
  99                                                  (serious-condition ()
 100                                                    (setf oops t))))))))
 101     (mapcar #'sb-thread:join-thread threads)
 102     (assert (not oops))))
 103
 104 (with-test (:name :semaphore-multiple-waiters :skipped-on '(not :sb-thread))
 105   (let ((semaphore (make-semaphore :name "test sem")))
 106     (labels ((make-readers (n i)
 107                (values
 108                 (loop for r from 0 below n
 109                       collect
 110                       (sb-thread:make-thread
 111                        (lambda ()
 112                          (let ((sem semaphore))
 113                            (dotimes (s i)
 114                              (sb-thread:wait-on-semaphore sem))))
 115                        :name "reader"))
 116                 (* n i)))
 117              (make-writers (n readers i)
 118                (let ((j (* readers i)))
 119                  (multiple-value-bind (k rem) (truncate j n)
 120                    (values
 121                     (let ((writers
 122                            (loop for w from 0 below n
 123                                  collect
 124                                  (sb-thread:make-thread
 125                                   (lambda ()
 126                                     (let ((sem semaphore))
 127                                       (dotimes (s k)
 128                                         (sb-thread:signal-semaphore sem))))
 129                                   :name "writer"))))
 130                       (assert (zerop rem))
 131                       writers)
 132                     (+ rem (* n k))))))
 133              (test (r w n)
 134                (multiple-value-bind (readers x) (make-readers r n)
 135                  (assert (= (length readers) r))
 136                  (multiple-value-bind (writers y) (make-writers w r n)
 137                    (assert (= (length writers) w))
 138                    (assert (= x y))
 139                    (mapc #'sb-thread:join-thread writers)
 140                    (mapc #'sb-thread:join-thread readers)
 141                    (assert (zerop (sb-thread:semaphore-count semaphore)))
 142                    (values)))))
 143       (assert
 144        (eq :ok
 145            (handler-case
 146                (sb-ext:with-timeout 10
 147                  (test 1 1 100)
 148                  (test 2 2 10000)
 149                  (test 4 2 10000)
 150                  (test 4 2 10000)
 151                  (test 10 10 10000)
 152                  (test 10 1 10000)
 153                  :ok)
 154              (sb-ext:timeout ()
 155                :timeout)))))))
 156
 157 ;;;; Printing waitqueues
 158
 159 (with-test (:name :waitqueue-circle-print :skipped-on '(not :sb-thread))
 160   (let* ((*print-circle* nil)
 161          (lock (sb-thread:make-mutex))
 162          (wq (sb-thread:make-waitqueue)))
 163     (sb-thread:with-recursive-lock (lock)
 164       (sb-thread:condition-notify wq))
 165     ;; Used to blow stack due to recursive structure.
 166     (assert (princ-to-string wq))))
 167
 168 ;;;; SYMBOL-VALUE-IN-THREAD
 169
 170 (with-test (:name symbol-value-in-thread.1)
 171   (let ((* (cons t t)))
 172     (assert (eq * (symbol-value-in-thread '* *current-thread*)))
 173     (setf (symbol-value-in-thread '* *current-thread*) 123)
 174     (assert (= 123 (symbol-value-in-thread '* *current-thread*)))
 175     (assert (= 123 *))))
 176
 177 (with-test (:name symbol-value-in-thread.2 :skipped-on '(not :sb-thread))
 178   (let* ((parent *current-thread*)
 179          (semaphore (make-semaphore))
 180          (child (make-thread (lambda ()
 181                                (wait-on-semaphore semaphore)
 182                                (let ((old (symbol-value-in-thread 'this-is-new parent)))
 183                                  (setf (symbol-value-in-thread 'this-is-new parent) :from-child)
 184                                  old)))))
 185     (progv '(this-is-new) '(42)
 186       (signal-semaphore semaphore)
 187       (assert (= 42 (join-thread child)))
 188       (assert (eq :from-child (symbol-value 'this-is-new))))))
 189
 190 ;;; Disabled on Darwin due to deadlocks caused by apparent OS specific deadlocks,
 191 ;;; wich _appear_ to be caused by malloc() and free() not being thread safe: an
 192 ;;; interrupted malloc in one thread can apparently block a free in another. There
 193 ;;; are also some indications that pthread_mutex_lock is not re-entrant.
 194 (with-test (:name symbol-value-in-thread.3 :skipped-on '(not :sb-thread) :broken-on :darwin)
 195   (let* ((parent *current-thread*)
 196          (semaphore (make-semaphore))
 197          (running t)
 198          (noise (make-thread (lambda ()
 199                                (loop while running
 200                                      do (setf * (make-array 1024))
 201                                      ;; Busy-wait a bit so we don't TOTALLY flood the
 202                                      ;; system with GCs: a GC occurring in the middle of
 203                                      ;; S-V-I-T causes it to start over -- we want that
 204                                      ;; to occur occasionally, but not _all_ the time.
 205                                         (loop repeat (random 128)
 206                                               do (setf ** *)))))))
 207     (write-string "; ")
 208     (dotimes (i 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                       (sb-thread:with-mutex (ma)
 304                         (sb-thread:signal-semaphore sa)
 305                         (sb-thread:wait-on-semaphore sb)
 306                         (sb-thread:with-mutex (mb)
 307                           :ok))
 308                     (sb-thread:thread-deadlock (e)
 309                       (princ e)
 310                       :deadlock)))))
 311          (let* ((m1 (sb-thread:make-mutex :name "M1"))
 312                 (m2 (sb-thread:make-mutex :name "M2"))
 313                 (s1 (sb-thread:make-semaphore :name "S1"))
 314                 (s2 (sb-thread:make-semaphore :name "S2"))
 315                 (t1 (sb-thread:make-thread (test m1 m2 s1 s2) :name "T1"))
 316                 (t2 (sb-thread:make-thread (test m2 m1 s2 s1) :name "T2")))
 317            ;; One will deadlock, and the other will then complete normally.
 318            ;; ...except sometimes, when we get unlucky, and both will do
 319            ;; the deadlock detection in parallel and both signal.
 320            (let ((res (list (sb-thread:join-thread t1)
 321                             (sb-thread:join-thread t2))))
 322              (assert (or (equal '(:deadlock :ok) res)
 323                          (equal '(:ok :deadlock) res)
 324                          (equal '(:deadlock :deadlock) res))))))))
 325
 326 (with-test (:name deadlock-detection.2 :skipped-on '(not :sb-thread))
 327   (let* ((m1 (sb-thread:make-mutex :name "M1"))
 328          (m2 (sb-thread:make-mutex :name "M2"))
 329          (s1 (sb-thread:make-semaphore :name "S1"))
 330          (s2 (sb-thread:make-semaphore :name "S2"))
 331          (t1 (sb-thread:make-thread
 332               (lambda ()
 333                 (sb-thread:with-mutex (m1)
 334                   (sb-thread:signal-semaphore s1)
 335                   (sb-thread:wait-on-semaphore s2)
 336                   (sb-thread:with-mutex (m2)
 337                     :ok)))
 338               :name "T1")))
 339     (prog (err)
 340      :retry
 341        (handler-bind ((sb-thread:thread-deadlock
 342                        (lambda (e)
 343                          (unless err
 344                            ;; Make sure we can print the condition
 345                            ;; while it's active
 346                            (let ((*print-circle* nil))
 347                              (setf err (princ-to-string e)))
 348                            (go :retry)))))
 349          (when err
 350            (sleep 1))
 351          (assert (eq :ok (sb-thread:with-mutex (m2)
 352                            (unless err
 353                              (sb-thread:signal-semaphore s2)
 354                              (sb-thread:wait-on-semaphore s1)
 355                              (sleep 1))
 356                            (sb-thread:with-mutex (m1)
 357                              :ok)))))
 358        (assert (stringp err)))
 359     (assert (eq :ok (sb-thread:join-thread t1)))))
 360
 361 (with-test (:name deadlock-detection.3  :skipped-on '(not :sb-thread))
 362   (let* ((m1 (sb-thread:make-mutex :name "M1"))
 363          (m2 (sb-thread:make-mutex :name "M2"))
 364          (s1 (sb-thread:make-semaphore :name "S1"))
 365          (s2 (sb-thread:make-semaphore :name "S2"))
 366          (t1 (sb-thread:make-thread
 367               (lambda ()
 368                 (sb-thread:with-mutex (m1)
 369                   (sb-thread:signal-semaphore s1)
 370                   (sb-thread:wait-on-semaphore s2)
 371                   (sb-thread:with-mutex (m2)
 372                     :ok)))
 373               :name "T1")))
 374     ;; Currently we don't consider it a deadlock
 375     ;; if there is a timeout in the chain. No
 376     ;; Timeouts on lutex builds, though.
 377     (assert (eq #-sb-lutex :deadline
 378                 #+sb-lutex :deadlock
 379                 (handler-case
 380                     (sb-thread:with-mutex (m2)
 381                       (sb-thread:signal-semaphore s2)
 382                       (sb-thread:wait-on-semaphore s1)
 383                       (sleep 1)
 384                       (sb-sys:with-deadline (:seconds 0.1)
 385                         (sb-thread:with-mutex (m1)
 386                           :ok)))
 387                   (sb-sys:deadline-timeout ()
 388                     :deadline)
 389                   (sb-thread:thread-deadlock ()
 390                     :deadlock))))
 391     (assert (eq :ok (join-thread t1)))))
 392
 393 (with-test (:name deadlock-detection.4  :skipped-on '(not :sb-thread))
 394   (loop
 395     repeat 1000
 396     do (flet ((test (ma mb sa sb)
 397                 (lambda ()
 398                   (handler-case
 399                       (sb-thread::with-spinlock (ma)
 400                         (sb-thread:signal-semaphore sa)
 401                         (sb-thread:wait-on-semaphore sb)
 402                         (sb-thread::with-spinlock (mb)
 403                           :ok))
 404                     (sb-thread:thread-deadlock (e)
 405                       (princ e)
 406                       :deadlock)))))
 407          (let* ((m1 (sb-thread::make-spinlock :name "M1"))
 408                 (m2 (sb-thread::make-spinlock :name "M2"))
 409                 (s1 (sb-thread:make-semaphore :name "S1"))
 410                 (s2 (sb-thread:make-semaphore :name "S2"))
 411                 (t1 (sb-thread:make-thread (test m1 m2 s1 s2) :name "T1"))
 412                 (t2 (sb-thread:make-thread (test m2 m1 s2 s1) :name "T2")))
 413            ;; One will deadlock, and the other will then complete normally
 414            ;; ...except sometimes, when we get unlucky, and both will do
 415            ;; the deadlock detection in parallel and both signal.
 416            (let ((res (list (sb-thread:join-thread t1)
 417                             (sb-thread:join-thread t2))))
 418              (assert (or (equal '(:deadlock :ok) res)
 419                          (equal '(:ok :deadlock) res)
 420                          (equal '(:deadlock :deadlock) res))))))))
 421
 422 (with-test (:name deadlock-detection.5 :skipped-on '(not :sb-thread))
 423   (let* ((m1 (sb-thread::make-spinlock :name "M1"))
 424          (m2 (sb-thread::make-spinlock :name "M2"))
 425          (s1 (sb-thread:make-semaphore :name "S1"))
 426          (s2 (sb-thread:make-semaphore :name "S2"))
 427          (t1 (sb-thread:make-thread
 428               (lambda ()
 429                 (sb-thread::with-spinlock (m1)
 430                   (sb-thread:signal-semaphore s1)
 431                   (sb-thread:wait-on-semaphore s2)
 432                   (sb-thread::with-spinlock (m2)
 433                     :ok)))
 434               :name "T1")))
 435     (prog (err)
 436      :retry
 437        (handler-bind ((sb-thread:thread-deadlock
 438                        (lambda (e)
 439                          (unless err
 440                            ;; Make sure we can print the condition
 441                            ;; while it's active
 442                            (let ((*print-circle* nil))
 443                              (setf err (princ-to-string e)))
 444                            (go :retry)))))
 445          (when err
 446            (sleep 1))
 447          (assert (eq :ok (sb-thread::with-spinlock (m2)
 448                            (unless err
 449                              (sb-thread:signal-semaphore s2)
 450                              (sb-thread:wait-on-semaphore s1)
 451                              (sleep 1))
 452                            (sb-thread::with-spinlock (m1)
 453                              :ok)))))
 454        (assert (stringp err)))
 455     (assert (eq :ok (sb-thread:join-thread t1)))))
 456
 457 (with-test (:name deadlock-detection.7 :skipped-on '(not :sb-thread))
 458   (let* ((m1 (sb-thread::make-spinlock :name "M1"))
 459          (m2 (sb-thread::make-spinlock :name "M2"))
 460          (s1 (sb-thread:make-semaphore :name "S1"))
 461          (s2 (sb-thread:make-semaphore :name "S2"))
 462          (t1 (sb-thread:make-thread
 463               (lambda ()
 464                 (sb-thread::with-spinlock (m1)
 465                   (sb-thread:signal-semaphore s1)
 466                   (sb-thread:wait-on-semaphore s2)
 467                   (sb-thread::with-spinlock (m2)
 468                     :ok)))
 469               :name "T1")))
 470     (assert (eq :deadlock
 471                 (handler-case
 472                     (sb-thread::with-spinlock (m2)
 473                       (sb-thread:signal-semaphore s2)
 474                       (sb-thread:wait-on-semaphore s1)
 475                       (sleep 1)
 476                       (sb-sys:with-deadline (:seconds 0.1)
 477                         (sb-thread::with-spinlock (m1)
 478                           :ok)))
 479                   (sb-sys:deadline-timeout ()
 480                     :deadline)
 481                   (sb-thread:thread-deadlock ()
 482                     :deadlock))))
 483     (assert (eq :ok (join-thread t1)))))
 484
 485 #+sb-thread
 486 (with-test (:name :pass-arguments-to-thread)
 487   (assert (= 3 (join-thread (make-thread #'+ :arguments '(1 2))))))
 488
 489 #+sb-thread
 490 (with-test (:name :pass-atom-to-thread)
 491   (assert (= 1/2 (join-thread (make-thread #'/ :arguments 2)))))
 492
 493 #+sb-thread
 494 (with-test (:name :pass-nil-to-thread)
 495   (assert (= 1 (join-thread (make-thread #'* :arguments '())))))
 496
 497 #+sb-thread
 498 (with-test (:name :pass-nothing-to-thread)
 499   (assert (= 1 (join-thread (make-thread #'*)))))
 500
 501 #+sb-thread
 502 (with-test (:name :pass-improper-list-to-thread)
 503   (multiple-value-bind (value error)
 504       (ignore-errors (make-thread #'+ :arguments '(1 . 1)))
 505     (when value
 506       (join-thread value))
 507     (assert (and (null value)
 508                  error))))