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

parallelize the contract tests

Browse Source 
(unfortunately, the speedup is not that great)
This commit is contained in:
Robby Findler 2013-07-21 14:50:35 -05:00
parent 72544723b5
commit bf73928892
1 changed files with 118 additions and 3 deletions
Show Stats Download Patch File Download Diff File Expand all files Collapse all files

121
pkgs/racket-pkgs/racket-test/tests/racket/contract/all.rkt
View File

@ -1,6 +1,79 @@
#lang racket/base
(require (for-syntax racket/base)
racket/place
"test-util.rkt")
(define parallel 1)
(let ([argv (current-command-line-arguments)])
(unless (= (vector-length argv) 0)
(define howmany (vector-ref argv 0))
(if (string->number howmany)
(set! parallel (string->number howmany))
(raise-user-error 'all.rkt "expected a number on the command-line got ~a" howmany))))
(module capturing-io racket/base
(provide capture-io)
(define (capture-io thunk)
(define-values (out-stdout in-stdout) (make-pipe))
(define-values (out-stderr in-stderr) (make-pipe))
(define out-char (make-channel))
(define in-char (make-channel))
(define io-done-chan (make-channel))
(define (mk-listen-loop port what chan)
(thread (λ ()
(let loop ()
(define c (read-char port))
(unless (eof-object? c)
(channel-put chan (cons what c))
(loop)))
(channel-put io-done-chan #t))))
(mk-listen-loop out-stdout 'out out-char)
(mk-listen-loop out-stderr 'err out-char)
(define done-chan (make-channel))
(thread
(λ ()
(let loop ([chars '()])
(sync
(handle-evt
out-char
(λ (c)
(loop (cons c chars))))
(handle-evt
done-chan
(λ (c) (channel-put c (reverse chars))))))))
(let/ec k
(parameterize ([current-output-port in-stdout]
[current-error-port in-stderr]
[error-escape-handler k])
(thunk)))
(close-output-port in-stdout)
(close-output-port in-stderr)
(channel-get io-done-chan)
(channel-get io-done-chan)
(let ([c (make-channel)])
(channel-put done-chan c)
(channel-get c))))
(require (submod "." capturing-io))
(module run-one racket/base
(provide run-one)
(require racket/place (submod ".." capturing-io))
(define (run-one chan)
(let loop ()
(define fn (place-channel-get chan))
(when fn
(define io
(capture-io
(λ ()
(dynamic-require (car fn) #f))))
(place-channel-put chan io)
(loop)))))
(define places
(and (not (= 1 parallel))
(for/list ([i (in-range parallel)])
(dynamic-place `(submod ,(build-path (this-dir) "all.rkt") run-one) 'run-one))))
(define-syntax (this-dir stx)
(define src (syntax-source stx))
(cond
@ -65,10 +138,52 @@
dep<?
#:key cadr))
(for ([file (in-list files-to-run)])
(printf "RUNNING: ~a ~s\n" (car file) (cadr file))
(dynamic-require (build-path (this-dir) (car file)) #f))
(define (main)
(cond
[places
(struct running (pc to-run resp-chan))
(let loop ([runnings '()]
[free places]
[to-run files-to-run])
(cond
[(and (pair? free) (pair? to-run))
(define c (make-channel))
(define pc (car free))
(thread (λ ()
(place-channel-put pc (car to-run))
(channel-put c (place-channel-get pc))))
(loop (cons (running pc (car to-run) c) runnings)
(cdr free)
(cdr to-run))]
[(null? runnings)
(void)]
[else
(apply sync
(map (λ (a-running)
(handle-evt
(running-resp-chan a-running)
(λ (io)
(replay-io (running-to-run a-running) io)
(loop (remove a-running runnings)
(cons (running-pc a-running) free)
to-run))))
runnings))]))]
[else
(for ([file (in-list files-to-run)])
(replay-io
(capture-io
(λ ()
(dynamic-require (build-path (this-dir) (car file)) #f)))))]))
(define (replay-io file-to-run io)
(printf "FINISHED ~a\n" (car file-to-run))
(for ([pr (in-list io)])
(display (cdr pr)
((case (car pr)
[(out) current-output-port]
[(err) current-error-port])))))
(main)
(fprintf (if (zero? failures)
(current-output-port)
(current-error-port))