1190 lines
33 KiB
Scheme
1190 lines
33 KiB
Scheme
|
|
|
|
(load-relative "loadtest.ss")
|
|
|
|
(SECTION 'threads)
|
|
|
|
(define SLEEP-TIME 0.1)
|
|
|
|
;; ----------------------------------------
|
|
|
|
(define t (thread (lambda () 8)))
|
|
(test #t thread? t)
|
|
|
|
(arity-test thread 1 1)
|
|
(err/rt-test (thread 5) type?)
|
|
(err/rt-test (thread (lambda (x) 8)) type?)
|
|
(arity-test thread? 1 1)
|
|
|
|
;; ----------------------------------------
|
|
;; Thread sets
|
|
|
|
(define (test-set-balance as bs cs ds
|
|
sa sb sc sd
|
|
a% b% c% d%)
|
|
(let ([a (box 0)]
|
|
[b (box 0)]
|
|
[c (box 0)]
|
|
[d (box 0)]
|
|
[stop? #f])
|
|
|
|
(define (go box s s-amt)
|
|
(parameterize ([current-thread-group s])
|
|
(thread (lambda ()
|
|
(let loop ()
|
|
(set-box! box (add1 (unbox box)))
|
|
(sleep s-amt)
|
|
(unless stop?
|
|
(loop)))))))
|
|
|
|
(go a as sa)
|
|
(go b bs sb)
|
|
(go c cs sc)
|
|
(go d ds sd)
|
|
|
|
(sleep SLEEP-TIME)
|
|
|
|
(set! stop? #t)
|
|
|
|
(let ([va (/ (unbox a) a%)]
|
|
[vb (unbox b)]
|
|
[vc (unbox c)]
|
|
[vd (unbox d)])
|
|
(define (roughly= x y)
|
|
(<= (* (- x 1) 0.9) y (* (+ x 1) 1.1)))
|
|
|
|
(test #t roughly= vb (* b% va))
|
|
(test #t roughly= vc (* c% va))
|
|
(test #t roughly= vd (* d% va)))))
|
|
|
|
;; Simple test:
|
|
(let ([ts (make-thread-group)])
|
|
(test-set-balance (current-thread-group) ts ts ts
|
|
0 0 0 0
|
|
1 1/3 1/3 1/3))
|
|
|
|
;; Make two sets, should be balanced:
|
|
(let ([ts1 (make-thread-group)]
|
|
[ts2 (make-thread-group)])
|
|
(test-set-balance ts1 ts2 ts2 ts1
|
|
0 0 0 0
|
|
1 1 1 1))
|
|
|
|
;; Like first test, but with an explicit "root" set
|
|
(let* ([ts1 (make-thread-group)]
|
|
[ts2 (make-thread-group ts1)])
|
|
(test-set-balance ts1 ts2 ts2 ts2
|
|
0 0 0 0
|
|
1 1/3 1/3 1/3))
|
|
|
|
;; Like second test, but with an explicit "root" set
|
|
(let* ([ts0 (make-thread-group)]
|
|
[ts1 (make-thread-group ts0)]
|
|
[ts2 (make-thread-group ts0)])
|
|
(test-set-balance ts1 ts2 ts2 ts1
|
|
0 0 0 0
|
|
1 1 1 1))
|
|
|
|
;; Check that suspended threads don't break
|
|
;; scheduling. (The test really continues past this
|
|
;; one, since the threads don't die right away.)
|
|
(let* ([ts0 (make-thread-group)]
|
|
[ts1 (make-thread-group ts0)]
|
|
[ts2 (make-thread-group ts0)])
|
|
(test-set-balance ts1 ts2 ts2 ts1
|
|
0 0 (* SLEEP-TIME 10) (* SLEEP-TIME 10)
|
|
1 1 0 0))
|
|
|
|
(arity-test make-thread-group 0 1)
|
|
(err/rt-test (make-thread-group 5) type?)
|
|
(arity-test thread-group? 1 1)
|
|
(test #t thread-group? (make-thread-group))
|
|
(test #f thread-group? 5)
|
|
(arity-test current-thread-group 0 1)
|
|
(err/rt-test (current-thread-group 5))
|
|
|
|
;; ----------------------------------------
|
|
|
|
; Should be able to make an arbitrarily deep chain of custodians
|
|
; if only the first & last are accssible:
|
|
(test #t custodian?
|
|
(let loop ([n 1000][c (current-custodian)])
|
|
(if (zero? n)
|
|
c
|
|
(loop (sub1 n) (make-custodian c)))))
|
|
|
|
(define result 0)
|
|
(define th1 0)
|
|
(define set-ready
|
|
(let ([s (make-semaphore 1)]
|
|
[r #f])
|
|
(lambda (v)
|
|
(semaphore-wait s)
|
|
(begin0
|
|
r
|
|
(set! r v)
|
|
(semaphore-post s)))))
|
|
(define cm (make-custodian))
|
|
(define th2 (parameterize ([current-custodian cm])
|
|
(thread
|
|
(lambda ()
|
|
(let ([cm2 (make-custodian cm)])
|
|
(parameterize ([current-custodian cm2])
|
|
(set! th1 (thread
|
|
(lambda ()
|
|
(let loop ()
|
|
(let ([r (set-ready #f)])
|
|
(sleep SLEEP-TIME)
|
|
(set! result (add1 result))
|
|
(when r (semaphore-post r)))
|
|
(loop)))))))))))
|
|
(define start result)
|
|
(let ([r (make-semaphore)])
|
|
(set-ready r)
|
|
(semaphore-wait r))
|
|
(test #f eq? start result)
|
|
(kill-thread th2)
|
|
(set! start result)
|
|
(let ([r (make-semaphore)])
|
|
(set-ready r)
|
|
(semaphore-wait r))
|
|
(test #f eq? start result)
|
|
(test #t thread-running? th1)
|
|
(test #f thread-dead? th1)
|
|
(custodian-shutdown-all cm)
|
|
(thread-wait th1)
|
|
(set! start result)
|
|
(test #f thread-running? th1)
|
|
(test #t thread-dead? th1)
|
|
(sleep SLEEP-TIME)
|
|
(test #t eq? start result)
|
|
|
|
(let ([kept-going? #f])
|
|
(let ([c (make-custodian)])
|
|
(parameterize ([current-custodian c])
|
|
(thread-wait
|
|
(thread
|
|
(lambda ()
|
|
(custodian-shutdown-all c)
|
|
(set! kept-going? #t))))))
|
|
(test #f 'kept-going-after-shutdown? kept-going?))
|
|
|
|
(err/rt-test (parameterize ([current-custodian cm]) (kill-thread (current-thread)))
|
|
exn:application:mismatch?)
|
|
|
|
(test #t custodian? cm)
|
|
(test #f custodian? 1)
|
|
(arity-test custodian? 1 1)
|
|
|
|
(arity-test custodian-shutdown-all 1 1)
|
|
(err/rt-test (custodian-shutdown-all 0))
|
|
|
|
(arity-test make-custodian 0 1)
|
|
(err/rt-test (make-custodian 0))
|
|
|
|
(test (void) kill-thread t)
|
|
(arity-test kill-thread 1 1)
|
|
(err/rt-test (kill-thread 5) type?)
|
|
|
|
(arity-test break-thread 1 1)
|
|
(err/rt-test (break-thread 5) type?)
|
|
|
|
(arity-test thread-wait 1 1)
|
|
(err/rt-test (thread-wait 5) type?)
|
|
|
|
(test #t thread-running? (current-thread))
|
|
(arity-test thread-running? 1 1)
|
|
(err/rt-test (thread-running? 5) type?)
|
|
|
|
(test #f thread-dead? (current-thread))
|
|
(arity-test thread-dead? 1 1)
|
|
(err/rt-test (thread-dead? 5) type?)
|
|
|
|
(arity-test sleep 0 1)
|
|
(err/rt-test (sleep 'a) type?)
|
|
(err/rt-test (sleep 1+3i) type?)
|
|
(err/rt-test (sleep -1.0) type?)
|
|
|
|
(define s (make-semaphore 1))
|
|
|
|
(test #t semaphore? s)
|
|
|
|
(arity-test make-semaphore 0 1)
|
|
(err/rt-test (make-semaphore "a") type?)
|
|
(err/rt-test (make-semaphore -1) type?)
|
|
(err/rt-test (make-semaphore 1.0) type?)
|
|
(err/rt-test (make-semaphore (expt 2 64)) exn:fail?)
|
|
(arity-test semaphore? 1 1)
|
|
|
|
(define test-block
|
|
(lambda (block? thunk)
|
|
(let* ([hit? #f]
|
|
[t (parameterize ([current-custodian (make-custodian)])
|
|
(thread (lambda () (thunk) (set! hit? #t))))])
|
|
(sleep SLEEP-TIME)
|
|
(begin0 (test block? 'nondeterministic-block-test (not hit?))
|
|
(kill-thread t)))))
|
|
|
|
(test #t semaphore-try-wait? s)
|
|
(test #f semaphore-try-wait? s)
|
|
(semaphore-post s)
|
|
(test #t semaphore-try-wait? s)
|
|
(test #f semaphore-try-wait? s)
|
|
(semaphore-post s)
|
|
(test-block #f (lambda () (semaphore-wait s)))
|
|
(test-block #t (lambda () (semaphore-wait s)))
|
|
(semaphore-post s)
|
|
(test-block #f (lambda () (semaphore-wait/enable-break s)))
|
|
(test-block #t (lambda () (semaphore-wait/enable-break s)))
|
|
|
|
(arity-test semaphore-try-wait? 1 1)
|
|
(arity-test semaphore-wait 1 1)
|
|
(arity-test semaphore-post 1 1)
|
|
|
|
(define s (make-semaphore))
|
|
(define result 0)
|
|
(define t-loop
|
|
(lambda (n m)
|
|
(lambda ()
|
|
(if (zero? n)
|
|
(begin
|
|
(set! result m)
|
|
(semaphore-post s))
|
|
(thread (t-loop (sub1 n) (add1 m)))))))
|
|
(thread (t-loop 25 1))
|
|
(semaphore-wait s)
|
|
(test 26 'thread-loop result)
|
|
|
|
; Make sure you can break a semaphore-wait:
|
|
'(test 'ok
|
|
'break-semaphore-wait
|
|
(let* ([s1 (make-semaphore 0)]
|
|
[s2 (make-semaphore 0)]
|
|
[t (thread (lambda ()
|
|
(semaphore-post s1)
|
|
(with-handlers ([exn:break? (lambda (x) (semaphore-post s2))])
|
|
(semaphore-wait (make-semaphore 0)))))])
|
|
(semaphore-wait s1)
|
|
(sleep SLEEP-TIME)
|
|
(break-thread t)
|
|
(semaphore-wait s2)
|
|
'ok))
|
|
|
|
; Make sure two waiters can be released
|
|
(test 'ok
|
|
'double-semaphore-wait
|
|
(let* ([s1 (make-semaphore 0)]
|
|
[s2 (make-semaphore 0)]
|
|
[go (lambda ()
|
|
(semaphore-post s2)
|
|
(semaphore-wait s1)
|
|
(semaphore-post s2))])
|
|
(thread go) (thread go)
|
|
(semaphore-wait s2) (semaphore-wait s2)
|
|
(semaphore-post s1) (semaphore-post s1)
|
|
(semaphore-wait s2) (semaphore-wait s2)
|
|
'ok))
|
|
|
|
; Tests inspired by a question from David Tillman
|
|
(define (read-line/expire1 port expiration)
|
|
(with-handlers ([exn:break? (lambda (exn) #f)])
|
|
(let ([timer (thread (let ([id (current-thread)])
|
|
(lambda ()
|
|
(sleep expiration)
|
|
(break-thread id))))])
|
|
(dynamic-wind
|
|
void
|
|
(lambda () (read-line port))
|
|
(lambda () (kill-thread timer))))))
|
|
(define (read-line/expire2 port expiration)
|
|
(let ([done (make-semaphore 0)]
|
|
[result #f])
|
|
(let ([t1 (thread (lambda ()
|
|
(set! result (read-line port))
|
|
(semaphore-post done)))]
|
|
[t2 (thread (lambda ()
|
|
(sleep expiration)
|
|
(semaphore-post done)))])
|
|
(semaphore-wait done)
|
|
(kill-thread t1)
|
|
(kill-thread t2)
|
|
result)))
|
|
;; the main thread is special for semaphore blocking,
|
|
;; so we try read-line/expire1 in sub-threads for a couple
|
|
;; of configurations:
|
|
(define (read-line/expire3 port expiration)
|
|
(call-in-nested-thread (lambda ()
|
|
(read-line/expire1 port expiration))))
|
|
(define (read-line/expire4 port expiration)
|
|
(let ([v #f])
|
|
(let ([t (thread (lambda ()
|
|
(set! v (read-line/expire1 port expiration))))])
|
|
(thread-wait t)
|
|
v)))
|
|
|
|
(define (go read-line/expire)
|
|
(define p (let ([c 0]
|
|
[nl-sema (make-semaphore 1)]
|
|
[ready? #f]
|
|
[nl? #f])
|
|
(make-input-port
|
|
'read-line/expire
|
|
(lambda (s)
|
|
(let ([c (if nl?
|
|
(if ready?
|
|
#\newline
|
|
(wrap-evt nl-sema
|
|
(lambda (x) 0)))
|
|
(begin
|
|
(set! nl? #t)
|
|
(semaphore-try-wait? nl-sema)
|
|
(set! ready? #f)
|
|
(thread (lambda ()
|
|
(sleep 0.4)
|
|
(set! ready? #t)
|
|
(semaphore-post nl-sema)))
|
|
(set! c (add1 c))
|
|
(integer->char c)))])
|
|
(if c
|
|
(if (char? c)
|
|
(begin
|
|
(bytes-set! s 0 (char->integer c))
|
|
1)
|
|
c)
|
|
0)))
|
|
#f
|
|
void)))
|
|
(test #f read-line/expire p 0.2) ; should get char but not newline
|
|
(test "" read-line/expire p 0.6)) ; picks up newline
|
|
|
|
(go read-line/expire1)
|
|
(go read-line/expire2)
|
|
(go read-line/expire3)
|
|
(go read-line/expire4)
|
|
|
|
;; Make sure queueing works, and check kill/wait interaction:
|
|
(let* ([s (make-semaphore)]
|
|
[l null]
|
|
[wait (lambda (who)
|
|
(thread
|
|
(lambda ()
|
|
(semaphore-wait s)
|
|
(set! l (cons who l)))))]
|
|
[pause (lambda () (sleep 0.01))])
|
|
(wait 0) (pause)
|
|
(wait 1) (pause)
|
|
(wait 2)
|
|
(pause)
|
|
(test null 'queue l)
|
|
(semaphore-post s) (pause)
|
|
(test '(0) 'queue l)
|
|
(semaphore-post s) (pause)
|
|
(test '(1 0) 'queue l)
|
|
(semaphore-post s) (pause)
|
|
(test '(2 1 0) 'queue l)
|
|
|
|
(set! l null)
|
|
(wait 0) (pause)
|
|
(let ([t (wait 1)])
|
|
(pause)
|
|
(wait 2)
|
|
(pause)
|
|
(test null 'queue l)
|
|
(kill-thread t)
|
|
(semaphore-post s) (pause)
|
|
(test '(0) 'queue l)
|
|
(semaphore-post s) (pause)
|
|
(test '(2 0) 'queue l)
|
|
(semaphore-post s) (pause)
|
|
(test '(2 0) 'queue l)
|
|
(wait 3) (pause)
|
|
(test '(3 2 0) 'queue l)))
|
|
|
|
;; Nested threads
|
|
(test 5 call-in-nested-thread (lambda () 5))
|
|
|
|
(define (exn:thread? e)
|
|
(and (exn:fail? e) (not (exn:fail:contract? e))))
|
|
|
|
(err/rt-test (call-in-nested-thread (lambda () (kill-thread (current-thread)))) exn:thread?)
|
|
(err/rt-test (call-in-nested-thread (lambda () ((error-escape-handler)))) exn:thread?)
|
|
(err/rt-test (call-in-nested-thread (lambda () (raise (box 5)))) box?)
|
|
|
|
(define output-stream null)
|
|
(define (output v)
|
|
(set! output-stream
|
|
(append output-stream (list v))))
|
|
(define (test-stream v)
|
|
(test v 'output-stream output-stream))
|
|
|
|
(define (chain c)
|
|
(define c1 (make-custodian))
|
|
(define c2 (make-custodian))
|
|
(define c3 (make-custodian))
|
|
|
|
|
|
(set! output-stream null)
|
|
|
|
(output 'os)
|
|
(with-handlers ([void (lambda (x) x)])
|
|
(call-in-nested-thread
|
|
(lambda ()
|
|
(output 'ms)
|
|
(begin0
|
|
(dynamic-wind
|
|
(lambda () (output 'mpre))
|
|
(lambda ()
|
|
(let ([t1 (current-thread)])
|
|
(call-in-nested-thread
|
|
(lambda ()
|
|
(output 'is)
|
|
(with-handlers ([void (lambda (x)
|
|
(if (exn:break? x)
|
|
(output 'ibreak)
|
|
(output 'iother))
|
|
(raise x))])
|
|
(let ([get-c (lambda (c)
|
|
(case c
|
|
[(1) c1]
|
|
[(2) c2]
|
|
[(3) c3]
|
|
[else c]))])
|
|
(if (procedure? c)
|
|
(c t1 get-c)
|
|
(custodian-shutdown-all (get-c c)))))
|
|
(output 'ie)
|
|
'inner-result)
|
|
c2)))
|
|
(lambda () (output 'mpost)))
|
|
(output 'me)))
|
|
c1)))
|
|
|
|
(test 'inner-result chain 3)
|
|
(test-stream '(os ms mpre is ie mpost me))
|
|
|
|
(test #t exn:thread? (chain 1))
|
|
(test-stream '(os ms mpre is ibreak))
|
|
|
|
(parameterize-break #f
|
|
(test #t exn:thread? (chain 1))
|
|
(test-stream '(os ms mpre is ie))
|
|
(test (void) 'discard-break
|
|
(with-handlers ([void void])
|
|
(break-enabled #t)
|
|
(sleep)
|
|
'not-void)))
|
|
|
|
(test #t exn:thread? (chain 2))
|
|
(test-stream '(os ms mpre is mpost))
|
|
|
|
(test #t exn:thread? (chain (lambda (t1 get-c) (kill-thread (current-thread)))))
|
|
(test-stream '(os ms mpre is mpost))
|
|
|
|
(test #t exn:fail:contract? (chain 'wrong))
|
|
(test-stream '(os ms mpre is iother mpost))
|
|
|
|
(test #t exn:break? (chain (let ([t (current-thread)]) (lambda (t1 get-c) (break-thread t)))))
|
|
(test-stream '(os ms mpre is ibreak mpost))
|
|
|
|
(test #t exn:thread? (chain (lambda (t1 get-c) (kill-thread t1))))
|
|
(test-stream '(os ms mpre is ibreak))
|
|
|
|
(parameterize-break #f
|
|
(test #t exn:thread? (let ([t (current-thread)])
|
|
(chain (lambda (t1 get-c)
|
|
(custodian-shutdown-all (get-c 1))
|
|
(test #t thread-running? (current-thread))
|
|
(test #t thread-running? t)
|
|
(test #f thread-running? t1)))))
|
|
(test-stream '(os ms mpre is ie))
|
|
(test (void) 'discard-break
|
|
(with-handlers ([void void])
|
|
(break-enabled #t)
|
|
(sleep)
|
|
'not-void)))
|
|
|
|
(err/rt-test (let/cc k (call-in-nested-thread (lambda () (k)))) exn:fail:contract:continuation?)
|
|
(err/rt-test (let/ec k (call-in-nested-thread (lambda () (k)))) exn:fail:contract:continuation?)
|
|
(err/rt-test ((call-in-nested-thread (lambda () (let/cc k k)))) exn:fail:contract:continuation?)
|
|
(err/rt-test ((call-in-nested-thread (lambda () (let/ec k k)))) exn:fail:contract:continuation?)
|
|
|
|
(err/rt-test (call-in-nested-thread 5))
|
|
(err/rt-test (call-in-nested-thread (lambda (x) 10)))
|
|
(err/rt-test (call-in-nested-thread (lambda () 10) 5))
|
|
|
|
(arity-test call-in-nested-thread 1 2)
|
|
|
|
;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;
|
|
;; Test wait-multiple:
|
|
|
|
(let ([s (make-semaphore 1)]
|
|
[s2 (make-semaphore 1)])
|
|
(let ([w (list
|
|
(sync s s2)
|
|
(sync s s2))])
|
|
(test #t 'both (or (equal? w (list s s2))
|
|
(equal? w (list s2 s))))
|
|
(test #f semaphore-try-wait? s)
|
|
(test #f semaphore-try-wait? s2)))
|
|
|
|
;; same test, but throw in an empty pipe to avoid the
|
|
;; special case for just semaphores:
|
|
(let ([s (make-semaphore 1)]
|
|
[s2 (make-semaphore 1)])
|
|
(let-values ([(r w) (make-pipe)])
|
|
(let ([w (list
|
|
(sync s r s2)
|
|
(sync s r s2))])
|
|
(test #t 'both (or (equal? w (list s s2))
|
|
(equal? w (list s2 s))))
|
|
(test #f semaphore-try-wait? s)
|
|
(test #f semaphore-try-wait? s2))))
|
|
|
|
(let ([s (make-semaphore)]
|
|
[s-t (make-semaphore)]
|
|
[portnum (+ 40000 (random 100))]) ; so parallel tests work ok
|
|
(let ([t (thread
|
|
(lambda ()
|
|
(sync s-t)))]
|
|
[l (tcp-listen portnum 5 #t)]
|
|
[orig-thread (current-thread)])
|
|
(let-values ([(r w) (make-pipe)])
|
|
|
|
(define (try-all-blocked* wait)
|
|
(let ([v #f])
|
|
(let ([bt (thread
|
|
(lambda ()
|
|
(with-handlers ([exn:break? (lambda (x) (set! v 'break))])
|
|
(set! v (wait #f s t l r)))))])
|
|
(sleep 0.05) ;;; <---------- race condition (that's unlikely to fail)
|
|
(break-thread bt)
|
|
(sleep 0.05) ;;; <----------
|
|
)
|
|
(test 'break 'broken-wait v)))
|
|
|
|
(define (try-all-blocked)
|
|
(test #f sync/timeout 0.05 s t l r))
|
|
|
|
(try-all-blocked* sync/timeout)
|
|
(try-all-blocked* sync/timeout/enable-break)
|
|
(parameterize-break #f
|
|
(try-all-blocked* sync/timeout/enable-break))
|
|
|
|
(display #\x w)
|
|
(test r sync s t l r)
|
|
(test r sync s t l r)
|
|
(peek-char r)
|
|
(test r sync s t l r)
|
|
(read-char r)
|
|
(try-all-blocked)
|
|
|
|
;; pipe write always available, since no limit:
|
|
(test w sync s t l r w)
|
|
|
|
(semaphore-post s)
|
|
(test s sync s t l r)
|
|
(try-all-blocked)
|
|
|
|
(semaphore-post s-t)
|
|
(test t sync s t l r)
|
|
(test t sync s t l r)
|
|
|
|
(set! t (thread (lambda () (semaphore-wait (make-semaphore)))))
|
|
|
|
(let-values ([(cr cw) (tcp-connect "localhost" portnum)])
|
|
(test l sync s t l r)
|
|
(test l sync s t l r)
|
|
|
|
(let-values ([(sr sw) (tcp-accept l)])
|
|
(try-all-blocked)
|
|
|
|
(close-output-port w)
|
|
(test r sync s t l r)
|
|
(test r sync s t l r)
|
|
|
|
(set! r cr)
|
|
(try-all-blocked)
|
|
|
|
(display #\y sw)
|
|
(flush-output sw)
|
|
(test cr sync s t l sr cr)
|
|
(read-char cr)
|
|
(try-all-blocked)
|
|
(test sw sync s t l sr cr sw)
|
|
|
|
(display #\z cw)
|
|
(flush-output cw)
|
|
(test sr sync s t l sr cr)
|
|
(read-char sr)
|
|
(try-all-blocked)
|
|
(test cw sync s t l sr cr cw)
|
|
|
|
;; Fill up output buffer:
|
|
(test sw sync/timeout 0 sw)
|
|
(test #t
|
|
positive?
|
|
(let loop ([n 0])
|
|
(if (and (sync/timeout 0 sw)
|
|
(= 4096 (write-bytes-avail (make-bytes 4096 (char->integer #\x)) sw)))
|
|
(loop (add1 n))
|
|
n)))
|
|
(test #f sync/timeout 0 sw sr)
|
|
(test cr sync/timeout 0 sw sr cr)
|
|
;; Flush cr:
|
|
(let ([s (make-bytes 4096)])
|
|
(let loop ()
|
|
(when (and (char-ready? cr)
|
|
(= 4096 (read-bytes-avail! s cr)))
|
|
(loop))))
|
|
|
|
(close-output-port sw)
|
|
(test cr sync s t l sr cr)
|
|
(test cr sync s t l sr cr)
|
|
|
|
(close-output-port cw)
|
|
(test sr sync s t l sr))))
|
|
(tcp-close l)))
|
|
|
|
;; Test limited pipe output waiting:
|
|
(let-values ([(r w) (make-pipe 5000)])
|
|
(test #f sync/timeout 0 r)
|
|
(test w sync/timeout 0 r w)
|
|
(display (make-bytes 4999 (char->integer #\x)) w)
|
|
(test w sync/timeout 0 w)
|
|
(display #\y w)
|
|
(test #f sync/timeout 0 w)
|
|
(test 0 write-bytes-avail* #"hello" w)
|
|
(test r sync/timeout 0 r w)
|
|
(read-char r)
|
|
(test w sync/timeout 0 w)
|
|
(display #\z w)
|
|
(test #f sync/timeout 0 w)
|
|
(read-bytes 5000 r)
|
|
(test #f sync/timeout 0 r)
|
|
(test w sync/timeout 0 r w)
|
|
(display (make-bytes 5000 (char->integer #\x)) w)
|
|
(test r sync/timeout 0 r w)
|
|
(test #f sync/timeout 0 w))
|
|
|
|
;; ----------------------------------------
|
|
;; Suspend and resume
|
|
|
|
;; Suspend main thread:
|
|
(let ([v 17]
|
|
[s (make-semaphore)]
|
|
[t (current-thread)])
|
|
(let ([t2 (thread (lambda ()
|
|
(thread-suspend t)
|
|
(test #f thread-running? t)
|
|
(test #f thread-dead? t)
|
|
(semaphore-post s)
|
|
(sleep SLEEP-TIME)
|
|
(test 17 values v)
|
|
(thread-resume t)))])
|
|
(semaphore-wait s)
|
|
(set! v 99)
|
|
(thread-wait t2)))
|
|
|
|
;; Self-suspend main thread:
|
|
(let ([v 19]
|
|
[t (current-thread)])
|
|
(let ([t2 (thread (lambda ()
|
|
(sleep SLEEP-TIME)
|
|
(test 19 values v)
|
|
(thread-resume t)))])
|
|
(thread-suspend t)
|
|
(set! v 99)
|
|
(thread-wait t2)))
|
|
|
|
;; Self-suspend child thread:
|
|
(let ([v 20])
|
|
(let ([t2 (thread (lambda ()
|
|
(thread-suspend (current-thread))
|
|
(set! v 99)))])
|
|
(sleep SLEEP-TIME)
|
|
(test #f thread-running? t2)
|
|
(test #f thread-dead? t2)
|
|
(thread-resume t2)
|
|
(test 20 values v)
|
|
(thread-wait t2)
|
|
(test #f thread-running? t2)
|
|
(test #t thread-dead? t2)
|
|
(test 99 values v)))
|
|
|
|
;; Suspend child thread:
|
|
(let ([v 17]
|
|
[s (make-semaphore)]
|
|
[t (current-thread)])
|
|
(let ([t2 (thread (lambda ()
|
|
(semaphore-wait s)
|
|
(set! v 99)))])
|
|
(thread-suspend t2)
|
|
(test #f thread-dead? t2)
|
|
(test #f thread-running? t2)
|
|
(semaphore-post s)
|
|
(sleep SLEEP-TIME)
|
|
(test 17 values v)
|
|
(thread-resume t2)
|
|
(thread-wait t2)
|
|
(test #f thread-running? t2)
|
|
(test #t thread-dead? t2)
|
|
(test 99 values v)))
|
|
|
|
;; Breaking/killing:
|
|
(define /dev/null-for-err
|
|
(make-output-port 'dev/null always-evt (lambda (s start end ? ??) (- end start)) void void))
|
|
(for-each
|
|
(lambda (sleep0)
|
|
(test (list 'start-sleep0 sleep0) values (list 'start-sleep0 sleep0))
|
|
(let ([goes
|
|
(lambda (sleep1 sleep2 break-thread)
|
|
(test (list 'start-goes sleep1 sleep2 break-thread) values (list 'start-goes sleep1 sleep2 break-thread))
|
|
(test 'external-suspend values 'external-suspend)
|
|
(let ([v 10])
|
|
(let ([t2 (parameterize ([current-error-port /dev/null-for-err])
|
|
(thread
|
|
(lambda ()
|
|
(let loop () (when (= v 10) (sleep) (loop)))
|
|
(sleep0)
|
|
(set! v 99))))])
|
|
(sleep1)
|
|
(thread-suspend t2)
|
|
(set! v 20)
|
|
(test (void) break-thread t2)
|
|
(sleep2)
|
|
(test (void) thread-resume t2)
|
|
(test (void) thread-wait t2)
|
|
(test 20 values v)))
|
|
(test 'self-suspend values 'self-suspend)
|
|
(let ([v 20])
|
|
(let ([t2 (parameterize ([current-error-port /dev/null-for-err])
|
|
(thread (lambda ()
|
|
(thread-suspend (current-thread))
|
|
(sleep0)
|
|
(set! v 99))))])
|
|
(sleep1)
|
|
(break-thread t2)
|
|
(sleep2)
|
|
;; keep trying to resume until the thread stops:
|
|
(let loop ()
|
|
(unless (sync/timeout 0 t2)
|
|
(thread-resume t2)
|
|
(loop)))
|
|
(thread-wait t2)
|
|
(test 20 values v)))
|
|
(let ([w-block
|
|
(lambda (post wait)
|
|
(test (list 'start-w-block post wait) values (list 'start-w-block post wait))
|
|
;; Child thread sleeps
|
|
(let ([v 20])
|
|
(let ([t2 (parameterize ([current-error-port /dev/null-for-err])
|
|
(thread (lambda ()
|
|
(wait)
|
|
(sleep0)
|
|
(set! v 99)
|
|
(fprintf (current-error-port) "Thread shouldn't get here! ~a~n" (break-enabled)))))])
|
|
(sleep1)
|
|
(thread-suspend t2)
|
|
(post)
|
|
(sleep2)
|
|
(break-thread t2)
|
|
(sleep2)
|
|
(thread-resume t2)
|
|
(thread-wait t2)
|
|
(test 20 values v)))
|
|
(unless (eq? break-thread kill-thread)
|
|
(wait)
|
|
;; Main thread sleeps
|
|
(let ([v 25]
|
|
[t (current-thread)]
|
|
[done (make-semaphore)])
|
|
(with-handlers ([exn:break?
|
|
(lambda (x) (semaphore-post done))])
|
|
(let ([t2 (thread (lambda ()
|
|
(sleep1)
|
|
(thread-suspend t)
|
|
(post)
|
|
(sleep2)
|
|
(break-thread t)
|
|
(sleep2)
|
|
(thread-resume t)
|
|
(semaphore-wait done)
|
|
(test 25 values v)))])
|
|
(wait)
|
|
(sleep0)
|
|
(set! v 99)
|
|
(fprintf (current-error-port) "Shouldn't get here! ~a~n" (break-enabled)))))))])
|
|
(test 'sema-block values 'sema-block)
|
|
(let ([s (make-semaphore)])
|
|
(w-block (lambda () (semaphore-post s))
|
|
(lambda () (semaphore-wait s))))
|
|
(for-each
|
|
(lambda (init)
|
|
(test (list 'sema-block/enable-break init) values (list 'sema-block/enable-break init))
|
|
(let ([s (make-semaphore)])
|
|
(parameterize-break init
|
|
(w-block (lambda () (semaphore-post s))
|
|
(lambda () (semaphore-wait/enable-break s))))))
|
|
'(#t #f))
|
|
(test 'ch-block values 'ch-block)
|
|
(let ([ch (make-channel)])
|
|
(w-block (lambda () (thread (lambda () (channel-put ch 10))))
|
|
(lambda () (sync (make-semaphore) ch))))
|
|
(for-each
|
|
(lambda (init)
|
|
(test (list 'ch-block/enable-break init) values (list 'ch-block/enable-break init))
|
|
(let ([ch (make-channel)])
|
|
(parameterize-break #f
|
|
(w-block (lambda () (thread (lambda () (channel-put ch 10))))
|
|
(lambda () (sync/timeout/enable-break #f (make-semaphore) ch))))))
|
|
'(#t #f))))])
|
|
(define BKT-SLEEP-TIME (/ SLEEP-TIME 4))
|
|
(goes void void break-thread)
|
|
(goes void void kill-thread)
|
|
(goes sleep void break-thread)
|
|
(goes sleep void kill-thread)
|
|
(goes void sleep break-thread)
|
|
(goes void sleep kill-thread)
|
|
(goes sleep sleep break-thread)
|
|
(goes sleep sleep kill-thread)
|
|
(goes (lambda () (sleep BKT-SLEEP-TIME)) void break-thread)
|
|
(goes (lambda () (sleep BKT-SLEEP-TIME)) void kill-thread)
|
|
(goes void (lambda () (sleep BKT-SLEEP-TIME)) break-thread)
|
|
(goes void (lambda () (sleep BKT-SLEEP-TIME)) kill-thread)
|
|
(goes (lambda () (sleep BKT-SLEEP-TIME)) (lambda () (sleep BKT-SLEEP-TIME)) break-thread)
|
|
(goes (lambda () (sleep BKT-SLEEP-TIME)) (lambda () (sleep BKT-SLEEP-TIME)) kill-thread)))
|
|
(list sleep void))
|
|
|
|
;; ----------------------------------------
|
|
;; Simple multi-custodian threads
|
|
|
|
(let ([go
|
|
(lambda (1st1st? derived?)
|
|
(let* ([c1 (make-custodian)]
|
|
[c2 (make-custodian (if derived? c1 (current-custodian)))])
|
|
(let ([t (parameterize ([current-custodian c1])
|
|
(thread (lambda () (sleep 1000))))])
|
|
(test #t thread-running? t)
|
|
(thread-resume t c2)
|
|
(test #t thread-running? t)
|
|
(custodian-shutdown-all (if 1st1st? c1 c2))
|
|
(test (not (and derived? 1st1st?)) thread-running? t)
|
|
(custodian-shutdown-all (if 1st1st? c1 c2))
|
|
(test (not (and derived? 1st1st?)) thread-running? t)
|
|
(custodian-shutdown-all (if 1st1st? c2 c1))
|
|
(test #f thread-running? t))))])
|
|
(go #t #f)
|
|
(go #f #f)
|
|
(go #t #t)
|
|
(go #f #t))
|
|
|
|
;; Test collapsing custodians for resume
|
|
(let* ([c0 (make-custodian)]
|
|
[c1 (make-custodian c0)]
|
|
[c2 (make-custodian c0)]
|
|
[c3 (make-custodian c0)])
|
|
(let ([t (parameterize ([current-custodian c1])
|
|
(thread (lambda () (sleep 1000))))])
|
|
(thread-resume t c2)
|
|
(thread-resume t c3)
|
|
(thread-resume t c0)
|
|
(custodian-shutdown-all c0)
|
|
(test #f thread-running? t)))
|
|
|
|
;; ----------------------------------------
|
|
;; Kill versus Suspend
|
|
|
|
(let* ([v 0]
|
|
[loop (lambda ()
|
|
(let loop ()
|
|
(set! v (add1 v))
|
|
(sleep (/ SLEEP-TIME 2))
|
|
(loop)))]
|
|
[c0 (make-custodian)])
|
|
(let ([try
|
|
(lambda (resumable?)
|
|
(let* ([c (parameterize ([current-custodian c0])
|
|
(make-custodian))]
|
|
[t (parameterize ([current-custodian c])
|
|
((if resumable? thread/suspend-to-kill thread) loop))]
|
|
[check-inc (lambda (inc?)
|
|
(let ([v0 v])
|
|
(sleep SLEEP-TIME)
|
|
(test inc? > v v0)))])
|
|
(test #t thread-running? t)
|
|
(check-inc #t)
|
|
(custodian-shutdown-all c)
|
|
(test #f thread-running? t)
|
|
(test (not resumable?) thread-dead? t)
|
|
(test (and resumable? t) sync/timeout 0 (thread-suspend-evt t))
|
|
(check-inc #f)
|
|
(let ([r (thread-resume-evt t)])
|
|
(test #f sync/timeout 0 r)
|
|
(set! c (make-custodian))
|
|
(thread-resume t c)
|
|
(test (and resumable? t) sync/timeout 0 r))
|
|
(test resumable? thread-running? t)
|
|
(when resumable?
|
|
(check-inc #t)
|
|
(custodian-shutdown-all c)
|
|
(test #f thread-running? t)
|
|
(test #f thread-dead? t)
|
|
(check-inc #f)
|
|
(set! c (make-custodian))
|
|
(thread-resume t c)
|
|
(test #t thread-running? t)
|
|
(check-inc #t)
|
|
(kill-thread t)
|
|
(test #f thread-running? t)
|
|
(test #f thread-dead? t)
|
|
(check-inc #f)
|
|
(thread-resume t)
|
|
(check-inc #t)
|
|
(custodian-shutdown-all c)
|
|
(thread-wait
|
|
(parameterize ([current-custodian c0])
|
|
(thread (lambda () (thread-resume t (current-thread))))))
|
|
(check-inc #t)
|
|
(custodian-shutdown-all c)
|
|
(test #t thread-running? t)
|
|
(check-inc #t)
|
|
(set! c (make-custodian))
|
|
(thread-resume t c)
|
|
(custodian-shutdown-all c)
|
|
(test #t thread-running? t)
|
|
(check-inc #t)
|
|
(custodian-shutdown-all c0)
|
|
(check-inc #f)
|
|
(thread-resume t (current-thread))
|
|
(check-inc #t)
|
|
(custodian-shutdown-all c)
|
|
(test #t thread-running? t)
|
|
(check-inc #t)
|
|
(kill-thread t)
|
|
(check-inc #f))))])
|
|
(try #f)
|
|
(try #t)))
|
|
|
|
;; Transitive resume:
|
|
(let ([go
|
|
(lambda (thread c-suspend?)
|
|
(parameterize ([current-custodian (make-custodian)])
|
|
(letrec ([setup-transitive
|
|
(lambda (t depth)
|
|
(if (= depth 0)
|
|
null
|
|
(let ([t1 (thread (lambda () (sleep 1000)))]
|
|
[t2 (thread (lambda () (semaphore-wait (make-semaphore))))])
|
|
(thread-resume t1 t)
|
|
(thread-resume t2 t)
|
|
(append
|
|
(setup-transitive t1 (sub1 depth))
|
|
(setup-transitive t2 (sub1 depth))
|
|
(list t1 t2)))))])
|
|
(let ([t (thread (lambda () (sleep 10000)))])
|
|
(let ([threads (cons t (setup-transitive t 5))])
|
|
(for-each (lambda (t)
|
|
(test #t thread-running? t))
|
|
threads)
|
|
(if c-suspend?
|
|
(custodian-shutdown-all (current-custodian))
|
|
(for-each thread-suspend threads))
|
|
(for-each (lambda (t)
|
|
(test #f thread-running? t))
|
|
threads)
|
|
(test (void) thread-resume t)
|
|
(for-each (lambda (t)
|
|
(test (not c-suspend?) thread-running? t))
|
|
threads)))
|
|
(custodian-shutdown-all (current-custodian)))))])
|
|
(go thread #f)
|
|
(go thread/suspend-to-kill #t)
|
|
(go thread/suspend-to-kill #f))
|
|
|
|
(let ([t1 (thread (lambda () (semaphore-wait (make-semaphore))))]
|
|
[t2 (thread (lambda () (semaphore-wait (make-semaphore))))]
|
|
[t3 (thread (lambda () (semaphore-wait (make-semaphore))))])
|
|
(test (void) thread-resume t2 t1)
|
|
(test (void) thread-resume t3 t2)
|
|
(thread-suspend t1)
|
|
(thread-suspend t3)
|
|
(test #f thread-running? t1)
|
|
(test #t thread-running? t2)
|
|
(test #f thread-running? t3)
|
|
(thread-resume t1)
|
|
;; Thread t3 should not have been resumed...
|
|
(test #f thread-running? t3)
|
|
(thread-resume t2)
|
|
;; Still, thread t3 should not have been resumed...
|
|
(test #f thread-running? t3)
|
|
(thread-suspend t2)
|
|
(thread-resume t2)
|
|
;; Now it should be resumed!
|
|
(test #t thread-running? t3)
|
|
(kill-thread t3)
|
|
(thread-suspend t2)
|
|
(thread-resume t2)
|
|
(test #f thread-running? t3))
|
|
|
|
;; Transitive custodian addition:
|
|
(let ([c1 (make-custodian)]
|
|
[c2 (make-custodian)]
|
|
[c3 (make-custodian)])
|
|
(let ([t1 (parameterize ([current-custodian c1])
|
|
(thread/suspend-to-kill (lambda () (sleep 10000))))]
|
|
[t2 (parameterize ([current-custodian c2])
|
|
(thread/suspend-to-kill (lambda () (sleep 10000))))])
|
|
(let ([t2-2 (let loop ([n 5][t t2])
|
|
(if (zero? n)
|
|
t
|
|
(loop (sub1 n)
|
|
(parameterize ([current-custodian c2])
|
|
(let ([t2 (thread/suspend-to-kill (lambda () (sleep 10000)))])
|
|
(thread-resume t2 t)
|
|
t2)))))])
|
|
(custodian-shutdown-all c2)
|
|
(test #f thread-running? t2)
|
|
(test #f thread-running? t2-2)
|
|
(thread-resume t2)
|
|
(test #f thread-running? t2)
|
|
(test #f thread-running? t2-2)
|
|
(thread-resume t2 t1)
|
|
(test #t thread-running? t2)
|
|
(test #t thread-running? t2-2)
|
|
(thread-resume t1 c3)
|
|
(custodian-shutdown-all c1)
|
|
(test #t thread-running? t1)
|
|
(test #t thread-running? t2)
|
|
(test #t thread-running? t2-2)
|
|
(custodian-shutdown-all c3)
|
|
(test #f thread-running? t1)
|
|
(test #f thread-running? t2)
|
|
(test #f thread-running? t2-2))))
|
|
|
|
;; Cyclic thread yokes should be ok:
|
|
(let* ([c1 (make-custodian)]
|
|
[c2 (make-custodian)]
|
|
[t1 (parameterize ([current-custodian c1])
|
|
(thread (lambda () (sleep 10000))))]
|
|
[t2 (parameterize ([current-custodian c2])
|
|
(thread (lambda () (sleep 10000))))])
|
|
(thread-resume t1 t2)
|
|
(thread-resume t2 t1)
|
|
(thread-suspend t1)
|
|
(thread-suspend t2)
|
|
(test #f thread-running? t1)
|
|
(test #f thread-running? t2)
|
|
(thread-resume t1)
|
|
(test #t thread-running? t1)
|
|
(test #t thread-running? t2)
|
|
(thread-suspend t1)
|
|
(thread-suspend t2)
|
|
(test #f thread-running? t1)
|
|
(test #f thread-running? t2)
|
|
(thread-resume t2)
|
|
(test #t thread-running? t1)
|
|
(test #t thread-running? t2)
|
|
(custodian-shutdown-all c1)
|
|
(test #t thread-running? t1)
|
|
(test #t thread-running? t2)
|
|
(custodian-shutdown-all c2)
|
|
(test #f thread-running? t1)
|
|
(test #f thread-running? t2))
|
|
|
|
;; ----------------------------------------
|
|
|
|
;; Check that a terminated thread cleans up ownership
|
|
;; of runstack and mark stack (crashes or doesn't).
|
|
;; Also checks that deep runstacks are ok.
|
|
(let ()
|
|
(define bye #f)
|
|
(define hi #f)
|
|
(define k #f)
|
|
|
|
(define s (make-semaphore))
|
|
(define s2 (make-semaphore))
|
|
(define s3 (make-semaphore))
|
|
(define s4 (make-semaphore))
|
|
(define s5 (make-semaphore))
|
|
|
|
(define t0
|
|
(thread (lambda ()
|
|
(semaphore-wait s)
|
|
(semaphore-wait s)
|
|
(kill-thread t))))
|
|
|
|
(define t
|
|
(thread (lambda ()
|
|
(let loop ([n 4000])
|
|
(with-continuation-mark 'x 10
|
|
(dynamic-wind
|
|
void
|
|
(lambda ()
|
|
(let ()
|
|
(if (zero? n)
|
|
(let ()
|
|
(let/cc x
|
|
(set! k x)
|
|
(printf "Bye\n")
|
|
(semaphore-post s)
|
|
(sync s2 s3 s4 s5))
|
|
(printf "Hi\n"))
|
|
(loop (sub1 n)))))
|
|
void))))))
|
|
(semaphore-post s)
|
|
|
|
(thread-wait t)
|
|
(thread-wait (thread k)))
|
|
|
|
; ----------------------------------------
|
|
|
|
(let ([c (make-thread-cell 10)]
|
|
[c2 (make-thread-cell -10 #t)]
|
|
[c3 (make-thread-cell 3 #t)])
|
|
(test 10 thread-cell-ref c)
|
|
(test -10 thread-cell-ref c2)
|
|
(let ([orig (current-preserved-thread-cell-values)])
|
|
(test (void) thread-cell-set! c 11)
|
|
(test (void) thread-cell-set! c2 -11)
|
|
(test 11 thread-cell-ref c)
|
|
(test -11 thread-cell-ref c2)
|
|
(test 3 thread-cell-ref c3)
|
|
(let ([check-sub
|
|
(lambda ()
|
|
(thread-wait (thread (lambda ()
|
|
(test 10 thread-cell-ref c)
|
|
(test -11 thread-cell-ref c2)
|
|
(test 3 thread-cell-ref c3)
|
|
(test (void) thread-cell-set! c 12)
|
|
(test 12 thread-cell-ref c)
|
|
(test (void) thread-cell-set! c2 -12)
|
|
(test -12 thread-cell-ref c2)
|
|
(test (void) thread-cell-set! c3 13)
|
|
(test 13 thread-cell-ref c3)))))]
|
|
[post (current-preserved-thread-cell-values)])
|
|
(check-sub)
|
|
(current-preserved-thread-cell-values orig)
|
|
(test 11 thread-cell-ref c)
|
|
(test -10 thread-cell-ref c2)
|
|
(test 3 thread-cell-ref c3)
|
|
(test (void) thread-cell-set! c3 23)
|
|
(test 23 thread-cell-ref c3)
|
|
(current-preserved-thread-cell-values post)
|
|
(test 11 thread-cell-ref c)
|
|
(test -11 thread-cell-ref c2)
|
|
(test 3 thread-cell-ref c3)
|
|
(check-sub)
|
|
(thread-wait (thread (lambda ()
|
|
(current-preserved-thread-cell-values post)
|
|
(test 10 thread-cell-ref c)
|
|
(test -11 thread-cell-ref c2)
|
|
(test 3 thread-cell-ref c3)
|
|
(test (void) thread-cell-set! c3 13)
|
|
(test 13 thread-cell-ref c3)
|
|
(current-preserved-thread-cell-values post)
|
|
(test 3 thread-cell-ref c3)))))))
|
|
|
|
; --------------------
|
|
|
|
(report-errs)
|