test-suite/tests/threads.test

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