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