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 #+sb-thread
  55 (with-test (:name without-interrupts+condition-wait
  56             :fails-on :sb-lutex)
  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 #+sb-thread
  75 (with-test (:name without-interrupts+get-mutex)
  76   (let* ((lock (make-mutex))
  77          (bar (progn (get-mutex lock) nil))
  78          (thread (make-thread (lambda ()
  79                                 (sb-sys:without-interrupts
  80                                     (with-mutex (lock)
  81                                       (setf bar t)))))))
  82     (sleep 1)
  83     (assert (thread-alive-p thread))
  84     (terminate-thread thread)
  85     (sleep 1)
  86     (assert (thread-alive-p thread))
  87     (release-mutex lock)
  88     (sleep 1)
  89     (assert (not (thread-alive-p thread)))
  90     (assert (eq :aborted (join-thread thread :default :aborted)))
  91     (assert bar)))
  92
  93 #+sb-thread
  94 (with-test (:name parallel-find-class)
  95   (let* ((oops nil)
  96          (threads (loop repeat 10
  97                         collect (make-thread (lambda ()
  98                                                (handler-case
  99                                                    (loop repeat 10000
 100                                                          do (find-class (gensym) nil))
 101                                                  (serious-condition ()
 102                                                    (setf oops t))))))))
 103     (mapcar #'sb-thread:join-thread threads)
 104     (assert (not oops))))
 105
 106 #+sb-thread
 107 (with-test (:name :semaphore-multiple-waiters)
 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                       (sb-thread:make-thread
 114                        (lambda ()
 115                          (let ((sem semaphore))
 116                            (dotimes (s i)
 117                              (sb-thread: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                                  (sb-thread:make-thread
 128                                   (lambda ()
 129                                     (let ((sem semaphore))
 130                                       (dotimes (s k)
 131                                         (sb-thread: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 #'sb-thread:join-thread writers)
 143                    (mapc #'sb-thread:join-thread readers)
 144                    (assert (zerop (sb-thread: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 #+sb-thread
 163 (with-test (:name :waitqueue-circle-print)
 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 #+sb-thread
 182 (with-test (:name symbol-value-in-thread.2)
 183   (let* ((parent *current-thread*)
 184          (semaphore (make-semaphore))
 185          (child (make-thread (lambda ()
 186                                (wait-on-semaphore semaphore)
 187                                (let ((old (symbol-value-in-thread 'this-is-new parent)))
 188                                  (setf (symbol-value-in-thread 'this-is-new parent) :from-child)
 189                                  old)))))
 190     (progv '(this-is-new) '(42)
 191       (signal-semaphore semaphore)
 192       (assert (= 42 (join-thread child)))
 193       (assert (eq :from-child (symbol-value 'this-is-new))))))
 194
 195 ;;; Disabled on Darwin due to deadlocks caused by apparent OS specific deadlocks,
 196 ;;; wich _appear_ to be caused by malloc() and free() not being thread safe: an
 197 ;;; interrupted malloc in one thread can apparently block a free in another. There
 198 ;;; are also some indications that pthread_mutex_lock is not re-entrant.
 199 #+(and sb-thread (not darwin))
 200 (with-test (:name symbol-value-in-thread.3)
 201   (let* ((parent *current-thread*)
 202          (semaphore (make-semaphore))
 203          (running t)
 204          (noise (make-thread (lambda ()
 205                                (loop while running
 206                                      do (setf * (make-array 1024))
 207                                      ;; Busy-wait a bit so we don't TOTALLY flood the
 208                                      ;; system with GCs: a GC occurring in the middle of
 209                                      ;; S-V-I-T causes it to start over -- we want that
 210                                      ;; to occur occasionally, but not _all_ the time.
 211                                         (loop repeat (random 128)
 212                                               do (setf ** *)))))))
 213     (write-string "; ")
 214     (dotimes (i 15000)
 215       (when (zerop (mod i 200))
 216         (write-char #\.)
 217         (force-output))
 218       (let* ((mom-mark (cons t t))
 219              (kid-mark (cons t t))
 220              (child (make-thread (lambda ()
 221                                    (wait-on-semaphore semaphore)
 222                                    (let ((old (symbol-value-in-thread 'this-is-new parent)))
 223                                      (setf (symbol-value-in-thread 'this-is-new parent)
 224                                            (make-array 24 :initial-element kid-mark))
 225                                      old)))))
 226         (progv '(this-is-new) (list (make-array 24 :initial-element mom-mark))
 227           (signal-semaphore semaphore)
 228           (assert (eq mom-mark (aref (join-thread child) 0)))
 229           (assert (eq kid-mark (aref (symbol-value 'this-is-new) 0))))))
 230     (setf running nil)
 231     (join-thread noise)))
 232
 233 #+sb-thread
 234 (with-test (:name symbol-value-in-thread.4)
 235   (let* ((parent *current-thread*)
 236          (semaphore (make-semaphore))
 237          (child (make-thread (lambda ()
 238                                (wait-on-semaphore semaphore)
 239                                (symbol-value-in-thread 'this-is-new parent nil)))))
 240     (signal-semaphore semaphore)
 241     (assert (equal '(nil nil) (multiple-value-list (join-thread child))))))
 242
 243 #+sb-thread
 244 (with-test (:name symbol-value-in-thread.5)
 245   (let* ((parent *current-thread*)
 246          (semaphore (make-semaphore))
 247          (child (make-thread (lambda ()
 248                                (wait-on-semaphore semaphore)
 249                                (handler-case
 250                                    (symbol-value-in-thread 'this-is-new parent)
 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     (assert (equal (list *current-thread* 'this-is-new (list :read :unbound-in-thread))
 257                    (join-thread child)))))
 258
 259 #+sb-thread
 260 (with-test (:name symbol-value-in-thread.6)
 261   (let* ((parent *current-thread*)
 262          (semaphore (make-semaphore))
 263          (name (gensym))
 264          (child (make-thread (lambda ()
 265                                (wait-on-semaphore semaphore)
 266                                (handler-case
 267                                    (setf (symbol-value-in-thread name parent) t)
 268                                  (symbol-value-in-thread-error (e)
 269                                    (list (thread-error-thread e)
 270                                          (cell-error-name e)
 271                                          (sb-thread::symbol-value-in-thread-error-info e))))))))
 272     (signal-semaphore semaphore)
 273     (let ((res (join-thread child))
 274           (want (list *current-thread* name (list :write :no-tls-value))))
 275       (unless (equal res want)
 276         (error "wanted ~S, got ~S" want res)))))
 277
 278 #+sb-thread
 279 (with-test (:name symbol-value-in-thread.7)
 280   (let ((child (make-thread (lambda ())))
 281         (error-occurred nil))
 282     (join-thread child)
 283     (handler-case
 284         (symbol-value-in-thread 'this-is-new child)
 285       (symbol-value-in-thread-error (e)
 286         (setf error-occurred t)
 287         (assert (eq child (thread-error-thread e)))
 288         (assert (eq 'this-is-new (cell-error-name e)))
 289         (assert (equal (list :read :thread-dead)
 290                        (sb-thread::symbol-value-in-thread-error-info e)))))
 291     (assert error-occurred)))
 292
 293 #+sb-thread
 294 (with-test (:name symbol-value-in-thread.8)
 295   (let ((child (make-thread (lambda ())))
 296         (error-occurred nil))
 297     (join-thread child)
 298     (handler-case
 299         (setf (symbol-value-in-thread 'this-is-new child) t)
 300       (symbol-value-in-thread-error (e)
 301         (setf error-occurred t)
 302         (assert (eq child (thread-error-thread e)))
 303         (assert (eq 'this-is-new (cell-error-name e)))
 304         (assert (equal (list :write :thread-dead)
 305                        (sb-thread::symbol-value-in-thread-error-info e)))))
 306     (assert error-occurred)))
 307
 308 #+sb-thread
 309 (with-test (:name deadlock-detection.1)
 310   (loop
 311     repeat 1000
 312     do (flet ((test (ma mb sa sb)
 313                 (lambda ()
 314                   (handler-case
 315                       (sb-thread:with-mutex (ma)
 316                         (sb-thread:signal-semaphore sa)
 317                         (sb-thread:wait-on-semaphore sb)
 318                         (sb-thread:with-mutex (mb)
 319                           :ok))
 320                     (sb-thread:thread-deadlock (e)
 321                       (princ e)
 322                       :deadlock)))))
 323          (let* ((m1 (sb-thread:make-mutex :name "M1"))
 324                 (m2 (sb-thread:make-mutex :name "M2"))
 325                 (s1 (sb-thread:make-semaphore :name "S1"))
 326                 (s2 (sb-thread:make-semaphore :name "S2"))
 327                 (t1 (sb-thread:make-thread (test m1 m2 s1 s2) :name "T1"))
 328                 (t2 (sb-thread:make-thread (test m2 m1 s2 s1) :name "T2")))
 329            ;; One will deadlock, and the other will then complete normally.
 330            ;; ...except sometimes, when we get unlucky, and both will do
 331            ;; the deadlock detection in parallel and both signal.
 332            (let ((res (list (sb-thread:join-thread t1)
 333                             (sb-thread:join-thread t2))))
 334              (assert (or (equal '(:deadlock :ok) res)
 335                          (equal '(:ok :deadlock) res)
 336                          (equal '(:deadlock :deadlock) res))))))))
 337
 338 #+sb-thread
 339 (with-test (:name deadlock-detection.2)
 340   (let* ((m1 (sb-thread:make-mutex :name "M1"))
 341          (m2 (sb-thread:make-mutex :name "M2"))
 342          (s1 (sb-thread:make-semaphore :name "S1"))
 343          (s2 (sb-thread:make-semaphore :name "S2"))
 344          (t1 (sb-thread:make-thread
 345               (lambda ()
 346                 (sb-thread:with-mutex (m1)
 347                   (sb-thread:signal-semaphore s1)
 348                   (sb-thread:wait-on-semaphore s2)
 349                   (sb-thread:with-mutex (m2)
 350                     :ok)))
 351               :name "T1")))
 352     (prog (err)
 353      :retry
 354        (handler-bind ((sb-thread:thread-deadlock
 355                        (lambda (e)
 356                          (unless err
 357                            ;; Make sure we can print the condition
 358                            ;; while it's active
 359                            (let ((*print-circle* nil))
 360                              (setf err (princ-to-string e)))
 361                            (go :retry)))))
 362          (when err
 363            (sleep 1))
 364          (assert (eq :ok (sb-thread:with-mutex (m2)
 365                            (unless err
 366                              (sb-thread:signal-semaphore s2)
 367                              (sb-thread:wait-on-semaphore s1)
 368                              (sleep 1))
 369                            (sb-thread:with-mutex (m1)
 370                              :ok)))))
 371        (assert (stringp err)))
 372     (assert (eq :ok (sb-thread:join-thread t1)))))
 373
 374 #+sb-thread
 375 (with-test (:name deadlock-detection.3)
 376   (let* ((m1 (sb-thread:make-mutex :name "M1"))
 377          (m2 (sb-thread:make-mutex :name "M2"))
 378          (s1 (sb-thread:make-semaphore :name "S1"))
 379          (s2 (sb-thread:make-semaphore :name "S2"))
 380          (t1 (sb-thread:make-thread
 381               (lambda ()
 382                 (sb-thread:with-mutex (m1)
 383                   (sb-thread:signal-semaphore s1)
 384                   (sb-thread:wait-on-semaphore s2)
 385                   (sb-thread:with-mutex (m2)
 386                     :ok)))
 387               :name "T1")))
 388     ;; Currently we don't consider it a deadlock
 389     ;; if there is a timeout in the chain. No
 390     ;; Timeouts on lutex builds, though.
 391     (assert (eq #-sb-lutex :deadline
 392                 #+sb-lutex :deadlock
 393                 (handler-case
 394                     (sb-thread:with-mutex (m2)
 395                       (sb-thread:signal-semaphore s2)
 396                       (sb-thread:wait-on-semaphore s1)
 397                       (sleep 1)
 398                       (sb-sys:with-deadline (:seconds 0.1)
 399                         (sb-thread:with-mutex (m1)
 400                           :ok)))
 401                   (sb-sys:deadline-timeout ()
 402                     :deadline)
 403                   (sb-thread:thread-deadlock ()
 404                     :deadlock))))
 405     (assert (eq :ok (join-thread t1)))))
 406
 407 #+sb-thread
 408 (with-test (:name deadlock-detection.4)
 409   (loop
 410     repeat 1000
 411     do (flet ((test (ma mb sa sb)
 412                 (lambda ()
 413                   (handler-case
 414                       (sb-thread::with-spinlock (ma)
 415                         (sb-thread:signal-semaphore sa)
 416                         (sb-thread:wait-on-semaphore sb)
 417                         (sb-thread::with-spinlock (mb)
 418                           :ok))
 419                     (sb-thread:thread-deadlock (e)
 420                       (princ e)
 421                       :deadlock)))))
 422          (let* ((m1 (sb-thread::make-spinlock :name "M1"))
 423                 (m2 (sb-thread::make-spinlock :name "M2"))
 424                 (s1 (sb-thread:make-semaphore :name "S1"))
 425                 (s2 (sb-thread:make-semaphore :name "S2"))
 426                 (t1 (sb-thread:make-thread (test m1 m2 s1 s2) :name "T1"))
 427                 (t2 (sb-thread:make-thread (test m2 m1 s2 s1) :name "T2")))
 428            ;; One will deadlock, and the other will then complete normally
 429            ;; ...except sometimes, when we get unlucky, and both will do
 430            ;; the deadlock detection in parallel and both signal.
 431            (let ((res (list (sb-thread:join-thread t1)
 432                             (sb-thread:join-thread t2))))
 433              (assert (or (equal '(:deadlock :ok) res)
 434                          (equal '(:ok :deadlock) res)
 435                          (equal '(:deadlock :deadlock) res))))))))
 436
 437 #+sb-thread
 438 (with-test (:name deadlock-detection.5)
 439   (let* ((m1 (sb-thread::make-spinlock :name "M1"))
 440          (m2 (sb-thread::make-spinlock :name "M2"))
 441          (s1 (sb-thread:make-semaphore :name "S1"))
 442          (s2 (sb-thread:make-semaphore :name "S2"))
 443          (t1 (sb-thread:make-thread
 444               (lambda ()
 445                 (sb-thread::with-spinlock (m1)
 446                   (sb-thread:signal-semaphore s1)
 447                   (sb-thread:wait-on-semaphore s2)
 448                   (sb-thread::with-spinlock (m2)
 449                     :ok)))
 450               :name "T1")))
 451     (prog (err)
 452      :retry
 453        (handler-bind ((sb-thread:thread-deadlock
 454                        (lambda (e)
 455                          (unless err
 456                            ;; Make sure we can print the condition
 457                            ;; while it's active
 458                            (let ((*print-circle* nil))
 459                              (setf err (princ-to-string e)))
 460                            (go :retry)))))
 461          (when err
 462            (sleep 1))
 463          (assert (eq :ok (sb-thread::with-spinlock (m2)
 464                            (unless err
 465                              (sb-thread:signal-semaphore s2)
 466                              (sb-thread:wait-on-semaphore s1)
 467                              (sleep 1))
 468                            (sb-thread::with-spinlock (m1)
 469                              :ok)))))
 470        (assert (stringp err)))
 471     (assert (eq :ok (sb-thread:join-thread t1)))))
 472
 473 #+sb-thread
 474 (with-test (:name deadlock-detection.7)
 475   (let* ((m1 (sb-thread::make-spinlock :name "M1"))
 476          (m2 (sb-thread::make-spinlock :name "M2"))
 477          (s1 (sb-thread:make-semaphore :name "S1"))
 478          (s2 (sb-thread:make-semaphore :name "S2"))
 479          (t1 (sb-thread:make-thread
 480               (lambda ()
 481                 (sb-thread::with-spinlock (m1)
 482                   (sb-thread:signal-semaphore s1)
 483                   (sb-thread:wait-on-semaphore s2)
 484                   (sb-thread::with-spinlock (m2)
 485                     :ok)))
 486               :name "T1")))
 487     (assert (eq :deadlock
 488                 (handler-case
 489                     (sb-thread::with-spinlock (m2)
 490                       (sb-thread:signal-semaphore s2)
 491                       (sb-thread:wait-on-semaphore s1)
 492                       (sleep 1)
 493                       (sb-sys:with-deadline (:seconds 0.1)
 494                         (sb-thread::with-spinlock (m1)
 495                           :ok)))
 496                   (sb-sys:deadline-timeout ()
 497                     :deadline)
 498                   (sb-thread:thread-deadlock ()
 499                     :deadlock))))
 500     (assert (eq :ok (join-thread t1)))))