test-suite/tests/threads.test

   1 ;;;; threads.test --- Tests for Guile threading.    -*- scheme -*-
   2 ;;;;
   3 ;;;; Copyright 2003, 2006, 2007, 2009 Free Software Foundation, Inc.
   4 ;;;;
   5 ;;;; This library is free software; you can redistribute it and/or
   6 ;;;; modify it under the terms of the GNU Lesser General Public
   7 ;;;; License as published by the Free Software Foundation; either
   8 ;;;; version 3 of the License, or (at your option) any later version.
   9 ;;;;
  10 ;;;; This library is distributed in the hope that it will be useful,
  11 ;;;; but WITHOUT ANY WARRANTY; without even the implied warranty of
  12 ;;;; MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE.  See the GNU
  13 ;;;; Lesser General Public License for more details.
  14 ;;;;
  15 ;;;; You should have received a copy of the GNU Lesser General Public
  16 ;;;; License along with this library; if not, write to the Free Software
  17 ;;;; Foundation, Inc., 51 Franklin Street, Fifth Floor, Boston, MA 02110-1301 USA
  18
  19 (define-module (test-threads)
  20   :use-module (ice-9 threads)
  21   :use-module (test-suite lib))
  22
  23 (define (asyncs-still-working?)
  24   (let ((a #f))
  25     (system-async-mark (lambda ()
  26                          (set! a #t)))
  27     ;; The point of the following (equal? ...) is to go through
  28     ;; primitive code (scm_equal_p) that includes a SCM_TICK call and
  29     ;; hence gives system asyncs a chance to run.  Of course the
  30     ;; evaluator (eval.i.c) also calls SCM_TICK regularly, but in the
  31     ;; near future we may be using the VM instead of the traditional
  32     ;; compiler, and then we will still want asyncs-still-working? to
  33     ;; work.  (The VM should probably have SCM_TICK calls too, but
  34     ;; let's not rely on that here.)
  35     (equal? '(a b c) '(a b c))
  36     a))
  37
  38 (if (provided? 'threads)
  39     (begin
  40
  41       (with-test-prefix "parallel"
  42         (pass-if "no forms"
  43           (call-with-values
  44               (lambda ()
  45                 (parallel))
  46             (lambda ()
  47               #t)))
  48
  49         (pass-if "1"
  50           (call-with-values
  51               (lambda ()
  52                 (parallel 1))
  53             (lambda (x)
  54               (equal? x 1))))
  55
  56         (pass-if "1 2"
  57           (call-with-values
  58               (lambda ()
  59                 (parallel 1 2))
  60             (lambda (x y)
  61               (and (equal? x 1)
  62                    (equal? y 2)))))
  63
  64         (pass-if "1 2 3"
  65           (call-with-values
  66               (lambda ()
  67                 (parallel 1 2 3))
  68             (lambda (x y z)
  69               (and (equal? x 1)
  70                    (equal? y 2)
  71                    (equal? z 3))))))
  72
  73       ;;
  74       ;; n-par-for-each
  75       ;;
  76
  77       (with-test-prefix "n-par-for-each"
  78
  79         (pass-if "0 in limit 10"
  80           (n-par-for-each 10 noop '())
  81           #t)
  82
  83         (pass-if "6 in limit 10"
  84           (let ((v (make-vector 6 #f)))
  85             (n-par-for-each 10 (lambda (n)
  86                                  (vector-set! v n #t))
  87                             '(0 1 2 3 4 5))
  88             (equal? v '#(#t #t #t #t #t #t))))
  89
  90         (pass-if "6 in limit 1"
  91           (let ((v (make-vector 6 #f)))
  92             (n-par-for-each 1 (lambda (n)
  93                                 (vector-set! v n #t))
  94                             '(0 1 2 3 4 5))
  95             (equal? v '#(#t #t #t #t #t #t))))
  96
  97         (pass-if "6 in limit 2"
  98           (let ((v (make-vector 6 #f)))
  99             (n-par-for-each 2 (lambda (n)
 100                                 (vector-set! v n #t))
 101                             '(0 1 2 3 4 5))
 102             (equal? v '#(#t #t #t #t #t #t))))
 103
 104         (pass-if "6 in limit 3"
 105           (let ((v (make-vector 6 #f)))
 106             (n-par-for-each 3 (lambda (n)
 107                                 (vector-set! v n #t))
 108                             '(0 1 2 3 4 5))
 109             (equal? v '#(#t #t #t #t #t #t)))))
 110
 111       ;;
 112       ;; n-for-each-par-map
 113       ;;
 114
 115       (with-test-prefix "n-for-each-par-map"
 116
 117         (pass-if "asyncs are still working 2"
 118           (asyncs-still-working?))
 119
 120         (pass-if "0 in limit 10"
 121           (n-for-each-par-map 10 noop noop '())
 122           #t)
 123
 124         (pass-if "6 in limit 10"
 125           (let ((result '()))
 126             (n-for-each-par-map 10
 127                                 (lambda (n) (set! result (cons n result)))
 128                                 (lambda (n) (* 2 n))
 129                                 '(0 1 2 3 4 5))
 130             (equal? result '(10 8 6 4 2 0))))
 131
 132         (pass-if "6 in limit 1"
 133           (let ((result '()))
 134             (n-for-each-par-map 1
 135                                 (lambda (n) (set! result (cons n result)))
 136                                 (lambda (n) (* 2 n))
 137                                 '(0 1 2 3 4 5))
 138             (equal? result '(10 8 6 4 2 0))))
 139
 140         (pass-if "6 in limit 2"
 141           (let ((result '()))
 142             (n-for-each-par-map 2
 143                                 (lambda (n) (set! result (cons n result)))
 144                                 (lambda (n) (* 2 n))
 145                                 '(0 1 2 3 4 5))
 146             (equal? result '(10 8 6 4 2 0))))
 147
 148         (pass-if "6 in limit 3"
 149           (let ((result '()))
 150             (n-for-each-par-map 3
 151                                 (lambda (n) (set! result (cons n result)))
 152                                 (lambda (n) (* 2 n))
 153                                 '(0 1 2 3 4 5))
 154             (equal? result '(10 8 6 4 2 0)))))
 155
 156       ;;
 157       ;; timed mutex locking
 158       ;;
 159
 160       (with-test-prefix "lock-mutex"
 161
 162         (pass-if "asyncs are still working 3"
 163           (asyncs-still-working?))
 164
 165         (pass-if "timed locking fails if timeout exceeded"
 166           (let ((m (make-mutex)))
 167             (lock-mutex m)
 168             (let ((t (begin-thread (lock-mutex m (+ (current-time) 1)))))
 169               (not (join-thread t)))))
 170
 171         (pass-if "asyncs are still working 6"
 172           (asyncs-still-working?))
 173
 174         (pass-if "timed locking succeeds if mutex unlocked within timeout"
 175           (let* ((m (make-mutex))
 176                  (c (make-condition-variable))
 177                  (cm (make-mutex)))
 178             (lock-mutex cm)
 179             (let ((t (begin-thread (begin (lock-mutex cm)
 180                                           (signal-condition-variable c)
 181                                           (unlock-mutex cm)
 182                                           (lock-mutex m
 183                                                       (+ (current-time) 2))))))
 184               (lock-mutex m)
 185               (wait-condition-variable c cm)
 186               (unlock-mutex cm)
 187               (sleep 1)
 188               (unlock-mutex m)
 189               (join-thread t))))
 190
 191         (pass-if "asyncs are still working 7"
 192           (asyncs-still-working?))
 193
 194         )
 195
 196       ;;
 197       ;; timed mutex unlocking
 198       ;;
 199
 200       (with-test-prefix "unlock-mutex"
 201
 202         (pass-if "asyncs are still working 5"
 203           (asyncs-still-working?))
 204
 205         (pass-if "timed unlocking returns #f if timeout exceeded"
 206           (let ((m (make-mutex))
 207                 (c (make-condition-variable)))
 208             (lock-mutex m)
 209             (not (unlock-mutex m c (current-time)))))
 210
 211         (pass-if "asyncs are still working 4"
 212           (asyncs-still-working?))
 213
 214         (pass-if "timed unlocking returns #t if condition signaled"
 215           (let ((m1 (make-mutex))
 216                 (m2 (make-mutex))
 217                 (c1 (make-condition-variable))
 218                 (c2 (make-condition-variable)))
 219             (lock-mutex m1)
 220             (let ((t (begin-thread (begin (lock-mutex m1)
 221                                           (signal-condition-variable c1)
 222                                           (lock-mutex m2)
 223                                           (unlock-mutex m1)
 224                                           (unlock-mutex m2
 225                                                         c2
 226                                                         (+ (current-time)
 227                                                            2))))))
 228               (wait-condition-variable c1 m1)
 229               (unlock-mutex m1)
 230               (lock-mutex m2)
 231               (signal-condition-variable c2)
 232               (unlock-mutex m2)
 233               (join-thread t)))))
 234
 235       ;;
 236       ;; timed joining
 237       ;;
 238
 239       (with-test-prefix "join-thread"
 240
 241         (pass-if "timed joining fails if timeout exceeded"
 242           (let* ((m (make-mutex))
 243                  (c (make-condition-variable))
 244                  (t (begin-thread (begin (lock-mutex m)
 245                                          (wait-condition-variable c m))))
 246                  (r (join-thread t (current-time))))
 247             (cancel-thread t)
 248             (not r)))
 249
 250         (pass-if "join-thread returns timeoutval on timeout"
 251           (let* ((m (make-mutex))
 252                  (c (make-condition-variable))
 253                  (t (begin-thread (begin (lock-mutex m)
 254                                          (wait-condition-variable c m))))
 255                  (r (join-thread t (current-time) 'foo)))
 256             (cancel-thread t)
 257             (eq? r 'foo)))
 258
 259
 260         (pass-if "timed joining succeeds if thread exits within timeout"
 261           (let ((t (begin-thread (begin (sleep 1) #t))))
 262             (join-thread t (+ (current-time) 2))))
 263
 264         (pass-if "asyncs are still working 1"
 265           (asyncs-still-working?))
 266
 267         ;; scm_join_thread_timed has a SCM_TICK in the middle of it,
 268         ;; to allow asyncs to run (including signal delivery).  We
 269         ;; used to have a bug whereby if the joined thread terminated
 270         ;; at the same time as the joining thread is in this SCM_TICK,
 271         ;; scm_join_thread_timed would not notice and would hang
 272         ;; forever.  So in this test we are setting up the following
 273         ;; sequence of events.
 274         ;;   T=0  other thread is created and starts running
 275         ;;   T=2  main thread sets up an async that will sleep for 10 seconds
 276         ;;   T=2  main thread calls join-thread, which will...
 277         ;;   T=2  ...call the async, which starts sleeping
 278         ;;   T=5  other thread finishes its work and terminates
 279         ;;   T=7  async completes, main thread continues inside join-thread.
 280         (pass-if "don't hang when joined thread terminates in SCM_TICK"
 281           (let ((other-thread (make-thread sleep 5)))
 282             (letrec ((delay-count 10)
 283                      (aproc (lambda ()
 284                               (set! delay-count (- delay-count 1))
 285                               (if (zero? delay-count)
 286                                   (sleep 5)
 287                                   (system-async-mark aproc)))))
 288               (sleep 2)
 289               (system-async-mark aproc)
 290               (join-thread other-thread)))
 291           #t))
 292
 293       ;;
 294       ;; thread cancellation
 295       ;;
 296
 297       (with-test-prefix "cancel-thread"
 298
 299         (pass-if "cancel succeeds"
 300           (let ((m (make-mutex)))
 301             (lock-mutex m)
 302             (let ((t (begin-thread (begin (lock-mutex m) 'foo))))
 303               (cancel-thread t)
 304               (join-thread t)
 305               #t)))
 306
 307         (pass-if "handler result passed to join"
 308           (let ((m (make-mutex)))
 309             (lock-mutex m)
 310             (let ((t (begin-thread (lock-mutex m))))
 311               (set-thread-cleanup! t (lambda () 'foo))
 312               (cancel-thread t)
 313               (eq? (join-thread t) 'foo))))
 314
 315         (pass-if "can cancel self"
 316           (let ((m (make-mutex)))
 317             (lock-mutex m)
 318             (let ((t (begin-thread (begin
 319                                      (set-thread-cleanup! (current-thread)
 320                                                           (lambda () 'foo))
 321                                      (cancel-thread (current-thread))
 322                                      (lock-mutex m)))))
 323               (eq? (join-thread t) 'foo))))
 324
 325         (pass-if "handler supplants final expr"
 326           (let ((t (begin-thread (begin (set-thread-cleanup! (current-thread)
 327                                                              (lambda () 'bar))
 328                                         'foo))))
 329             (eq? (join-thread t) 'bar)))
 330
 331         (pass-if "remove handler by setting false"
 332           (let ((m (make-mutex)))
 333             (lock-mutex m)
 334             (let ((t (begin-thread (lock-mutex m) 'bar)))
 335               (set-thread-cleanup! t (lambda () 'foo))
 336               (set-thread-cleanup! t #f)
 337               (unlock-mutex m)
 338               (eq? (join-thread t) 'bar))))
 339
 340         (pass-if "initial handler is false"
 341           (not (thread-cleanup (current-thread)))))
 342
 343       ;;
 344       ;; mutex ownership
 345       ;;
 346
 347       (with-test-prefix "mutex-ownership"
 348         (pass-if "mutex ownership for locked mutex"
 349           (let ((m (make-mutex)))
 350             (lock-mutex m)
 351             (eq? (mutex-owner m) (current-thread))))
 352
 353         (pass-if "mutex ownership for unlocked mutex"
 354           (let ((m (make-mutex)))
 355             (not (mutex-owner m))))
 356
 357         (pass-if "locking mutex on behalf of other thread"
 358           (let* ((m (make-mutex))
 359                  (t (begin-thread 'foo)))
 360             (lock-mutex m #f t)
 361             (eq? (mutex-owner m) t)))
 362
 363         (pass-if "locking mutex with no owner"
 364           (let ((m (make-mutex)))
 365             (lock-mutex m #f #f)
 366             (not (mutex-owner m))))
 367
 368         (pass-if "mutex with owner not retained (bug #27450)"
 369           (let ((g (make-guardian)))
 370             (g (let ((m (make-mutex))) (lock-mutex m) m))
 371
 372             ;; Avoid false references to M on the stack.
 373             (let cleanup ((i 20))
 374               (and (> i 0)
 375                    (begin (cleanup (1- i)) i)))
 376
 377             (gc) (gc)
 378             (let ((m (g)))
 379               (and (mutex? m)
 380                    (eq? (mutex-owner m) (current-thread)))))))
 381
 382       ;;
 383       ;; mutex lock levels
 384       ;;
 385
 386       (with-test-prefix "mutex-lock-levels"
 387
 388         (pass-if "unlocked level is 0"
 389           (let ((m (make-mutex)))
 390             (and (not (mutex-locked? m)) (eqv? (mutex-level m) 0))))
 391
 392         (pass-if "non-recursive lock level is 1"
 393           (let ((m (make-mutex)))
 394             (lock-mutex m)
 395             (and (mutex-locked? m) (eqv? (mutex-level m) 1))))
 396
 397         (pass-if "recursive lock level is >1"
 398           (let ((m (make-mutex 'recursive)))
 399             (lock-mutex m)
 400             (lock-mutex m)
 401             (and (mutex-locked? m) (eqv? (mutex-level m) 2)))))
 402
 403       ;;
 404       ;; mutex behavior
 405       ;;
 406
 407       (with-test-prefix "mutex-behavior"
 408
 409         (pass-if "unchecked unlock"
 410           (let* ((m (make-mutex 'unchecked-unlock)))
 411             (unlock-mutex m)))
 412
 413         (pass-if "allow external unlock"
 414           (let* ((m (make-mutex 'allow-external-unlock))
 415                  (t (begin-thread (lock-mutex m))))
 416             (join-thread t)
 417             (unlock-mutex m)))
 418
 419         (pass-if "recursive mutexes"
 420           (let* ((m (make-mutex 'recursive)))
 421             (lock-mutex m)
 422             (lock-mutex m)))
 423
 424         (pass-if "locking abandoned mutex throws exception"
 425           (let* ((m (make-mutex))
 426                  (t (begin-thread (lock-mutex m)))
 427                  (success #f))
 428             (join-thread t)
 429             (catch 'abandoned-mutex-error
 430                    (lambda () (lock-mutex m))
 431                    (lambda key (set! success #t)))
 432             success)))))