diff --git a/collects/tests/typed-racket/main.rkt b/collects/tests/typed-racket/main.rkt index 596e285b..d645ab74 100644 --- a/collects/tests/typed-racket/main.rkt +++ b/collects/tests/typed-racket/main.rkt @@ -1,12 +1,15 @@ -#lang scheme/base +#lang racket/base (require rackunit rackunit/text-ui racket/file - mzlib/etc scheme/port - compiler/compiler - scheme/match mzlib/compile + mzlib/etc racket/port + compiler/compiler racket/promise + racket/match mzlib/compile "unit-tests/all-tests.rkt" "unit-tests/test-utils.rkt" - "optimizer/run.rkt") + "optimizer/run.rkt" + "places.rkt") + +(define places (make-parameter (and (place-enabled?) (min 8 (processor-count))))) (define (scheme-file? s) (regexp-match ".*[.](rkt|ss|scm)$" (path->string s))) @@ -43,41 +46,47 @@ [_ (exn-matches ".*Type Checker.*" exn:fail:syntax?)]))) -(define (mk-tests dir loader test) +(define (mk-tests dir test #:error [error? #f]) (lambda () (define path (build-path (this-expression-source-directory) dir)) - (define tests + (define prms (for/list ([p (directory-list path)] #:when (scheme-file? p) ;; skip backup files #:when (not (regexp-match #rx".*~" (path->string p)))) + (define p* (build-path path p)) + (define prm (list path p + (if (places) + (run-in-other-place p* error?) + (delay + (parameterize ([read-accept-reader #t] + [current-load-relative-directory path] + [current-directory path] + [current-output-port (open-output-nowhere)]) + (dr p)))))) + prm)) + (define tests + (for/list ([e prms]) + (match-define (list path p prm) e) (test-suite (path->string p) (test (build-path path p) - (lambda () - (parameterize ([read-accept-reader #t] - [current-load-relative-directory path] - [current-directory path] - [current-output-port (open-output-nowhere)]) - (loader p))))))) - (make-test-suite dir tests))) - -(define (dr p) - (parameterize ([current-namespace (make-base-empty-namespace)]) - (dynamic-require `(file ,(if (string? p) p (path->string p))) #f))) + (λ () + (force prm)))))) + (make-test-suite dir tests))) (define succ-tests (mk-tests "succeed" - dr - (lambda (p thnk) (check-not-exn thnk)))) + (lambda (p thnk) + (check-not-exn thnk)))) (define fail-tests (mk-tests "fail" - dr (lambda (p thnk) (define-values (pred info) (exn-pred p)) (parameterize ([error-display-handler void]) (with-check-info (['predicates info]) - (check-exn pred thnk)))))) + (check-exn pred thnk)))) + #:error #t)) (define int-tests (test-suite "Integration tests" @@ -105,6 +114,23 @@ (mk common) (delete-directory/files (build-path common "compiled")))) +(require racket/place data/queue racket/async-channel) + + +(define-values (enq-ch deq-ch) (place-channel)) +(define (start-workers) + (when (places) + (for ([i (places)]) + (start-worker deq-ch i)))) + +(define (run-in-other-place p* [error? #f]) + (define-values (res-ch res-ch*) (place-channel)) + (place-channel-put enq-ch (vector p* res-ch* error?)) + (delay/thread + (define res (place-channel-get res-ch)) + (when (s-exn? res) + (raise (deserialize-exn res))))) + (define (just-one p*) (define-values (path p b) (split-path p*)) @@ -128,6 +154,8 @@ (f (build-path path p) (lambda () + (force (run-in-other-place p*)) + #; (parameterize ([read-accept-reader #t] [current-load-relative-directory (path->complete-path path)] @@ -139,6 +167,6 @@ (define (go tests) (test/gui tests)) (define (go/text tests) (run-tests tests 'verbose)) -(provide go go/text just-one +(provide go go/text just-one places start-workers int-tests unit-tests compile-benchmarks optimization-tests missed-optimization-tests) diff --git a/collects/tests/typed-racket/places.rkt b/collects/tests/typed-racket/places.rkt new file mode 100644 index 00000000..09c0e674 --- /dev/null +++ b/collects/tests/typed-racket/places.rkt @@ -0,0 +1,54 @@ +#lang racket + +(require racket/place data/queue racket/async-channel) +(provide start-worker dr serialize-exn deserialize-exn s-exn?) +(struct s-exn (message) #:prefab) +(struct s-exn:fail s-exn () #:prefab) +(struct s-exn:fail:syntax s-exn:fail (exprs) #:prefab) +(struct s-exn:fail:contract s-exn:fail () #:prefab) +(define (serialize-exn e) + (match e + [(exn:fail:syntax msg _ exprs) + (s-exn:fail:syntax msg (map syntax->datum exprs))] + [(exn:fail:contract msg _) + (s-exn:fail:contract msg)] + [(exn:fail msg _) + (s-exn:fail msg)] + [(exn msg _) + (s-exn msg)])) +(define (deserialize-exn e) + (match e + [(s-exn:fail:syntax msg exprs) + (exn:fail:syntax msg (current-continuation-marks) + (map (λ (e) (datum->syntax #f e)) exprs))] + [(s-exn:fail:contract m) + (exn:fail:contract m (current-continuation-marks))] + [(s-exn:fail m) + (exn:fail m (current-continuation-marks))] + [(s-exn m) + (exn m (current-continuation-marks))])) +(define (dr p) + (parameterize ([current-namespace (make-base-empty-namespace)]) + (dynamic-require `(file ,(if (string? p) p (path->string p))) #f))) + +(define (start-worker get-ch name) + (define p + (place ch + (define n (place-channel-get ch)) + (define get-ch (place-channel-get ch)) + (let loop () + (match-define (vector p* res error?) (place-channel-get get-ch)) + (define-values (path p b) (split-path p*)) + (parameterize ([read-accept-reader #t] + [current-load-relative-directory + (path->complete-path path)] + [current-directory path] + [current-output-port (open-output-nowhere)] + [error-display-handler (if error? void (error-display-handler))]) + (with-handlers ([exn? (λ (e) + (place-channel-put res (serialize-exn e)))]) + (dr p) + (place-channel-put res #t))) + (loop)))) + (place-channel-put p name) + (place-channel-put p get-ch)) \ No newline at end of file diff --git a/collects/tests/typed-racket/run.rkt b/collects/tests/typed-racket/run.rkt index a8a7880e..0309de6c 100644 --- a/collects/tests/typed-racket/run.rkt +++ b/collects/tests/typed-racket/run.rkt @@ -20,13 +20,18 @@ ["--missed-opt" "run the missed optimization tests" (missed-opt? #t)] ["--benchmarks" "compile the typed benchmarks" (bench? #t)] ["--just" path "run only this test" (single (just-one path))] - ["--nightly" "for the nightly builds" (begin (nightly? #t) (unit? #t) (opt? #t) (missed-opt? #t))] + ["--nightly" "for the nightly builds" (begin (nightly? #t) (unit? #t) (opt? #t) (missed-opt? #t) (places 1))] ["--all" "run all tests" (begin (unit? #t) (int? #t) (opt? #t) (missed-opt? #t) (bench? #t))] + ["-j" num "number of places to use" + (let ([n (string->number num)]) + (places (and (integer? n) (> n 1) n)))] ["--gui" "run using the gui" (if (gui-available?) (begin (exec go)) (error "GUI not available"))]) +(start-workers) + (if (and (nightly?) (eq? 'cgc (system-type 'gc))) (printf "Skipping Typed Racket tests.\n") (let ([to-run (cond [(single) (single)]