73 lines
2.0 KiB
Scheme
73 lines
2.0 KiB
Scheme
|
|
;; Runs 3 threads perfoming the test suite simultaneously. Each
|
|
;; 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))
|
|
|
|
(define (start x) (x))
|
|
|
|
;; Uncomment the following expression to have threads start with the
|
|
;; same continuation, which forces sharing of the Scheme stack:
|
|
#;
|
|
(thread-wait
|
|
(thread (lambda () ((let/cc k (set! start k) void)))))
|
|
|
|
; 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)])
|
|
(let loop ([n n])
|
|
(unless (zero? n)
|
|
(let ([ns (make-namespace)])
|
|
(thread
|
|
(lambda ()
|
|
(start
|
|
(lambda ()
|
|
(parameterize ([current-namespace ns])
|
|
(namespace-transformer-require 'mzscheme)
|
|
(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)))))
|
|
(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))))))
|
|
|
|
(define (delete-directory* dir)
|
|
(for-each (lambda (f)
|
|
(let ([f (build-path dir f)])
|
|
(if (or (link-exists? f) (file-exists? f))
|
|
(delete-file f)
|
|
(delete-directory* f))))
|
|
(directory-list dir))
|
|
(delete-directory dir))
|
|
|
|
(parallel 3 (path->complete-path parallel-load (current-load-relative-directory)))
|