1;;
2;; Test for threads
3;;
4
5(use gauche.test)
6(use gauche.sequence)
7(use gauche.time)
8(use srfi-19)
9(add-load-path ".")
10
11(test-start "threads")
12
13(use gauche.threads)
14(test-module 'gauche.threads)
15
16(cond-expand
17 [(not gauche.sys.threads)
18  (format #t "thread not supported\n")
19  (test-end)
20  (exit 0)]
21 [else])
22
23;;---------------------------------------------------------------------
24(test-section "basic thread API")
25
26(test* "current-thread" #t
27       (eq? (current-thread) (current-thread)))
28(test* "thread?" '(#t #f)
29       (list (thread? (current-thread))
30             (thread? 'foo)))
31(test* "make-thread" #t
32       (thread? (make-thread (^[] #f))))
33(test* "thread-name" 'foo
34       (thread-name (make-thread (^[] #f) 'foo)))
35(test* "thread-specific" "hello"
36       (begin
37         (thread-specific-set! (current-thread) "hello")
38         (thread-specific (current-thread))))
39(test* "thread-start!" "hello"
40       (call-with-output-string
41         (^p (let1 t (thread-start! (make-thread (^[] (display "hello" p))))
42               (thread-join! t)))))
43
44;; calculate fibonacchi in awful way
45(define (mt-fib n)
46  (let1 threads (make-vector n)
47    (dotimes [i n]
48      (set! (ref threads i)
49            (make-thread
50             (case i
51               [(0) (^[] 1)]
52               [(1) (^[] 1)]
53               [else (^[] (+ (thread-join! (ref threads (- i 1)))
54                             (thread-join! (ref threads (- i 2)))))])
55             i)))
56    (dotimes [i n]
57      (thread-start! (ref threads (- n i 1))))
58    (thread-join! (ref threads (- n 1)))))
59(test* "thread-join!" 1346269 (mt-fib 31))
60
61(let ()
62  (define (thread-sleep-test x)
63    (test* (format "thread-sleep! ~s" x) #t
64           (let1 c (make <real-time-counter>)
65             (with-time-counter c (thread-sleep! x))
66             (> (time-counter-value c)
67                (- (if (is-a? x <time>)
68                     (time->seconds (time-difference (current-time) x))
69                     x)
70                   0.01)))))
71
72  (thread-sleep-test 0.02)
73  (thread-sleep-test 1/50)
74  (thread-sleep-test (add-duration (current-time)
75                                   (make-time time-duration #e2e7 0)))
76  )
77
78;; thread stop and cont
79(let1 t1 (make-thread (^[] (while #t (sys-nanosleep #e5e8))))
80  (test* "thread-status" 'new (thread-state t1))
81  (thread-start! t1)
82  (test* "thread-status" 'runnable (thread-state t1))
83  (thread-stop! t1)
84  (test* "thread-status" 'stopped (thread-state t1))
85  (thread-stop! t1) ; duplicate stop test
86  (test* "thread-status" 'stopped (thread-state t1))
87  (thread-cont! t1)
88  (test* "thread-status" 'runnable (thread-state t1))
89  (thread-terminate! t1)
90  (test* "thread-status" 'terminated
91         (guard (e [(<terminated-thread-exception> e)
92                    (thread-state t1)])
93           (thread-join! t1))))
94
95;; thread termination via stopRequest
96(let1 t1 (thread-start! (make-thread (^[] (let loop () (loop))))) ; busy loop
97  (test* "thread termination via stopRequest" 'terminated
98         (guard (e [(<terminated-thread-exception> e)
99                    (thread-state t1)])
100           (thread-terminate! t1)
101           (thread-join! t1))))
102
103;; this SEGVs on 0.9.3.3. test code from @cryks.
104(test* "thread termination before running" 'terminated
105       (let1 t1 (make-thread (^[] #f))
106         (thread-terminate! t1)
107         (thread-state t1)))
108
109(test* "thread termination while being stopped" 'terminated
110       (let1 t1 (thread-start! (make-thread (^[] (let loop () (loop)))))
111         (thread-stop! t1)
112         (thread-terminate! t1)
113         (thread-state t1)))
114
115;;---------------------------------------------------------------------
116(test-section "thread and error")
117
118(test* "uncaught-exception" #t
119       (let1 t (make-thread (^[] (error "foo")))
120         (thread-start! t)
121         (with-error-handler
122             (^e (and (uncaught-exception? e)
123                      (is-a? (uncaught-exception-reason e) <error>)))
124           (^[] (thread-join! t)))))
125
126(test* "uncaught-exception" #t
127       (let1 t (make-thread (^[] (raise 4)))
128         (thread-start! t)
129         (with-error-handler
130             (^e (and (uncaught-exception? e)
131                      (eqv? (uncaught-exception-reason e) 4)))
132           (^[] (thread-join! t)))))
133
134(test* "uncaught-exception" #t
135       (let1 t (make-thread (^[] (with-error-handler identity
136                                   (^[] (error "foo")))))
137         (thread-start! t)
138         (with-error-handler identity
139           (^[] (is-a? (thread-join! t) <error>)))))
140
141;;---------------------------------------------------------------------
142(test-section "basic mutex API")
143
144(test* "make-mutex" #t (mutex? (make-mutex)))
145(test* "mutex-name" 'foo (mutex-name (make-mutex 'foo)))
146
147(test* "mutex-specific" "hoge"
148       (let1 m (make-mutex 'bar)
149         (mutex-specific-set! m "hoge")
150         (mutex-specific m)))
151
152(test* "lock and unlock - no blocking" #t
153       (let1 m (make-mutex)
154         (mutex-lock! m)
155         (mutex-unlock! m)))
156
157(test* "mutex-state"
158       (list 'not-abandoned (current-thread) 'not-owned 'not-abandoned)
159       (let ([m (make-mutex)]
160             [r '()])
161         (push! r (mutex-state m))
162         (mutex-lock! m)
163         (push! r (mutex-state m))
164         (mutex-unlock! m)
165         (mutex-lock! m #f #f)
166         (push! r (mutex-state m))
167         (mutex-unlock! m)
168         (push! r (mutex-state m))
169         (reverse r)))
170
171;; This test uses simple-minded spin lock, without using mutex timeouts
172;; nor condition variables.   Not recommended way for real code.
173(test* "lock and unlock - blocking (simple spin-lock)"
174       '((put a) (get a) (put b) (get b) (put c) (get c))
175       (let ([log '()]
176             [cell #f]
177             [m (make-mutex)])
178         (define (put! msg)
179           (mutex-lock! m)
180           (if cell
181             (begin (mutex-unlock! m) (put! msg))
182             (begin (set! cell msg)
183                    (push! log `(put ,msg))
184                    (mutex-unlock! m))))
185         (define (get!)
186           (mutex-lock! m)
187           (if cell
188             (rlet1 r cell
189               (set! cell #f)
190               (push! log `(get ,r))
191               (mutex-unlock! m))
192             (begin (mutex-unlock! m) (get!))))
193         (define (producer)
194           (put! 'a)
195           (put! 'b)
196           (put! 'c))
197         (define (consumer)
198           (get!)
199           (get!)
200           (get!))
201         (let ([tp (thread-start! (make-thread producer 'producer))]
202               [tc (thread-start! (make-thread consumer 'consumer))])
203           (thread-join! tp)
204           (thread-join! tc)
205           (reverse log))))
206
207(test* "lock with timeout"
208      '(#t #f #f #f #f #t #t)
209      (let1 m (make-mutex)
210        (let* ([r0 (mutex-lock! m)]
211               [r1 (mutex-lock! m 0)]
212               [r2 (mutex-lock! m 0.05)]
213               [r3 (mutex-lock! m (seconds->time (+ (time->seconds (current-time)) 0.05)))]
214               [r4 (mutex-lock! m (seconds->time (- (time->seconds (current-time)) 0.05)))]
215               [r5 (mutex-unlock! m)]
216               [r6 (mutex-lock! m 0)])
217          (mutex-unlock! m)
218          (list r0 r1 r2 r3 r4 r5 r6))))
219
220;; recursive mutex code taken from an example in SRFI-18
221(test "recursive mutex"
222      (list (current-thread) 0 'not-abandoned)
223      (^[]
224        (define (mutex-lock-recursively! mutex)
225          (if (eq? (mutex-state mutex) (current-thread))
226            (let1 n (mutex-specific mutex)
227              (mutex-specific-set! mutex (+ n 1)))
228            (begin
229              (mutex-lock! mutex)
230              (mutex-specific-set! mutex 0))))
231        (define (mutex-unlock-recursively! mutex)
232          (let1 n (mutex-specific mutex)
233            (if (= n 0)
234              (mutex-unlock! mutex)
235              (mutex-specific-set! mutex (- n 1)))))
236        (let1 m (make-mutex)
237          (mutex-specific-set! m 0)
238          (mutex-lock-recursively! m)
239          (mutex-lock-recursively! m)
240          (mutex-lock-recursively! m)
241          (let1 r0 (mutex-state m)
242            (mutex-unlock-recursively! m)
243            (mutex-unlock-recursively! m)
244            (let1 r1 (mutex-specific m)
245              (mutex-unlock-recursively! m)
246              (list r0 r1 (mutex-state m)))))
247        ))
248
249;;---------------------------------------------------------------------
250(test-section "condition variables")
251
252(test* "make-condition-variable" #t
253       (condition-variable? (make-condition-variable)))
254
255(test* "condition-variable-name" 'foo
256       (condition-variable-name (make-condition-variable 'foo)))
257
258(test* "condition-variable-specific" "hello"
259       (let1 c (make-condition-variable 'foo)
260         (condition-variable-specific-set! c "hello")
261         (condition-variable-specific c)))
262
263;; Producer-consumer model using condition variable.
264(test* "condition-variable-signal!"
265       '((put a) (get a) (put b) (get b) (put c) (get c))
266       (let ([log '()]
267             [cell #f]
268             [m  (make-mutex)]
269             [put-cv (make-condition-variable)]
270             [get-cv (make-condition-variable)])
271         (define (put! msg)
272           (mutex-lock! m)
273           (if cell
274             (begin (mutex-unlock! m put-cv) (put! msg))
275             (begin (set! cell msg)
276                    (push! log `(put ,msg))
277                    (condition-variable-signal! get-cv)
278                    (mutex-unlock! m))))
279         (define (get!)
280           (mutex-lock! m)
281           (if cell
282             (rlet1 r cell
283               (set! cell #f)
284               (push! log `(get ,r))
285               (condition-variable-signal! put-cv)
286               (mutex-unlock! m))
287             (begin
288               (mutex-unlock! m get-cv) (get!))))
289         (define (producer)
290           (put! 'a)
291           (put! 'b)
292           (put! 'c))
293         (define (consumer)
294           (get!)
295           (get!)
296           (get!))
297         (let ([tp (thread-start! (make-thread producer 'producer))]
298               [tc (thread-start! (make-thread consumer 'consumer))])
299           (thread-join! tp)
300           (thread-join! tc)
301           (reverse log))))
302
303;;---------------------------------------------------------------------
304(test-section "port access serialization")
305
306(use srfi-1)
307
308(define (port-test-chunk-generator nchars c)
309  (^[] (make-string nchars c)))
310
311(define (port-test-read-string nchars port)
312  (let loop ([i 1] [c (read-char port)] [r '()])
313    (cond [(eof-object? c)
314           (if (null? r) c (list->string (reverse r)))]
315          [(= i nchars) (list->string (reverse (cons c r)))]
316          [else (loop (+ i 1) (read-char port) (cons c r))])))
317
318(define (port-test-testers nchars nthread nrepeat line?)
319  (let* ([strgen (map (^i ($ port-test-chunk-generator nchars
320                             $ integer->char (+ (char->integer #\a) i)))
321                      (iota nthread))]
322         [generators (map (^[gen]
323                            (let ((i 0))
324                              (^[] (if (= i nrepeat)
325                                     #f
326                                     (begin
327                                       (inc! i)
328                                       (if line?
329                                         (string-append (gen) "\n")
330                                         (gen)))))))
331                          strgen)]
332         [getter (if line?
333                   read-line
334                   (cut port-test-read-string nchars <>))]
335         [confirmer  (^[inp]
336                       (let1 strs (map (cut <>) strgen)
337                         (let loop ([chunk (getter inp)])
338                           (cond [(eof-object? chunk) #t]
339                                 [(member chunk strs) (loop (getter inp))]
340                                 [else #f]))))])
341    (values confirmer generators)))
342
343(define (port-test-kick-threads generators outp)
344  (let* ([thunks  (map (^[gen] (^[] (let loop ([s (gen)])
345                                      (when s
346                                        (display s outp)
347                                        (thread-sleep! 0.001)
348                                        (loop (gen))))))
349                       generators)]
350         [threads (map make-thread thunks)])
351    (for-each thread-start! threads)
352    (for-each thread-join! threads)))
353
354(sys-system "rm -rf test.out")
355
356(test* "write to file, buffered" #t
357       (receive (confirmer generators)
358           (port-test-testers 160 8 20 #f)
359         (call-with-output-file "test.out"
360           (^[outp] (port-test-kick-threads generators outp)))
361         (call-with-input-file "test.out" confirmer)))
362
363(sys-system "rm -rf test.out")
364
365(test* "write to file, line-buffered" #t
366       (receive (confirmer generators)
367           (port-test-testers 160 8 20 #t)
368         (call-with-output-file "test.out"
369           (^[outp] (port-test-kick-threads generators outp))
370           :buffering :line)
371         (call-with-input-file "test.out" confirmer)))
372
373
374(sys-system "rm -rf test.out")
375
376(test* "write to string" #t
377       (receive (confirmer generators)
378           (port-test-testers 160 8 20 #f)
379         (let1 s (call-with-output-string
380                   (^[outp] (port-test-kick-threads generators outp)))
381           (call-with-input-string s confirmer))))
382
383;; Check if port is properly unlocked when an error is signalled
384;; inside the port processing routine.
385
386(define *port-test-error* #f)
387
388(define (make-error-test-port outp flush?)
389  (open-output-buffered-port
390   (^[str]
391     (cond [(not str) (flush outp)]
392           [(string-scan str "Z" 'before)
393            => (^s (display s outp)
394                   (if flush? (flush outp))
395                   (unless *port-test-error*
396                     (set! *port-test-error* #t)
397                     (error "error")))]
398           [else (display str outp) (if flush? (flush outp))]))
399   5))
400
401(define (port-test-on-error port use-flush?)
402  (set! *port-test-error* #f)
403  (let* ([p   (make-error-test-port port use-flush?)]
404         [th1 (make-thread
405               (^[] (with-error-handler (^e #f)
406                      (^[] (display "aaaaaAAAZAa" p))))
407               'th1)]
408         [th2 (make-thread
409               (^[] (display "bbbbbbbb" p))
410               'th2)])
411    (thread-start! th1)
412    (thread-join! th1)
413    (thread-start! th2)
414    (thread-join! th2)
415    (close-output-port p)))
416
417(test* "check if port is unlocked on error" "aaaaaAAAAAAbbbbbbbb"
418       (call-with-output-string (cut port-test-on-error <> #f)))
419(test* "check if port is unlocked on error" "aaaaaAAAAAAbbbbbbbb"
420       (call-with-output-string (cut port-test-on-error <> #t)))
421
422(sys-system "rm -f test.out")
423(test* "check if port is unlocked on error (use file)" "aaaaaAAAAAAbbbbbbbb"
424       (begin
425         (call-with-output-file "test.out"
426           (cut port-test-on-error <> #f))
427         (call-with-input-file "test.out" port->string)))
428
429(sys-system "rm -f test.out")
430(test* "check if port is unlocked on error (use file)" "aaaaaAAAAAAbbbbbbbb"
431       (begin
432         (call-with-output-file "test.out"
433           (cut port-test-on-error <> #t))
434         (call-with-input-file "test.out" port->string)))
435
436;;---------------------------------------------------------------------
437;(test-section "thread and signal")
438
439;(test "catching signal by primordial thread" (make-list 10 'int)
440
441;;---------------------------------------------------------------------
442(test-section "thread-local parameters")
443
444(define *thr1-val* #f)
445(define *thr2-val* #f)
446
447(define p (make-parameter 3))
448
449(test* "check locality of parameters" '(3 4 5)
450       (let ([th1 (make-thread (^[] (p 4) (set! *thr1-val* (p))))]
451             [th2 (make-thread (^[] (p 5) (set! *thr2-val* (p))))])
452         (thread-start! th1)
453         (thread-start! th2)
454         (thread-join! th1)
455         (thread-join! th2)
456         (list (p) *thr1-val* *thr2-val*)))
457
458;; Parameters that are created in a different thread
459;; We used to prohibit accessing parameters that are created by different
460;; threads (up to 0.9.2).  But it caused annoyance when a module creating
461;; parameters is loaded after some threads are already started.
462
463(test* "parameters created by different thread" '(2 1 3)
464       (let ([p #f]
465             [handshake #f]
466             [val1 #f]
467             [val2 #f]
468             [val3 #f])
469         (let ([th1 (make-thread (^[]
470                                   (set! p (make-parameter 1))
471                                   (p 2)
472                                   (until handshake (sys-nanosleep 10000))
473                                   (set! val1 (p))))]
474               [th2 (make-thread (^[]
475                                   (until p (sys-nanosleep 10000))
476                                   (set! val2 (p))))]
477               [th3 (make-thread (^[]
478                                   (until p (sys-nanosleep 10000))
479                                   (p 3)
480                                   (set! handshake #t)
481                                   (set! val3 (p))))])
482           (thread-start! th1)
483           (thread-start! th2)
484           (thread-start! th3)
485           (thread-join! th1)
486           (thread-join! th2)
487           (thread-join! th3)
488           (list val1 val2 val3))))
489
490;;---------------------------------------------------------------------
491(test-section "atoms")
492
493(test* "atom" #t (atom? (atom 0 1 2)))
494
495(test* "atomic counting" 300
496       (let ([a (atom 0)] [ts '()])
497         (dotimes [n 30]
498           (push! ts
499                  (thread-start! (make-thread
500                                  (^[] (dotimes [m 10]
501                                         (atomic-update! a (pa$ + 1))))))))
502         (for-each thread-join! ts)
503         (atom-ref a)))
504
505(test* "atomic-update! extra values" '(2 3 4)
506       (let ([a (atom 1 2)])
507         (values->list
508          (atomic-update! a
509                          (^[x y] (values (+ x 1) (+ y 1) (+ x y 1)))))))
510
511;;---------------------------------------------------------------------
512(test-section "threads and promise")
513
514(use srfi-1)
515
516(letrec ([x 0]
517         [z (delay (begin (sys-nanosleep 100000) (inc! x) 'ok))])
518  (test* "concurrent forcing" 1
519         (let ([ts (map (^_ (make-thread (^[] (force z)))) (iota 10))])
520           (for-each thread-start! ts)
521           (for-each thread-join! ts)
522           x)))
523
524(letrec ([count 0]
525         [x 5]
526         [z (delay (begin (set! count (+ count 1))
527                          (if (> count x)
528                            count
529                            (force p))))])
530  (test* "concurrent forcing w/ recursive force" 1
531         (let ([ts (map (^_ (make-thread (^[] (force z)))) (iota 10))])
532           (for-each thread-start! ts)
533           (for-each thread-join! ts)
534           count)))
535
536;;---------------------------------------------------------------------
537(test-section "threads and lazy sequences")
538
539(let1 k 0
540  (define (weird-generator)
541    (inc! k)
542    (case k
543      [(1) 0]
544      [(2) (sys-nanosleep #e1e7) (raise "boo")]
545      [(3) 1]
546      [else (eof-object)]))
547  (define (task seq)
548    (guard (e [else e])
549      (let1 k (length seq) seq)))
550  (let* ([seq (generator->lseq weird-generator)]
551         [t0  (make-thread (^[] (task seq)))]
552         [t1  (make-thread (^[] (task seq)))])
553    (test* "accessing the same lazy sequence"
554           (test-one-of '("boo" (0 1)) '((0 1) "boo"))
555           (begin (thread-start! t0)
556                  (thread-start! t1)
557                  (list (thread-join! t0) (thread-join! t1))))))
558
559;;---------------------------------------------------------------------
560(test-section "synchrnization by queues")
561
562;; These are actually for testing mtqueue, but put here since they
563;; require threads to work.
564
565(use data.queue)
566
567(define (test-producer-consumer name qs ndata nthreads)
568  (define qr (make-mtqueue))
569  (define data (iota ndata))
570  (define (producer)
571    (dolist [n data] (enqueue/wait! qs n))
572    (dotimes [k nthreads] (enqueue/wait! qs #f)))
573  (define (consumer)
574    (let loop ([x (dequeue/wait! qs)])
575      (when x
576        (enqueue! qr x)
577        (sys-nanosleep #e1e7)
578        (loop (dequeue/wait! qs)))))
579
580  (test* #"synchronized queue ~name" data
581         (let* ([cs (map (^_ (thread-start! (make-thread consumer)))
582                         (iota nthreads))]
583                [p1 (make-thread producer)])
584           (sys-nanosleep #e1e8)
585           (thread-start! p1)
586           (for-each thread-join! cs)
587           (thread-join! p1)
588           (queue->list qr))
589         (cut lset= eqv? <> <>)))
590
591(test-producer-consumer "(unbound queue length)"
592                        (make-mtqueue)
593                        100 3)
594
595(test-producer-consumer "(bound queue length)"
596                        (make-mtqueue :max-length 5)
597                        100 3)
598
599(test-producer-consumer "(zero-length queue)"
600                        (make-mtqueue :max-length 0)
601                        100 3)
602
603(test* "dequeue/wait! timeout" "timed out!"
604       (dequeue/wait! (make-mtqueue) 0.01 "timed out!"))
605(test* "enqueue/wait! timeout" "timed out!"
606       (let1 q (make-mtqueue :max-length 1)
607         (enqueue! q 'a)
608         (enqueue/wait! q 'b 0.01 "timed out!")))
609(test* "queue-push/wait! timeout" "timed out!"
610       (let1 q (make-mtqueue :max-length 1)
611         (enqueue! q 'a)
612         (queue-push/wait! q 'b 0.01 "timed out!")))
613
614(test* "zero-length-queue handshaking" '(5 4 3 2 1 0)
615       (let ([r '()]
616             [q0 (make-mtqueue :max-length 0)]
617             [q1 (make-mtqueue :max-length 0)])
618         (let1 t (thread-start!
619                  (make-thread (^[]
620                                 (push! r 0)
621                                 (dequeue/wait! q0)
622                                 (enqueue/wait! q1 'b)
623                                 (push! r 2)
624                                 (dequeue/wait! q0)
625                                 (enqueue/wait! q1 'd)
626                                 (push! r 4)
627                                 (dequeue/wait! q0))))
628           (enqueue/wait! q0 'a)
629           (push! r 1)
630           (dequeue/wait! q1)
631           (enqueue/wait! q0 'c)
632           (push! r 3)
633           (dequeue/wait! q1)
634           (enqueue/wait! q0 'e)
635           (push! r 5))
636         r))
637
638(test* "zero-length-queue multiple reader" '(a a b b)
639       (let ([r0 #f] [r1 #f]
640             [q  (make-mtqueue :max-length 0)]
641             [qq (make-mtqueue :max-length 0)])
642         (let ([t0 (thread-start!
643                    (make-thread (^[] (enqueue/wait! qq #t)
644                                      (set! r0 (dequeue/wait! q))
645                                      (enqueue/wait! qq 'b))))]
646               [t1 (thread-start!
647                    (make-thread (^[] (enqueue/wait! qq #t)
648                                      (set! r1 (dequeue/wait! q))
649                                      (enqueue/wait! qq 'b))))])
650           (dequeue/wait! qq)
651           (dequeue/wait! qq)
652           (enqueue/wait! q 'a)
653           (enqueue/wait! q 'a)
654           (let1 r (list (dequeue/wait! qq) (dequeue/wait! qq))
655             (list* r0 r1 r)))))
656
657(test-end)
658
659