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 (use-package '("SB-EXT" "SB-THREAD"))
  15
  16 (with-test (:name :dont-print-array
  17             :skipped-on (not :sb-thread))
  18   (let ((thr (sb-thread:make-thread (lambda () (make-array 100)))))
  19     (sb-thread:join-thread thr)
  20     (assert (search "#<(SIMPLE-VECTOR" (write-to-string thr)))))
  21
  22 (with-test (:name atomic-update
  23             :skipped-on (not :sb-thread))
  24   (let ((x (cons :count 0))
  25         (nthreads (ecase sb-vm:n-word-bits (32 100) (64 1000))))
  26     (mapc #'join-thread
  27           (loop repeat nthreads
  28              collect (make-thread (lambda ()
  29                                     (loop repeat 1000
  30                                        do (atomic-update (cdr x) #'1+)
  31                                          (sleep 0.00001))))))
  32     (assert (equal x `(:count ,@(* 1000 nthreads))))))
  33
  34 (with-test (:name mutex-owner)
  35   ;; Make sure basics are sane on unithreaded ports as well
  36   (let ((mutex (make-mutex)))
  37     (grab-mutex mutex)
  38     (assert (eq *current-thread* (mutex-owner mutex)))
  39     (handler-bind ((warning #'error))
  40       (release-mutex mutex))
  41     (assert (not (mutex-owner mutex)))))
  42
  43 ;;; Terminating a thread that's waiting for the terminal.
  44
  45 (with-test (:name (:terminate-thread :get-foreground)
  46                   :skipped-on (not :sb-thread)
  47                   :broken-on :win32)
  48  (let ((thread (make-thread (lambda ()
  49                               (sb-thread::get-foreground)))))
  50    (sleep 1)
  51    (assert (thread-alive-p thread))
  52    (terminate-thread thread)
  53    (sleep 1)
  54    (assert (not (thread-alive-p thread)))))
  55
  56 ;;; Condition-wait should not be interruptible under WITHOUT-INTERRUPTS
  57 ;;; BUT: Such a claim is without much merit. Even if a wait is not "interrupted",
  58 ;;; the very definition of spurious wakeup is that return from the wait happens
  59 ;;; for ANY reason - users of condition variables must ALWAYS anticipate needing
  60 ;;; to loop over a condition-wait.
  61
  62 (with-test (:name :without-interrupts+condition-wait
  63             :skipped-on (not :sb-thread)
  64             :broken-on :win32)
  65   (let* ((lock (make-mutex))
  66          (queue (make-waitqueue))
  67          (actually-wakeup nil)
  68          (thread (make-thread (lambda ()
  69                                 (sb-sys:without-interrupts
  70                                   (with-mutex (lock)
  71                                     (loop
  72                                      (condition-wait queue lock)
  73                                      (if actually-wakeup (return)))))))))
  74     (sleep .25)
  75     (assert (thread-alive-p thread))
  76     ;; this is the supposed "interrupt that doesn't interrupt",
  77     ;; but it _is_ permitted to wake the condition variable.
  78     (terminate-thread thread)
  79     (sleep .5)
  80     (assert (thread-alive-p thread))
  81     (setq actually-wakeup t)
  82     (sb-thread:barrier (:write))
  83     (condition-notify queue)
  84     (sleep .25)
  85     (assert (not (thread-alive-p thread)))))
  86
  87 ;;; GRAB-MUTEX should not be interruptible under WITHOUT-INTERRUPTS
  88
  89 (with-test (:name :without-interrupts+grab-mutex
  90             :skipped-on (not :sb-thread)
  91             :broken-on :win32)
  92   (let* ((lock (make-mutex))
  93          (bar (progn (grab-mutex lock) nil))
  94          (thread (make-thread (lambda ()
  95                                 (sb-sys:without-interrupts
  96                                     (with-mutex (lock)
  97                                       (setf bar t)))))))
  98     (sleep 1)
  99     (assert (thread-alive-p thread))
 100     (terminate-thread thread)
 101     (sleep 1)
 102     (assert (thread-alive-p thread))
 103     (release-mutex lock)
 104     (sleep 1)
 105     (assert (not (thread-alive-p thread)))
 106     (assert (eq :aborted (join-thread thread :default :aborted)))
 107     (assert bar)))
 108
 109 (with-test (:name :parallel-find-class :skipped-on (not :sb-thread))
 110   (let* ((oops nil)
 111          (threads (loop repeat 10
 112                         collect (make-thread (lambda ()
 113                                                (handler-case
 114                                                    (loop repeat 10000
 115                                                          do (find-class (gensym) nil))
 116                                                  (serious-condition ()
 117                                                    (setf oops t))))))))
 118     (mapc #'join-thread threads)
 119     (assert (not oops))))
 120
 121 (with-test (:name :semaphore-multiple-waiters :skipped-on (or (not :sb-thread) :gc-stress))
 122   (let ((semaphore (make-semaphore :name "test sem")))
 123     (labels ((make-readers (n i)
 124                (values
 125                 (loop for r from 0 below n
 126                       collect
 127                       (make-thread
 128                        (lambda ()
 129                          (sb-ext:with-timeout 10
 130                            (let ((sem semaphore))
 131                              (dotimes (s i)
 132                                (wait-on-semaphore sem)))))
 133                        :name "reader"))
 134                 (* n i)))
 135              (make-writers (n readers i)
 136                (let ((j (* readers i)))
 137                  (multiple-value-bind (k rem) (truncate j n)
 138                    (values
 139                     (let ((writers
 140                            (loop for w from 0 below n
 141                                  collect
 142                                  (make-thread
 143                                   (lambda ()
 144                                     (sb-ext:with-timeout 10
 145                                       (let ((sem semaphore))
 146                                         (dotimes (s k)
 147                                           (signal-semaphore sem)))))
 148                                   :name "writer"))))
 149                       (assert (zerop rem))
 150                       writers)
 151                     (+ rem (* n k))))))
 152              (test (r w n)
 153                (multiple-value-bind (readers x) (make-readers r n)
 154                  (assert (= (length readers) r))
 155                  (multiple-value-bind (writers y) (make-writers w r n)
 156                    (assert (= (length writers) w))
 157                    (assert (= x y))
 158                    (mapc #'join-thread writers)
 159                    (mapc #'join-thread readers)
 160                    (assert (zerop (semaphore-count semaphore)))
 161                    (values)))))
 162       (assert
 163        (eq :ok
 164            (sb-ext:with-timeout 20
 165              (test 1 1 100)
 166              (test 2 2 10000)
 167              (test 4 2 10000)
 168              (test 4 2 10000)
 169              (test 10 10 10000)
 170              (test 10 1 10000)
 171              :ok))))))
 172
 173 ;;;; Printing waitqueues
 174
 175 (with-test (:name :waitqueue-circle-print :skipped-on (not :sb-thread))
 176   (let* ((*print-circle* nil)
 177          (lock (make-mutex))
 178          (wq (make-waitqueue)))
 179     (with-recursive-lock (lock)
 180       (condition-notify wq))
 181     ;; Used to blow stack due to recursive structure.
 182     (assert (princ-to-string wq))))
 183
 184 ;;;; SYMBOL-VALUE-IN-THREAD
 185
 186 (with-test (:name :symbol-value-in-thread.1)
 187   (let ((* (cons t t)))
 188     (assert (eq * (symbol-value-in-thread '* *current-thread*)))
 189     (setf (symbol-value-in-thread '* *current-thread*) 123)
 190     (assert (= 123 (symbol-value-in-thread '* *current-thread*)))
 191     (assert (= 123 *))))
 192
 193 (with-test (:name :symbol-value-in-thread.2 :skipped-on (not :sb-thread))
 194   (let* ((parent *current-thread*)
 195          (semaphore (make-semaphore))
 196          (child (make-thread (lambda ()
 197                                (wait-on-semaphore semaphore)
 198                                (let ((old (symbol-value-in-thread 'this-is-new parent)))
 199                                  (setf (symbol-value-in-thread 'this-is-new parent) :from-child)
 200                                  old)))))
 201     (progv '(this-is-new) '(42)
 202       (signal-semaphore semaphore)
 203       (assert (= 42 (join-thread child)))
 204       (assert (eq :from-child (symbol-value 'this-is-new))))))
 205
 206 (with-test (:name :symbol-value-in-thread.3
 207             :skipped-on (not :sb-thread)
 208             :broken-on :sb-safepoint)
 209   (let* ((parent *current-thread*)
 210          (semaphore (make-semaphore))
 211          (running t)
 212          (noise (make-thread (lambda ()
 213                                (loop while running
 214                                      do (setf * (make-array 1024))
 215                                      ;; Busy-wait a bit so we don't TOTALLY flood the
 216                                      ;; system with GCs.
 217                                         (loop repeat (random 128)
 218                                               do (setf ** *)))))))
 219     (dotimes (i 500)
 220       (let* ((mom-mark (cons t t))
 221              (kid-mark (cons t t))
 222              (child (make-thread
 223                      (lambda ()
 224                        (if (wait-on-semaphore semaphore :timeout 10)
 225                            (let ((old (symbol-value-in-thread 'this-is-new parent)))
 226                              (setf (symbol-value-in-thread 'this-is-new parent)
 227                                    (make-array 24 :initial-element kid-mark))
 228                              old)
 229                            :timeout)))))
 230         (progv '(this-is-new) (list (make-array 24 :initial-element mom-mark))
 231           (signal-semaphore semaphore)
 232           (assert (eq mom-mark (aref (join-thread child :timeout 10) 0)))
 233           (assert (eq kid-mark (aref (symbol-value 'this-is-new) 0))))))
 234     (setf running nil)
 235     (join-thread noise)))
 236
 237 (with-test (:name :symbol-value-in-thread.4 :skipped-on (not :sb-thread))
 238   (let* ((parent *current-thread*)
 239          (semaphore (make-semaphore))
 240          (child (make-thread (lambda ()
 241                                (wait-on-semaphore semaphore)
 242                                (symbol-value-in-thread 'this-is-new parent nil)))))
 243     (signal-semaphore semaphore)
 244     (assert (equal '(nil nil) (multiple-value-list (join-thread child))))))
 245
 246 (with-test (:name :symbol-value-in-thread.5 :skipped-on (not :sb-thread))
 247   (let* ((parent *current-thread*)
 248          (semaphore (make-semaphore))
 249          (child (make-thread (lambda ()
 250                                (wait-on-semaphore semaphore)
 251                                (handler-case
 252                                    (symbol-value-in-thread 'this-is-new parent)
 253                                  (symbol-value-in-thread-error (e)
 254                                    (list (thread-error-thread e)
 255                                          (cell-error-name e)
 256                                          (sb-thread::symbol-value-in-thread-error-info e))))))))
 257     (signal-semaphore semaphore)
 258     (assert (equal (list *current-thread* 'this-is-new (list :read :no-tls-value))
 259                    (join-thread child)))))
 260
 261 (with-test (:name :symbol-value-in-thread.6 :skipped-on (not :sb-thread))
 262   (let* ((parent *current-thread*)
 263          (semaphore (make-semaphore))
 264          (name (gensym))
 265          (child (make-thread (lambda ()
 266                                (wait-on-semaphore semaphore)
 267                                (handler-case
 268                                    (setf (symbol-value-in-thread name parent) t)
 269                                  (symbol-value-in-thread-error (e)
 270                                    (list (thread-error-thread e)
 271                                          (cell-error-name e)
 272                                          (sb-thread::symbol-value-in-thread-error-info e))))))))
 273     (signal-semaphore semaphore)
 274     (let ((res (join-thread child))
 275           (want (list *current-thread* name (list :write :no-tls-value))))
 276       (unless (equal res want)
 277         (error "wanted ~S, got ~S" want res)))))
 278
 279 (with-test (:name :symbol-value-in-thread.7 :skipped-on (not :sb-thread))
 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 (with-test (:name :symbol-value-in-thread.8 :skipped-on (not :sb-thread))
 294   (let ((child (make-thread (lambda ())))
 295         (error-occurred nil))
 296     (join-thread child)
 297     (handler-case
 298         (setf (symbol-value-in-thread 'this-is-new child) t)
 299       (symbol-value-in-thread-error (e)
 300         (setf error-occurred t)
 301         (assert (eq child (thread-error-thread e)))
 302         (assert (eq 'this-is-new (cell-error-name e)))
 303         (assert (equal (list :write :thread-dead)
 304                        (sb-thread::symbol-value-in-thread-error-info e)))))
 305     (assert error-occurred)))
 306
 307 #+sb-thread
 308 (with-test (:name :pass-arguments-to-thread)
 309   (assert (= 3 (join-thread (make-thread #'+ :arguments '(1 2))))))
 310
 311 #+sb-thread
 312 (with-test (:name :pass-atom-to-thread)
 313   (assert (= 1/2 (join-thread (make-thread #'/ :arguments 2)))))
 314
 315 #+sb-thread
 316 (with-test (:name :pass-nil-to-thread)
 317   (assert (= 1 (join-thread (make-thread #'* :arguments '())))))
 318
 319 #+sb-thread
 320 (with-test (:name :pass-nothing-to-thread)
 321   (assert (= 1 (join-thread (make-thread #'*)))))
 322
 323 #+sb-thread
 324 (with-test (:name :pass-improper-list-to-thread)
 325   (multiple-value-bind (value error)
 326       (ignore-errors (make-thread #'+ :arguments '(1 . 1)))
 327     (when value
 328       (join-thread value))
 329     (assert (and (null value)
 330                  error))))
 331
 332 (with-test (:name (:wait-for :deadline))
 333   (assert (eq :ok
 334               (sb-sys:with-deadline (:seconds 10)
 335                 (assert (not (sb-ext:wait-for nil :timeout 0.1)))
 336                 :ok)))
 337   (assert (eq :deadline
 338               (handler-case
 339                   (sb-sys:with-deadline (:seconds 0.1)
 340                     (sb-ext:wait-for nil :timeout 10)
 341                     (error "oops"))
 342                 (sb-sys:deadline-timeout () :deadline)))))
 343
 344 (with-test (:name (:condition-wait :timeout :one-thread)
 345                   :skipped-on :gc-stress)
 346   (let ((mutex (make-mutex))
 347         (waitqueue (make-waitqueue)))
 348     (assert (not (with-mutex (mutex)
 349                    (condition-wait waitqueue mutex :timeout 0.01))))))
 350
 351 (with-test (:name (:condition-wait :timeout :many-threads)
 352             :skipped-on (or (not :sb-thread) :gc-stress))
 353   (let* ((mutex (make-mutex))
 354          (waitqueue (make-waitqueue))
 355          (sem (make-semaphore))
 356          (data nil)
 357          (workers
 358            (loop repeat 100
 359                  collect (make-thread
 360                           (lambda ()
 361                             (wait-on-semaphore sem)
 362                             (block thread
 363                               (with-mutex (mutex)
 364                                 (loop until data
 365                                       do (or (condition-wait waitqueue mutex :timeout 0.01)
 366                                              (return-from thread nil)))
 367                                 (assert (eq t (pop data)))
 368                                 t)))))))
 369     (loop repeat 50
 370           do (with-mutex (mutex)
 371                (push t data)
 372                (condition-notify waitqueue)))
 373     (signal-semaphore sem 100)
 374     (let ((ok (count-if #'join-thread workers)))
 375       (unless (eql 50 ok)
 376         (error "Wanted 50, got ~S" ok)))))
 377
 378 (with-test (:name (wait-on-semaphore :timeout :one-thread))
 379   (let ((count 10)
 380         (semaphore (make-semaphore)))
 381     (signal-semaphore semaphore count)
 382     (let ((values (loop repeat 100
 383                      collect (wait-on-semaphore semaphore :timeout 0.001)))
 384           (expected (loop for i from 9 downto 0 collect i)))
 385       (assert (equal (remove nil values) expected)))))
 386
 387 (with-test (:name (wait-on-semaphore :timeout :many-threads)
 388             :skipped-on (not :sb-thread))
 389   (let* ((count 10)
 390          (semaphore (make-semaphore)))
 391     ;; Add 10 tokens right away.
 392     (signal-semaphore semaphore count)
 393     ;; 100 threads try to decrement the semaphore by 1.
 394     (let ((threads
 395            (loop repeat 100
 396               collect (make-thread
 397                        (lambda ()
 398                          (sleep (random 0.02))
 399                          (wait-on-semaphore semaphore :timeout 0.5))))))
 400       ;; Add 10 more tokens while threads may already be waiting and
 401       ;; decrementing.
 402       (loop repeat (floor count 2) do (signal-semaphore semaphore 2))
 403       ;; 20 threads should have been able to decrement the semaphore
 404       ;; and obtain an updated count.
 405       (let ((values (mapcar #'join-thread threads)))
 406         ;; 20 threads should succeed waiting for the semaphore.
 407         (assert (= (* 2 count) (count-if-not #'null values)))
 408         ;; The updated semaphore count should be in [0,19] at all
 409         ;; times.
 410         (assert (every (lambda (value) (<= 0 value (1- (* 2 count))))
 411                        (remove nil values)))
 412         ;; (At least) one thread should decrease the count to 0.
 413         (assert (find 0 values))))))
 414
 415 (with-test (:name (wait-on-semaphore semaphore-notification :lp-1038034)
 416             :skipped-on (not :sb-thread)
 417             :broken-on :sb-safepoint)
 418   ;; Test robustness of semaphore acquisition and notification with
 419   ;; asynchronous thread termination...  Which we know is currently
 420   ;; fragile.
 421   (dotimes (run 180)
 422     (let ((sem (make-semaphore)))
 423       ;; In CRITICAL, WAIT-ON-SEMAPHORE and SLEEP can be interrupted
 424       ;; by TERMINATE-THREAD below. But the SIGNAL-SEMAPHORE cleanup
 425       ;; cannot be interrupted.
 426       (flet ((critical (sleep)
 427                (let ((note (make-semaphore-notification)))
 428                  (sb-sys:without-interrupts
 429                      (unwind-protect
 430                           (sb-sys:with-local-interrupts
 431                             (wait-on-semaphore sem :notification note)
 432                             (sleep sleep))
 433                        ;; Re-increment on exit if we decremented it.
 434                        (when (semaphore-notification-status note)
 435                          (signal-semaphore sem)))))))
 436         ;; Create /parallel/ threads trying to acquire and then signal
 437         ;; the semaphore. Try to asynchronously abort T2 just as T1 is
 438         ;; exiting.
 439         (destructuring-bind (t1 t2 t3)
 440             (loop for i from 1
 441                for sleep in '(0.01 0.02 0.02)
 442                collect (make-thread #'critical :arguments sleep
 443                                     :name (format nil "T~A" i)))
 444           (signal-semaphore sem)
 445           (sleep 0.01)
 446           (ignore-errors
 447             (terminate-thread t2))
 448           (flet ((safe-join-thread (thread &key timeout)
 449                    (assert timeout)
 450                    (when (eq :timeout
 451                              (join-thread thread
 452                                           :timeout timeout
 453                                           :default :timeout))
 454                      (error "Hang in (join-thread ~A) ?" thread))))
 455             (safe-join-thread t1 :timeout 60)
 456             (safe-join-thread t3 :timeout 60)))))
 457     (when (zerop (mod run 60))
 458       (fresh-line)
 459       (write-string "; "))
 460     (write-char #\.)
 461     (force-output)))
 462
 463 (with-test (:name (wait-on-semaphore :n))
 464   (let ((semaphore (make-semaphore :count 3)))
 465     (assert (= 1 (wait-on-semaphore semaphore :n 2)))
 466     (assert (= 1 (semaphore-count semaphore)))))
 467
 468 (with-test (:name (try-semaphore semaphore-notification)
 469             :skipped-on (not :sb-thread))
 470   (let* ((sem (make-semaphore))
 471          (note (make-semaphore-notification)))
 472     (assert (eql nil (try-semaphore sem 1 note)))
 473     (assert (not (semaphore-notification-status note)))
 474     (signal-semaphore sem)
 475     (assert (eql 0 (try-semaphore sem 1 note)))
 476     (assert (semaphore-notification-status note))))
 477
 478 (with-test (:name (return-from-thread :normal-thread)
 479             :skipped-on (not :sb-thread))
 480   (let ((thread (make-thread (lambda ()
 481                                (return-from-thread (values 1 2 3))
 482                                :foo))))
 483     (assert (equal '(1 2 3) (multiple-value-list (join-thread thread))))))
 484
 485 (with-test (:name (return-from-thread :main-thread))
 486   (assert (main-thread-p))
 487   (assert-error (return-from-thread t) thread-error))
 488
 489 (with-test (:name (abort-thread :normal-thread)
 490             :skipped-on (not :sb-thread))
 491   (let ((thread (make-thread (lambda ()
 492                                (abort-thread)
 493                                :foo))))
 494     (assert (equal '(:aborted! :abort)
 495                    (multiple-value-list
 496                     (join-thread thread :default :aborted!))))))
 497
 498 (with-test (:name (abort-thread :main-thread))
 499   (assert (main-thread-p))
 500   (assert-error (abort-thread) thread-error))
 501
 502 ;;; The OSes vary in how pthread_setname works.
 503 ;;; According to https://stackoverflow.com/questions/2369738/how-to-set-the-name-of-a-thread-in-linux-pthreads
 504 ;;;   // NetBSD: name + arg work like printf(name, arg)
 505 ;;;   int pthread_setname_np(pthread_t thread, const char *name, void *arg);
 506 ;;;   // FreeBSD & OpenBSD: function name is slightly different, and has no return value
 507 ;;;   void pthread_set_name_np(pthread_t tid, const char *name);
 508 ;;;   // Mac OS X: must be set from within the thread (can't specify thread ID)
 509 ;;;   int pthread_setname_np(const char*);
 510 ;;; Only Linux is implemented for now.
 511 (with-test (:name :os-thread-name :skipped-on (:not (and :linux :sb-thread)))
 512   (let ((thr
 513          (make-thread
 514           (lambda ()
 515             (let ((all-names
 516                    (loop for filename in (directory "/proc/self/task/*/comm")
 517                          collect (with-open-file (stream filename) (read-line stream)))))
 518               (setf (thread-name *current-thread*) "newname")
 519               (with-open-file (stream (format nil "/proc/self/task/~d/comm"
 520                                               (thread-os-tid *current-thread*)))
 521                 (list (read-line stream) all-names))))
 522           :name "testme")))
 523     (let ((results (join-thread thr)))
 524       (assert (string= (first results) "newname"))
 525       (assert (find "finalizer" (second results) :test 'string=))
 526       (assert (find "testme" (second results) :test 'string=)))))