Parallelize running Typed Racket optimizer tests.

No speedup yet, though.

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")
+         "places.rkt" "send-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)))
@@ -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*))

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)]
+   (for/list ([p prms])
-              #:when (test-file? name))
      (make-test-suite
-      (path->string name)
+      (path->string (first p))
-      (proc name)))))
+      (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))

collects/tests/typed-racket/places.rkt

@@ -1,7 +1,8 @@
 #lang racket
 
-(require racket/place data/queue racket/async-channel)
+(require racket/place typed-racket/optimizer/logging
-(provide start-worker dr serialize-exn deserialize-exn s-exn?)
+         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 
+  (open-place ch
-    (place ch
+    (let loop ()
-           (define n (place-channel-get ch))
+      (match (place-channel-get get-ch)                
-           (define get-ch (place-channel-get ch))
+        [(vector 'log name dir res)
-           (let loop ()
+         (with-handlers ([exn:fail? 
-             (match-define (vector p* res error?) (place-channel-get get-ch))
+                          (λ (e) (place-channel-put 
-             (define-values (path p b) (split-path p*))
+                                  res 
-             (parameterize ([read-accept-reader #t]
+                                  (string-append "EXCEPTION: " (exn-message e))))])
-                            [current-load-relative-directory
+           (define lg (generate-log/place name dir))
-                             (path->complete-path path)]
+           (place-channel-put res lg))
-                            [current-directory path]
+         (loop)]
-                            [current-output-port (open-output-nowhere)]
+        [(vector p* res error?) 
-                            [error-display-handler (if error? void (error-display-handler))])
+         (define-values (path p b) (split-path p*))
-               (with-handlers ([exn? (λ (e)
+         (parameterize ([read-accept-reader #t]
-                                       (place-channel-put res (serialize-exn e)))])
+                        [current-load-relative-directory
-                 (dr p)
+                         (path->complete-path path)]
-                 (place-channel-put res #t)))
+                        [current-directory path]
-             (loop))))
+                        [current-output-port (open-output-nowhere)]
-  (place-channel-put p name)
+                        [error-display-handler (if error? void (error-display-handler))])
-  (place-channel-put p get-ch))
+           (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")))))

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 (int?)        (list (int-tests))                     '())
-                                  (if (opt?)        (list optimization-tests)            '())
+                                  (if (opt?)        (list (optimization-tests))            '())
-                                  (if (missed-opt?) (list missed-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")

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)]))