suzanne.soy/racket
1
0
Fork 0
Code Issues Pull Requests Actions Packages Projects Releases Wiki Activity

improve parallel testing

Browse Source 
svn: r5548
This commit is contained in:
Matthew Flatt 2007-02-03 22:15:36 +00:00
parent 40c6593a36
commit 126ff2a91a
6 changed files with 99 additions and 97 deletions
Show Stats Download Patch File Download Diff File Expand all files Collapse all files

104
collects/tests/mzscheme/parallel.ss
View File

@ -3,12 +3,9 @@
;; thread creates a directory sub<n> to run in, so that filesystem ;; thread creates a directory sub<n> to run in, so that filesystem
;; tests don't collide. ;; tests don't collide.
(with-handlers ([exn:fail? (namespace-variable-value 'parallel-load #f
(lambda (exn) (lambda ()
(namespace-set-variable-value! (namespace-set-variable-value! 'parallel-load "quiet.ss")))
'parallel-load
"quiet.ss"))])
(namespace-variable-value 'parallel-load))
(define in-shared-k #f) (define in-shared-k #f)
;; Some threads start with the ;; Some threads start with the
@ -24,63 +21,55 @@
; Runs n versions of test in parallel threads and namespaces, ; Runs n versions of test in parallel threads and namespaces,
; waiting until all are done ; waiting until all are done
(define (parallel n test) (define (parallel n test)
(let ([done (make-semaphore)] (let ([custodians (let loop ([n n])
[go (make-semaphore)]
[custodians (let loop ([n n])
(if (zero? n) (if (zero? n)
null null
(cons (make-custodian) (loop (sub1 n)))))]) (cons (make-custodian) (loop (sub1 n)))))]
(let loop ([n n]) [o (current-error-port)])
(unless (zero? n) (define threads
(let ([ns (make-namespace)] (let loop ([n n])
[eh (exit-handler)] (if (zero? n)
[cust (list-ref custodians (sub1 n))]) null
(parameterize ([current-custodian cust]) (cons
(thread (let ([ns (make-namespace)]
(lambda () [eh (exit-handler)]
(start [cust (list-ref custodians (sub1 n))])
n (parameterize ([current-custodian cust])
(lambda () (thread
(parameterize ([current-namespace ns] (lambda ()
[exit-handler (lambda (v) (start
(for-each (lambda (c) n
(unless (eq? c cust) (lambda ()
(custodian-shutdown-all c))) (parameterize ([current-namespace ns])
custodians) (namespace-transformer-require 'mzscheme)
(eh v))]) (eval `(define Section-prefix ,(format "~a:" n)))
(namespace-transformer-require 'mzscheme) (let ([dirname (path->complete-path (format "sub~s" n))])
(eval `(define Section-prefix ,(format "~a:" n))) (when (directory-exists? dirname)
(let ([dirname (format "sub~s" n)]) (delete-directory* dirname))
(when (directory-exists? dirname) (make-directory dirname)
(delete-directory* dirname)) (current-directory dirname)
(make-directory dirname) (parameterize ([exit-handler (lambda (v)
(current-directory dirname) (current-directory (build-path dirname 'up))
(dynamic-wind (delete-directory* dirname)
void (if (zero? v)
(lambda () ;; Shut down self:
(load test)) (custodian-shutdown-all cust)
(lambda () (begin
(semaphore-post done) ;; Shut down all the others:
(semaphore-wait go) (for-each (lambda (c)
(printf "~nThread ~s:" n) (unless (eq? c cust)
(eval '(report-errs)) (custodian-shutdown-all c)))
(current-directory (build-path 'up)) custodians)
(delete-directory* dirname) ;; Exit whole process:
(semaphore-post done)))))))))) (eh v))))])
(loop (sub1 n))))) (load test)
(exit 0))))))))))
(loop (sub1 n))))))
(with-handlers ([exn? (lambda (exn) (with-handlers ([exn? (lambda (exn)
(for-each custodian-shutdown-all (for-each custodian-shutdown-all
custodians) custodians)
(raise exn))]) (raise exn))])
(let loop ([n n]) (for-each sync threads))))
(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)))))))
(define (delete-directory* dir) (define (delete-directory* dir)
(for-each (lambda (f) (for-each (lambda (f)
@ -92,3 +81,4 @@
(delete-directory dir)) (delete-directory dir))
(parallel 3 (path->complete-path parallel-load (current-load-relative-directory))) (parallel 3 (path->complete-path parallel-load (current-load-relative-directory)))
(exit 0)

2
collects/tests/mzscheme/quiet.ss
View File

@ -25,7 +25,7 @@
;; -- set up a timeout ;; -- set up a timeout
(thread (lambda () (thread (lambda ()
(sleep 600) (sleep 600)
(fprintf err "\n\nTIMEOUT -- ABORTING!\n") (fprintf err "\n\n~aTIMEOUT -- ABORTING!\n" Section-prefix)
(exit 3) (exit 3)
;; in case the above didn't work for some reason ;; in case the above didn't work for some reason
(sleep 60) (sleep 60)

14
collects/tests/mzscheme/sync.ss
View File

@ -490,8 +490,10 @@
[real-took (/ (abs (- (current-milliseconds) real-msecs)) 1000.0)] [real-took (/ (abs (- (current-milliseconds) real-msecs)) 1000.0)]
[boundary (/ SYNC-BUSY-DELAY 6)]) [boundary (/ SYNC-BUSY-DELAY 6)])
;; Hack. ;; Hack.
;; The following test isn't reliable, so only Matthew should see it. ;; 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))) ;; 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))))) (test busy? (lambda (a ax b c d) (> b c)) 'busy-wait? go took boundary real-took)))))
(define (test-good-waitable wrap-sema) (define (test-good-waitable wrap-sema)
@ -587,7 +589,7 @@
(thread (lambda () (thread (lambda ()
(sleep SYNC-BUSY-DELAY) (sleep SYNC-BUSY-DELAY)
(set! go? #t))) (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))) #t)))
(test-stuck-port (make-semaphore 1) semaphore-try-wait? semaphore-post) (test-stuck-port (make-semaphore 1) semaphore-try-wait? semaphore-post)
@ -706,7 +708,11 @@
[sl (lambda () [sl (lambda ()
(let loop ([n 20]) (let loop ([n 20])
(unless (zero? n) (sleep) (loop (sub1 n)))))] (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 (test #t
ok-done? ok-done?
(let loop ([tries 0][n 100]) (let loop ([tries 0][n 100])

13
collects/tests/mzscheme/testing.ss
View File

@ -278,16 +278,19 @@ transcript.
(let* ([final? (and (pair? final?) (car final?))] (let* ([final? (and (pair? final?) (car final?))]
[printf (if final? eprintf* printf)] [printf (if final? eprintf* printf)]
[ok? (null? errs)]) [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 number-of-error-tests)
number-of-tests "good expressions" number-of-tests "good expressions"
number-of-error-tests "bad 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) number-of-exn-tests)
(if ok? (if ok?
(printf "Passed all tests.\n") (printf "~aPassed all tests.\n" Section-prefix)
(begin (printf "Errors were:\n(Section (got expected (call)))\n") (begin (printf "~aErrors were:\n~a(Section (got expected (call)))\n"
(for-each (lambda (l) (printf "~s\n" l)) (reverse errs)) Section-prefix Section-prefix)
(for-each (lambda (l) (printf "~a~s\n" Section-prefix l)) (reverse errs))
(when final? (exit 1)))) (when final? (exit 1))))
(when final? (exit (if ok? 0 1))) (when final? (exit (if ok? 0 1)))
(printf "(Other messages report successful tests of~a.)\n" (printf "(Other messages report successful tests of~a.)\n"

57
collects/tests/mzscheme/thread.ss
View File

@ -22,40 +22,41 @@
(define (test-set-balance as bs cs ds (define (test-set-balance as bs cs ds
sa sb sc sd sa sb sc sd
a% b% c% d%) a% b% c% d%)
(let ([a (box 0)] (when (equal? "" Section-prefix)
[b (box 0)] (let ([a (box 0)]
[c (box 0)] [b (box 0)]
[d (box 0)] [c (box 0)]
[stop? #f]) [d (box 0)]
[stop? #f])
(define (go box s s-amt) (define (go box s s-amt)
(parameterize ([current-thread-group s]) (parameterize ([current-thread-group s])
(thread (lambda () (thread (lambda ()
(let loop () (let loop ()
(set-box! box (add1 (unbox box))) (set-box! box (add1 (unbox box)))
(sleep s-amt) (sleep s-amt)
(unless stop? (unless stop?
(loop))))))) (loop)))))))
(go a as sa) (go a as sa)
(go b bs sb) (go b bs sb)
(go c cs sc) (go c cs sc)
(go d ds sd) (go d ds sd)
(sleep SLEEP-TIME) (sleep SLEEP-TIME)
(set! stop? #t) (set! stop? #t)
(let ([va (/ (unbox a) a%)] (let ([va (/ (unbox a) a%)]
[vb (unbox b)] [vb (unbox b)]
[vc (unbox c)] [vc (unbox c)]
[vd (unbox d)]) [vd (unbox d)])
(define (roughly= x y) (define (roughly= x y)
(<= (* (- x 1) 0.9) y (* (+ x 1) 1.1))) (<= (* (- x 1) 0.9) y (* (+ x 1) 1.1)))
(test #t roughly= vb (* b% va)) (test #t roughly= vb (* b% va))
(test #t roughly= vc (* c% va)) (test #t roughly= vc (* c% va))
(test #t roughly= vd (* d% va))))) (test #t roughly= vd (* d% va))))))
;; Simple test: ;; Simple test:
(let ([ts (make-thread-group)]) (let ([ts (make-thread-group)])

2
collects/tests/mzscheme/threadlib.ss
View File

@ -97,3 +97,5 @@
(test #f coroutine-result w4) (test #f coroutine-result w4)
(err/rt-test (coroutine-run MAX-RUN-TIME w4) (lambda (x) (eq? x 15))) (err/rt-test (coroutine-run MAX-RUN-TIME w4) (lambda (x) (eq? x 15)))
(test #t coroutine-run 100 w4) (test #t coroutine-run 100 w4)
(report-errs)