Make Typed Racket integration tests run in parallel.

Parallel speedup of approximately 4x when using 8 workers on a 12-core machine.

Closes PR 12911.

original commit: 9e5060ef5b7e831480e82d45eb7459d1015f1f54

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)

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

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