improve parallel testing
svn: r5548
This commit is contained in:
Matthew Flatt
parent
40c6593a36
commit
126ff2a91a
|
|
@ -3,12 +3,9 @@
|
|||
;; thread creates a directory sub<n> to run in, so that filesystem
|
||||
;; tests don't collide.
|
||||
|
||||
(with-handlers ([exn:fail?
|
||||
(lambda (exn)
|
||||
(namespace-set-variable-value!
|
||||
'parallel-load
|
||||
"quiet.ss"))])
|
||||
(namespace-variable-value 'parallel-load))
|
||||
(namespace-variable-value 'parallel-load #f
|
||||
(lambda ()
|
||||
(namespace-set-variable-value! 'parallel-load "quiet.ss")))
|
||||
|
||||
(define in-shared-k #f)
|
||||
;; Some threads start with the
|
||||
|
|
@ -24,63 +21,55 @@
|
|||
; Runs n versions of test in parallel threads and namespaces,
|
||||
; waiting until all are done
|
||||
(define (parallel n test)
|
||||
(let ([done (make-semaphore)]
|
||||
[go (make-semaphore)]
|
||||
[custodians (let loop ([n n])
|
||||
(let ([custodians (let loop ([n n])
|
||||
(if (zero? n)
|
||||
null
|
||||
(cons (make-custodian) (loop (sub1 n)))))])
|
||||
(let loop ([n n])
|
||||
(unless (zero? n)
|
||||
(let ([ns (make-namespace)]
|
||||
[eh (exit-handler)]
|
||||
[cust (list-ref custodians (sub1 n))])
|
||||
(parameterize ([current-custodian cust])
|
||||
(thread
|
||||
(lambda ()
|
||||
(start
|
||||
n
|
||||
(lambda ()
|
||||
(parameterize ([current-namespace ns]
|
||||
[exit-handler (lambda (v)
|
||||
(for-each (lambda (c)
|
||||
(unless (eq? c cust)
|
||||
(custodian-shutdown-all c)))
|
||||
custodians)
|
||||
(eh v))])
|
||||
(namespace-transformer-require 'mzscheme)
|
||||
(eval `(define Section-prefix ,(format "~a:" n)))
|
||||
(let ([dirname (format "sub~s" n)])
|
||||
(when (directory-exists? dirname)
|
||||
(delete-directory* dirname))
|
||||
(make-directory dirname)
|
||||
(current-directory dirname)
|
||||
(dynamic-wind
|
||||
void
|
||||
(lambda ()
|
||||
(load test))
|
||||
(lambda ()
|
||||
(semaphore-post done)
|
||||
(semaphore-wait go)
|
||||
(printf "~nThread ~s:" n)
|
||||
(eval '(report-errs))
|
||||
(current-directory (build-path 'up))
|
||||
(delete-directory* dirname)
|
||||
(semaphore-post done))))))))))
|
||||
(loop (sub1 n)))))
|
||||
(cons (make-custodian) (loop (sub1 n)))))]
|
||||
[o (current-error-port)])
|
||||
(define threads
|
||||
(let loop ([n n])
|
||||
(if (zero? n)
|
||||
null
|
||||
(cons
|
||||
(let ([ns (make-namespace)]
|
||||
[eh (exit-handler)]
|
||||
[cust (list-ref custodians (sub1 n))])
|
||||
(parameterize ([current-custodian cust])
|
||||
(thread
|
||||
(lambda ()
|
||||
(start
|
||||
n
|
||||
(lambda ()
|
||||
(parameterize ([current-namespace ns])
|
||||
(namespace-transformer-require 'mzscheme)
|
||||
(eval `(define Section-prefix ,(format "~a:" n)))
|
||||
(let ([dirname (path->complete-path (format "sub~s" n))])
|
||||
(when (directory-exists? dirname)
|
||||
(delete-directory* dirname))
|
||||
(make-directory dirname)
|
||||
(current-directory dirname)
|
||||
(parameterize ([exit-handler (lambda (v)
|
||||
(current-directory (build-path dirname 'up))
|
||||
(delete-directory* dirname)
|
||||
(if (zero? v)
|
||||
;; Shut down self:
|
||||
(custodian-shutdown-all cust)
|
||||
(begin
|
||||
;; Shut down all the others:
|
||||
(for-each (lambda (c)
|
||||
(unless (eq? c cust)
|
||||
(custodian-shutdown-all c)))
|
||||
custodians)
|
||||
;; Exit whole process:
|
||||
(eh v))))])
|
||||
(load test)
|
||||
(exit 0))))))))))
|
||||
(loop (sub1 n))))))
|
||||
(with-handlers ([exn? (lambda (exn)
|
||||
(for-each custodian-shutdown-all
|
||||
custodians)
|
||||
(raise exn))])
|
||||
(let loop ([n n])
|
||||
(unless (zero? n)
|
||||
(semaphore-wait done)
|
||||
(loop (sub1 n))))
|
||||
(let loop ([n n])
|
||||
(unless (zero? n)
|
||||
(semaphore-post go)
|
||||
(semaphore-wait done)
|
||||
(loop (sub1 n)))))))
|
||||
(for-each sync threads))))
|
||||
|
||||
(define (delete-directory* dir)
|
||||
(for-each (lambda (f)
|
||||
|
|
@ -92,3 +81,4 @@
|
|||
(delete-directory dir))
|
||||
|
||||
(parallel 3 (path->complete-path parallel-load (current-load-relative-directory)))
|
||||
(exit 0)
|
||||
|
|
|
|||
|
|
@ -25,7 +25,7 @@
|
|||
;; -- set up a timeout
|
||||
(thread (lambda ()
|
||||
(sleep 600)
|
||||
(fprintf err "\n\nTIMEOUT -- ABORTING!\n")
|
||||
(fprintf err "\n\n~aTIMEOUT -- ABORTING!\n" Section-prefix)
|
||||
(exit 3)
|
||||
;; in case the above didn't work for some reason
|
||||
(sleep 60)
|
||||
|
|
|
|||
|
|
@ -490,8 +490,10 @@
|
|||
[real-took (/ (abs (- (current-milliseconds) real-msecs)) 1000.0)]
|
||||
[boundary (/ SYNC-BUSY-DELAY 6)])
|
||||
;; Hack.
|
||||
;; The following test isn't reliable, so only Matthew should see it.
|
||||
(when (regexp-match #rx"(mflatt)|(matthewf)" (path->string (find-system-path 'home-dir)))
|
||||
;; The following test isn't reliable, so only Matthew should see it,
|
||||
;; and only in non-parallel mode:
|
||||
(when (and (regexp-match #rx"(mflatt)|(matthewf)" (path->string (find-system-path 'home-dir)))
|
||||
(equal? "" Section-prefix))
|
||||
(test busy? (lambda (a ax b c d) (> b c)) 'busy-wait? go took boundary real-took)))))
|
||||
|
||||
(define (test-good-waitable wrap-sema)
|
||||
|
|
@ -587,7 +589,7 @@
|
|||
(thread (lambda ()
|
||||
(sleep SYNC-BUSY-DELAY)
|
||||
(set! go? #t)))
|
||||
(test bad-stuck-port sync/timeout (* 3 SYNC-BUSY-DELAY) bad-stuck-port))
|
||||
(test bad-stuck-port sync bad-stuck-port))
|
||||
#t)))
|
||||
|
||||
(test-stuck-port (make-semaphore 1) semaphore-try-wait? semaphore-post)
|
||||
|
|
@ -706,7 +708,11 @@
|
|||
[sl (lambda ()
|
||||
(let loop ([n 20])
|
||||
(unless (zero? n) (sleep) (loop (sub1 n)))))]
|
||||
[ok-done? (lambda (r) (<= (list-ref r 3) orig-scheduled))])
|
||||
[ok-done? (lambda (r)
|
||||
(or (<= (list-ref r 3) orig-scheduled)
|
||||
;; If we're running parallel threads,
|
||||
;; just give up on the comparison.
|
||||
(not (equal? "" Section-prefix))))])
|
||||
(test #t
|
||||
ok-done?
|
||||
(let loop ([tries 0][n 100])
|
||||
|
|
|
|||
|
|
@ -278,16 +278,19 @@ transcript.
|
|||
(let* ([final? (and (pair? final?) (car final?))]
|
||||
[printf (if final? eprintf* printf)]
|
||||
[ok? (null? errs)])
|
||||
(printf "\nPerformed ~a expression tests (~a ~a, ~a ~a)\n"
|
||||
(printf "\n~aPerformed ~a expression tests (~a ~a, ~a ~a)\n"
|
||||
Section-prefix
|
||||
(+ number-of-tests number-of-error-tests)
|
||||
number-of-tests "good expressions"
|
||||
number-of-error-tests "bad expressions")
|
||||
(printf "and ~a exception field tests.\n\n"
|
||||
(printf "~aand ~a exception field tests.\n\n"
|
||||
Section-prefix
|
||||
number-of-exn-tests)
|
||||
(if ok?
|
||||
(printf "Passed all tests.\n")
|
||||
(begin (printf "Errors were:\n(Section (got expected (call)))\n")
|
||||
(for-each (lambda (l) (printf "~s\n" l)) (reverse errs))
|
||||
(printf "~aPassed all tests.\n" Section-prefix)
|
||||
(begin (printf "~aErrors were:\n~a(Section (got expected (call)))\n"
|
||||
Section-prefix Section-prefix)
|
||||
(for-each (lambda (l) (printf "~a~s\n" Section-prefix l)) (reverse errs))
|
||||
(when final? (exit 1))))
|
||||
(when final? (exit (if ok? 0 1)))
|
||||
(printf "(Other messages report successful tests of~a.)\n"
|
||||
|
|
|
|||
|
|
@ -22,40 +22,41 @@
|
|||
(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)
|
||||
(when (equal? "" Section-prefix)
|
||||
(let ([a (box 0)]
|
||||
[b (box 0)]
|
||||
[c (box 0)]
|
||||
[d (box 0)]
|
||||
[stop? #f])
|
||||
|
||||
(sleep SLEEP-TIME)
|
||||
(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)
|
||||
|
||||
(set! stop? #t)
|
||||
(sleep SLEEP-TIME)
|
||||
|
||||
(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)))
|
||||
(set! stop? #t)
|
||||
|
||||
(test #t roughly= vb (* b% va))
|
||||
(test #t roughly= vc (* c% va))
|
||||
(test #t roughly= vd (* d% va)))))
|
||||
(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)])
|
||||
|
|
|
|||
|
|
@ -97,3 +97,5 @@
|
|||
(test #f coroutine-result w4)
|
||||
(err/rt-test (coroutine-run MAX-RUN-TIME w4) (lambda (x) (eq? x 15)))
|
||||
(test #t coroutine-run 100 w4)
|
||||
|
||||
(report-errs)
|
||||
|
|
|
|||
Loading…
Reference in New Issue
Block a user