From e705d4d450b1753a0c5fe8b34bb1a41c22e381cc Mon Sep 17 00:00:00 2001 From: Sam Tobin-Hochstadt Date: Tue, 21 Aug 2012 12:08:56 -0400 Subject: [PATCH] Parallelize running Typed Racket optimizer tests. No speedup yet, though. --- collects/tests/typed-racket/main.rkt | 23 +------ collects/tests/typed-racket/optimizer/run.rkt | 35 +++------- collects/tests/typed-racket/places.rkt | 67 +++++++++++++------ collects/tests/typed-racket/run.rkt | 6 +- collects/tests/typed-racket/send-places.rkt | 31 +++++++++ 5 files changed, 91 insertions(+), 71 deletions(-) create mode 100644 collects/tests/typed-racket/send-places.rkt diff --git a/collects/tests/typed-racket/main.rkt b/collects/tests/typed-racket/main.rkt index 0a4ccfc753..ebbd817233 100644 --- a/collects/tests/typed-racket/main.rkt +++ b/collects/tests/typed-racket/main.rkt @@ -7,9 +7,7 @@ "unit-tests/all-tests.rkt" "unit-tests/test-utils.rkt" "optimizer/run.rkt" - "places.rkt") - -(define places (make-parameter (and (place-enabled?) (min 8 (processor-count))))) + "places.rkt" "send-places.rkt") (define (scheme-file? s) (regexp-match ".*[.](rkt|ss|scm)$" (path->string s))) @@ -88,7 +86,7 @@ (check-exn pred thnk)))) #:error #t)) -(define int-tests +(define (int-tests) (test-suite "Integration tests" (succ-tests) (fail-tests))) @@ -114,23 +112,6 @@ (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*)) diff --git a/collects/tests/typed-racket/optimizer/run.rkt b/collects/tests/typed-racket/optimizer/run.rkt index 35e2db9019..b109cc00dd 100644 --- a/collects/tests/typed-racket/optimizer/run.rkt +++ b/collects/tests/typed-racket/optimizer/run.rkt @@ -1,30 +1,13 @@ #lang racket (require racket/runtime-path compiler/compiler rackunit rackunit/text-ui - typed-racket/optimizer/logging) + typed-racket/optimizer/logging + "../send-places.rkt") (provide optimization-tests missed-optimization-tests test-opt test-missed-optimization test-file? generate-log tests-dir missed-optimizations-dir) -(define comp (compile-zos #f #:module? #t)) - -(define (generate-log name dir) - ;; some tests require other tests, so some fiddling is required - (define f (build-path dir name)) - (with-output-to-string - (lambda () - (with-tr-logging-to-port - (current-output-port) - (lambda () - (comp (list f) 'auto))) - (parameterize - ([current-namespace (make-base-empty-namespace)] - [current-load-relative-directory dir]) - (dynamic-require f #f)) - ;; clean up compiled files in prevision of the next testing run - (delete-directory/files (build-path dir "compiled"))))) - ;; we log optimizations and compare to an expected log to make sure that all ;; the optimizations we expected did indeed happen (define (compare-logs name dir) @@ -59,15 +42,17 @@ ;; proc returns the list of tests to be run on each file (define (mk-suite suite-name dir proc) + (define prms (for/list ([name (directory-list dir)] + #:when (test-file? name)) + (list name (delay/thread (proc name))))) (make-test-suite suite-name - (for/list ([name (directory-list dir)] - #:when (test-file? name)) + (for/list ([p prms]) (make-test-suite - (path->string name) - (proc name))))) + (path->string (first p)) + (force (second p)))))) -(define optimization-tests +(define (optimization-tests) (mk-suite "Optimization Tests" tests-dir test-opt)) -(define missed-optimization-tests +(define (missed-optimization-tests) (mk-suite "Missed Optimization Tests" missed-optimizations-dir test-missed-optimization)) diff --git a/collects/tests/typed-racket/places.rkt b/collects/tests/typed-racket/places.rkt index 09c0e67466..8eaeadbd24 100644 --- a/collects/tests/typed-racket/places.rkt +++ b/collects/tests/typed-racket/places.rkt @@ -1,7 +1,8 @@ #lang racket -(require racket/place data/queue racket/async-channel) -(provide start-worker dr serialize-exn deserialize-exn s-exn?) +(require racket/place typed-racket/optimizer/logging + unstable/open-place compiler/compiler) +(provide start-worker dr serialize-exn deserialize-exn s-exn? generate-log/place) (struct s-exn (message) #:prefab) (struct s-exn:fail s-exn () #:prefab) (struct s-exn:fail:syntax s-exn:fail (exprs) #:prefab) @@ -32,23 +33,45 @@ (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 + (open-place ch + (let loop () + (match (place-channel-get get-ch) + [(vector 'log name dir res) + (with-handlers ([exn:fail? + (λ (e) (place-channel-put + res + (string-append "EXCEPTION: " (exn-message e))))]) + (define lg (generate-log/place name dir)) + (place-channel-put res lg)) + (loop)] + [(vector p* res error?) + (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)])))) + +(define comp (compile-zos #f #:module? #t)) + +(define (generate-log/place name dir) + ;; some tests require other tests, so some fiddling is required + (define f (build-path dir name)) + (with-output-to-string + (lambda () + (with-tr-logging-to-port + (current-output-port) + (lambda () + (comp (list f) 'auto))) + (parameterize + ([current-namespace (make-base-empty-namespace)] + [current-load-relative-directory dir]) + (dynamic-require f #f)) + ;; clean up compiled files in prevision of the next testing run + (delete-directory/files (build-path dir "compiled"))))) diff --git a/collects/tests/typed-racket/run.rkt b/collects/tests/typed-racket/run.rkt index 0309de6c65..103b5d5709 100644 --- a/collects/tests/typed-racket/run.rkt +++ b/collects/tests/typed-racket/run.rkt @@ -39,9 +39,9 @@ (make-test-suite "Typed Racket Tests" (append (if (unit?) (list unit-tests) '()) - (if (int?) (list int-tests) '()) - (if (opt?) (list optimization-tests) '()) - (if (missed-opt?) (list missed-optimization-tests) '()) + (if (int?) (list (int-tests)) '()) + (if (opt?) (list (optimization-tests)) '()) + (if (missed-opt?) (list (missed-optimization-tests)) '()) (if (bench?) (list (compile-benchmarks)) '())))])]) (unless (= 0 ((exec) to-run)) (eprintf "Typed Racket Tests did not pass.\n") diff --git a/collects/tests/typed-racket/send-places.rkt b/collects/tests/typed-racket/send-places.rkt new file mode 100644 index 0000000000..ce7fcd164c --- /dev/null +++ b/collects/tests/typed-racket/send-places.rkt @@ -0,0 +1,31 @@ +#lang racket + +(require "places.rkt") + +(require racket/place data/queue racket/async-channel) +(provide generate-log start-workers run-in-other-place places) + +(define places (make-parameter (and (place-enabled?) (min 8 (processor-count))))) + +(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 (generate-log name dir) + (cond [(places) + (define-values (res-ch res-ch*) (place-channel)) + (place-channel-put enq-ch (vector 'log name dir res-ch*)) + (place-channel-get res-ch)] + [else + (generate-log/place name dir)])) \ No newline at end of file