guile18/test-suite/tests/threads.test

   1 ;;;; threads.test --- Tests for Guile threading.    -*- scheme -*-
   2 ;;;;
   3 ;;;; Copyright 2003, 2006 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 (use-modules (ice-9 threads)
  21              (test-suite lib))
  22
  23 (if (provided? 'threads)
  24     (begin
  25
  26       (with-test-prefix "parallel"
  27         (pass-if "no forms"
  28           (call-with-values
  29               (lambda ()
  30                 (parallel))
  31             (lambda ()
  32               #t)))
  33
  34         (pass-if "1"
  35           (call-with-values
  36               (lambda ()
  37                 (parallel 1))
  38             (lambda (x)
  39               (equal? x 1))))
  40
  41         (pass-if "1 2"
  42           (call-with-values
  43               (lambda ()
  44                 (parallel 1 2))
  45             (lambda (x y)
  46               (and (equal? x 1)
  47                    (equal? y 2)))))
  48
  49         (pass-if "1 2 3"
  50           (call-with-values
  51               (lambda ()
  52                 (parallel 1 2 3))
  53             (lambda (x y z)
  54               (and (equal? x 1)
  55                    (equal? y 2)
  56                    (equal? z 3))))))
  57
  58       ;;
  59       ;; n-par-for-each
  60       ;;
  61
  62       (with-test-prefix "n-par-for-each"
  63
  64         (pass-if "0 in limit 10"
  65           (n-par-for-each 10 noop '())
  66           #t)
  67
  68         (pass-if "6 in limit 10"
  69           (let ((v (make-vector 6 #f)))
  70             (n-par-for-each 10 (lambda (n)
  71                                  (vector-set! v n #t))
  72                             '(0 1 2 3 4 5))
  73             (equal? v '#(#t #t #t #t #t #t))))
  74
  75         (pass-if "6 in limit 1"
  76           (let ((v (make-vector 6 #f)))
  77             (n-par-for-each 1 (lambda (n)
  78                                 (vector-set! v n #t))
  79                             '(0 1 2 3 4 5))
  80             (equal? v '#(#t #t #t #t #t #t))))
  81
  82         (pass-if "6 in limit 2"
  83           (let ((v (make-vector 6 #f)))
  84             (n-par-for-each 2 (lambda (n)
  85                                 (vector-set! v n #t))
  86                             '(0 1 2 3 4 5))
  87             (equal? v '#(#t #t #t #t #t #t))))
  88
  89         (pass-if "6 in limit 3"
  90           (let ((v (make-vector 6 #f)))
  91             (n-par-for-each 3 (lambda (n)
  92                                 (vector-set! v n #t))
  93                             '(0 1 2 3 4 5))
  94             (equal? v '#(#t #t #t #t #t #t)))))
  95
  96       ;;
  97       ;; n-for-each-par-map
  98       ;;
  99
 100       (with-test-prefix "n-for-each-par-map"
 101
 102         (pass-if "0 in limit 10"
 103           (n-for-each-par-map 10 noop noop '())
 104           #t)
 105
 106         (pass-if "6 in limit 10"
 107           (let ((result '()))
 108             (n-for-each-par-map 10
 109                                 (lambda (n) (set! result (cons n result)))
 110                                 (lambda (n) (* 2 n))
 111                                 '(0 1 2 3 4 5))
 112             (equal? result '(10 8 6 4 2 0))))
 113
 114         (pass-if "6 in limit 1"
 115           (let ((result '()))
 116             (n-for-each-par-map 1
 117                                 (lambda (n) (set! result (cons n result)))
 118                                 (lambda (n) (* 2 n))
 119                                 '(0 1 2 3 4 5))
 120             (equal? result '(10 8 6 4 2 0))))
 121
 122         (pass-if "6 in limit 2"
 123           (let ((result '()))
 124             (n-for-each-par-map 2
 125                                 (lambda (n) (set! result (cons n result)))
 126                                 (lambda (n) (* 2 n))
 127                                 '(0 1 2 3 4 5))
 128             (equal? result '(10 8 6 4 2 0))))
 129
 130         (pass-if "6 in limit 3"
 131           (let ((result '()))
 132             (n-for-each-par-map 3
 133                                 (lambda (n) (set! result (cons n result)))
 134                                 (lambda (n) (* 2 n))
 135                                 '(0 1 2 3 4 5))
 136             (equal? result '(10 8 6 4 2 0)))))
 137
 138       ;;
 139       ;; thread joining
 140       ;;
 141
 142       (with-test-prefix "joining"
 143
 144         ;; scm_join_thread has a SCM_TICK in the middle of it, to
 145         ;; allow asyncs to run (including signal delivery).  We used
 146         ;; to have a bug whereby if the joined thread terminated at
 147         ;; the same time as the joining thread is in this SCM_TICK,
 148         ;; scm_join_thread would not notice and would hang forever.
 149         ;; So in this test we are setting up the following sequence of
 150         ;; events.
 151         ;;   T=0  other thread is created and starts running
 152         ;;   T=2  main thread sets up an async that will sleep for 10 seconds
 153         ;;   T=2  main thread calls join-thread, which will...
 154         ;;   T=2  ...call the async, which starts sleeping
 155         ;;   T=5  other thread finishes its work and terminates
 156         ;;   T=7  async completes, main thread continues inside join-thread.
 157         (pass-if "don't hang when joined thread terminates in SCM_TICK"
 158           (let ((other-thread (make-thread sleep 5)))
 159             (letrec ((delay-count 10)
 160                      (aproc (lambda ()
 161                               (set! delay-count (- delay-count 1))
 162                               (if (zero? delay-count)
 163                                   (sleep 5)
 164                                   (system-async-mark aproc)))))
 165               (sleep 2)
 166               (system-async-mark aproc)
 167               (join-thread other-thread)))
 168           #t))))