From 126ff2a91a96805871bde17e8363cf352625a0ca Mon Sep 17 00:00:00 2001 From: Matthew Flatt Date: Sat, 3 Feb 2007 22:15:36 +0000 Subject: [PATCH] improve parallel testing svn: r5548 --- collects/tests/mzscheme/parallel.ss | 104 ++++++++++++--------------- collects/tests/mzscheme/quiet.ss | 2 +- collects/tests/mzscheme/sync.ss | 14 ++-- collects/tests/mzscheme/testing.ss | 13 ++-- collects/tests/mzscheme/thread.ss | 61 ++++++++-------- collects/tests/mzscheme/threadlib.ss | 2 + 6 files changed, 99 insertions(+), 97 deletions(-) diff --git a/collects/tests/mzscheme/parallel.ss b/collects/tests/mzscheme/parallel.ss index c3810a65da..e22427795d 100644 --- a/collects/tests/mzscheme/parallel.ss +++ b/collects/tests/mzscheme/parallel.ss @@ -3,12 +3,9 @@ ;; thread creates a directory sub 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) diff --git a/collects/tests/mzscheme/quiet.ss b/collects/tests/mzscheme/quiet.ss index ee51f0f543..311a258b3e 100644 --- a/collects/tests/mzscheme/quiet.ss +++ b/collects/tests/mzscheme/quiet.ss @@ -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) diff --git a/collects/tests/mzscheme/sync.ss b/collects/tests/mzscheme/sync.ss index 78ab4a5512..251ddb409f 100644 --- a/collects/tests/mzscheme/sync.ss +++ b/collects/tests/mzscheme/sync.ss @@ -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]) diff --git a/collects/tests/mzscheme/testing.ss b/collects/tests/mzscheme/testing.ss index 9db7e6d49d..6d5061f450 100644 --- a/collects/tests/mzscheme/testing.ss +++ b/collects/tests/mzscheme/testing.ss @@ -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" diff --git a/collects/tests/mzscheme/thread.ss b/collects/tests/mzscheme/thread.ss index 26edc83ea3..0929a6fb1a 100644 --- a/collects/tests/mzscheme/thread.ss +++ b/collects/tests/mzscheme/thread.ss @@ -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)]) diff --git a/collects/tests/mzscheme/threadlib.ss b/collects/tests/mzscheme/threadlib.ss index 289792ef67..27b80695a1 100644 --- a/collects/tests/mzscheme/threadlib.ss +++ b/collects/tests/mzscheme/threadlib.ss @@ -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)