From 70e671189e57f51e1215519158dfac66ce10ed50 Mon Sep 17 00:00:00 2001 From: Eric Dobson Date: Sat, 22 Jun 2013 16:15:36 -0700 Subject: [PATCH] Make benchmark code run in parallel. original commit: bda8c24d2c52af4688148db6646ede46439ec6aa --- .../tests/typed-racket/main.rkt | 23 +++++++++++------- .../tests/typed-racket/places.rkt | 14 ++++++++++- .../tests/typed-racket/send-places.rkt | 24 +++++++++++++------ 3 files changed, 44 insertions(+), 17 deletions(-) diff --git a/pkgs/typed-racket-pkgs/typed-racket-test/tests/typed-racket/main.rkt b/pkgs/typed-racket-pkgs/typed-racket-test/tests/typed-racket/main.rkt index 5674cb54..4df46399 100644 --- a/pkgs/typed-racket-pkgs/typed-racket-test/tests/typed-racket/main.rkt +++ b/pkgs/typed-racket-pkgs/typed-racket-test/tests/typed-racket/main.rkt @@ -54,7 +54,8 @@ (define p* (build-path path p)) (define prm (list path p (if (places) - (run-in-other-place p* error?) + (delay/thread + (run-in-other-place p* error?)) (delay (parameterize ([read-accept-reader #t] [current-load-relative-directory path] @@ -96,14 +97,18 @@ (define shootout (collection-path "tests" "racket" "benchmarks" "shootout" "typed")) (define common (collection-path "tests" "racket" "benchmarks" "common" "typed")) (define (mk dir) - (make-test-suite (path->string dir) - (for/list ([file (in-list (directory-list dir))] - #:when (scheme-file? file)) - (test-suite (path->string file) - (check-not-exn (λ () - (get-module-code (build-path dir file) - #:choose (lambda (src zo so) 'src)))))))) - (test-suite "compiling" + (let ((promised-results + (for/hash ([file (in-list (directory-list dir))] + #:when (scheme-file? file)) + (values (path->string file) + (delay/thread (compile-path (build-path dir file))))))) + (make-test-suite (path->string dir) + (for/list ([(name results) promised-results]) + (test-suite name + (check-not-exn (λ () (force results)))))))) + + + (test-suite "Compiling Benchmark tests" (mk shootout) (mk common))) diff --git a/pkgs/typed-racket-pkgs/typed-racket-test/tests/typed-racket/places.rkt b/pkgs/typed-racket-pkgs/typed-racket-test/tests/typed-racket/places.rkt index 939578ac..0520a735 100644 --- a/pkgs/typed-racket-pkgs/typed-racket-test/tests/typed-racket/places.rkt +++ b/pkgs/typed-racket-pkgs/typed-racket-test/tests/typed-racket/places.rkt @@ -2,7 +2,7 @@ (require racket/place typed-racket/optimizer/logging unstable/open-place syntax/modcode data/queue) -(provide start-worker dr serialize-exn deserialize-exn s-exn? generate-log/place verbose?) +(provide start-worker dr serialize-exn deserialize-exn s-exn? generate-log/place compile-path/place verbose?) (define verbose? (make-parameter #f)) @@ -50,6 +50,12 @@ (define lg (generate-log/place name dir)) (place-channel-put res lg)) (loop)] + [(vector 'compile path res) + (with-handlers ([exn:fail? + (λ (e) (place-channel-put res (serialize-exn e)))]) + (compile-path/place path) + (place-channel-put res (void))) + (loop)] [(vector p* res error?) (define-values (path p b) (split-path p*)) (with-handlers ([exn? (λ (e) (place-channel-put res (serialize-exn e)))]) @@ -63,6 +69,12 @@ (place-channel-put res #t))) (loop)])))) +(define (compile-path/place path) + (get-module-code + path + #:choose (lambda (src zo so) 'src))) + + (define-namespace-anchor anchor) (define (generate-log/place name dir) diff --git a/pkgs/typed-racket-pkgs/typed-racket-test/tests/typed-racket/send-places.rkt b/pkgs/typed-racket-pkgs/typed-racket-test/tests/typed-racket/send-places.rkt index 4470c8be..a129f5c1 100644 --- a/pkgs/typed-racket-pkgs/typed-racket-test/tests/typed-racket/send-places.rkt +++ b/pkgs/typed-racket-pkgs/typed-racket-test/tests/typed-racket/send-places.rkt @@ -3,7 +3,7 @@ (require "places.rkt") (require racket/place data/queue racket/async-channel) -(provide generate-log start-workers run-in-other-place places verbose?) +(provide generate-log start-workers run-in-other-place places verbose? compile-path) (define places (make-parameter (and (place-enabled?) (min 8 (processor-count))))) @@ -13,18 +13,17 @@ (for ([i (places)]) (start-worker deq-ch i)))) -(define (run-in-other-place p* [error? #f]) +(define (run-in-other-place p* error?) (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 res (place-channel-get res-ch)) + (when (s-exn? res) + (raise (deserialize-exn res)))) (define (generate-log name dir) (apply values - (cond [(places) + (cond [(places) (define-values (res-ch res-ch*) (place-channel)) (place-channel-put enq-ch (vector 'log name dir res-ch*)) (define res (place-channel-get res-ch)) @@ -33,3 +32,14 @@ res)] [else (generate-log/place name dir)]))) + +(define (compile-path file) + (cond [(places) + (define-values (res-ch res-ch*) (place-channel)) + (place-channel-put enq-ch (vector 'compile file res-ch*)) + (define res (place-channel-get res-ch)) + (if (s-exn? res) + (raise (deserialize-exn res)) + res)] + [else + (compile-path/place file)]))