raco make -j

collects/compiler/commands/make.rkt

@@ -3,7 +3,9 @@
          raco/command-name
          compiler/cm
          "../compiler.ss"
-         dynext/file)
+         dynext/file
+         setup/parallel-build
+         racket/match)
 
 (define verbose (make-parameter #f))
 (define very-verbose (make-parameter #f))
@@ -12,6 +14,7 @@
 (define disable-deps (make-parameter #f))
 (define prefixes (make-parameter null))
 (define assume-primitives (make-parameter #t))
+(define worker-count (make-parameter 1))
 
 (define source-files
   (command-line
@@ -27,13 +30,15 @@
     (assume-primitives #f)]
    [("-v") "Verbose mode"
     (verbose #t)]
+   [("-j") wc "Parallel job count" (worker-count (string->number wc))]
    [("--vv") "Very verbose mode"
     (verbose #t)
     (very-verbose #t)]
    #:args (file . another-file) (cons file another-file)))
 
-(if (disable-deps)
+(cond 
   ;; Just compile one file:
+  [(disable-deps)
     (let ([prefix
            `(begin
               (require scheme)
@@ -45,8 +50,9 @@
               (void))])
       ((compile-zos prefix #:verbose? (verbose))
        source-files
-       'auto))
+       'auto))]
   ;; Normal make:
+  [(= (worker-count) 1)
     (let ([n (make-base-empty-namespace)]
           [did-one? #f])
       (parameterize ([current-namespace n]
@@ -76,4 +82,11 @@
               (when (verbose)
                 (printf " [~a \"~a\"]\n"
                         (if did-one? "output to" "already up-to-date at")
-                        dest))))))))
+                        dest)))))))]
+  ;; Parallel make:
+  [else (parallel-compile-files source-files #:worker-count (worker-count)
+    #:handler (lambda (type work msg out err)
+      (match type
+        ['done (when (verbose) (printf " Made ~a\n" work))]
+        ['output (printf " Output from: ~a\n~a~a" work out err)]
+        [else (printf " Error compiling ~a\n~a\n~a~a" work msg out err)])))])

collects/scribblings/raco/make.scrbl

@@ -7,7 +7,9 @@
                      racket/include
                      racket/contract
                      compiler/cm
-                     compiler/cm-accomplice))
+                     compiler/cm-accomplice
+                     setup/parallel-build))
+
 
 @(define cm-eval (make-base-eval))
 @(interaction-eval #:eval cm-eval (require compiler/cm))
@@ -356,6 +358,66 @@ parallel builder should continue without compiling @racket[zo-path].
 }
 @; ----------------------------------------------------------------------
 
+@section[#:tag "api:parallel-build"]{API for Parallel-Build}
+
+@defmodule[setup/parallel-build]{
+
+The @schememodname[setup/parallel-build] library provides the parallel compilation to bytecode
+functionality of @exec{rack setup} and @exec{rack make}.}
+
+@; ----------------------------------------------------------------------
+
+
+@defproc[(parallel-compile-files [list-of-files (listof path?)] 
+  [#:worker-count worker-count non-negative-integer?] 
+  [#:handler handler ([handler-type symbol?]
+                      [path path-string?]
+                      [msg string?] 
+                      [out string?] 
+                      [err string?] -> void?)]) void?]{
+
+The @racket[parallel-compile] utility function is used by @exec{rack make} to
+compile a list of paths in parallel.  The optional keyword argument
+@racket[#:worker-count] specifies the number of compile workers to spawn during
+parallel compilation.  The callback, @racket[handler], is called with type
+@racket['done] for each successfully compiled file, @racket['output] when a
+successful compilation produces stdout/stderr output, @racket['error] when a
+compilation error has occured, or @racket['fatal-error] when a unrecoverable
+error occurs.
+ 
+  @racketblock[
+    (parallel-compile-files 
+      source-files 
+      #:worker-count 4
+      #:handler (lambda (type work msg out err)
+        (match type
+          ['done (when (verbose) (printf " Made ~a\n" work))]
+          ['output (printf " Output from: ~a\n~a~a" work out err)]
+          [else (printf " Error compiling ~a\n~a\n~a~a"
+                        work 
+                        msg 
+                        out 
+                        err)])))]
+}
+
+@defproc[(parallel-compile 
+  [worker-count non-negative-integer?] 
+  [setup-fprintf (->* ([stage string?] [format string?]) 
+                      () 
+                      #:rest (listof any/c) void)]
+  [append-error (cc? [prefix string?] [exn (or/c exn? null?)] [out string?] [err srtring?] [message string?] . -> . void?)]
+  [collects-tree (listof any/c)])  (void)]{
+
+The @racket[parallel-compile] internal utility function is used by @exec{rack
+setup} to compile collects in parallel.  The @racket[worker-count] argument
+specifies the number of compile workers to spawn during parallel compilation.
+The @racket[setup-fprintf] and @racket[append-error] functions are internal
+callback mechanisms that @exec{rack setup} uses to communicate intermediate
+compilation results.  The @racket[collects-tree] argument is a compound
+datastructure containing an in-memory tree representation of the collects
+directory.
+}
+
 @section{Compilation Manager Hook for Syntax Transformers}
 
 @defmodule[compiler/cm-accomplice]

collects/setup/parallel-build.rkt

@@ -6,9 +6,11 @@
          racket/path
          setup/collects
          setup/parallel-do
-         racket/class)
+         racket/class
+         racket/future)
 
-(provide parallel-compile)
+(provide parallel-compile
+         parallel-compile-files)
 
 
 (define Lock-Manager% (class object%
@@ -34,8 +36,12 @@
   (lm/lock lock fn wrkr)
   (lm/unlock unlock fn))
 
+(define (->bytes x)
+  (cond [(path? x) (path->bytes x)]
+        [(string? x) (string->bytes/locale x)]))
+
 (define CollectsQueue% (class* object% (WorkQueue<%>) 
-  (init-field cclst collects-dir printer append-error)
+  (init-field cclst printer append-error)
   (field (lock-mgr (new Lock-Manager%)))
   (field (hash (make-hash)))
   (inspect #f)
@@ -89,14 +95,11 @@
             (list h)]))
       (let ([w-hash hash])
         (define (build-job cc file last)
-          (define (->bytes x)
-            (cond [(path? x) (path->bytes x)]
-                  [(string? x) (string->bytes/locale x)]))
           (let* ([cc-name (cc-name cc)]
                  [cc-path (cc-path cc)]
                  [full-path (path->string (build-path cc-path file))])
             ;(printf "JOB ~a ~a ~a ~a\n" workerid cc-name cc-path file)
-            (values (list cc file last) (list cc-name (->bytes cc-path) (->bytes file)))))
+            (values (list cc file last) (list (->bytes cc-name) (->bytes cc-path) (->bytes file)))))
         (let retry ()
           (define (find-job-in-cc cc id)
             (match cc
@@ -144,15 +147,61 @@
     (define/public (get-results) (void))
     (super-new)))
 
+(define FileListQueue% (class* object% (WorkQueue<%>) 
+  (init-field filelist handler)
+  (field (lock-mgr (new Lock-Manager%)))
+  (inspect #f)
+
+  (define/public (work-done work wrkr msg)
+    (match msg
+      [(list result-type out err)
+        (match result-type
+          [(list 'LOCK fn) (lm/lock lock-mgr fn wrkr) #f]
+          [(list 'UNLOCK fn) (lm/unlock lock-mgr fn) #f]
+          [(list 'ERROR msg) (handler 'error work msg out err) #t]
+          ['DONE
+            (define (string-!empty? s) (not (zero? (string-length s))))
+            (if (ormap string-!empty? (list out err))
+              (handler 'output work "" out err)
+              (handler 'done work "" "" ""))
+            #t])]
+      [else
+        (handler 'fatalerror (format "Error matching work: ~a queue ~a" work filelist) "" "") #t]))
+         
+    (define/public (get-job workerid)
+      (match filelist
+        [(cons hd tail)
+            (define-values (dir file b) (split-path hd))
+            (set! filelist tail)
+            (values hd (list (->bytes hd) (->bytes dir) (->bytes file)))]
+        [(list) null]))
+    (define/public (has-jobs?) (not (null? filelist)))
+    (define/public (jobs-cnt) (length filelist))
+    (define/public (get-results) (void))
+    (super-new)))
+
+
+(define (build-parallel-build-worker-args)
+  (list (current-executable-path)
+        "-X"
+        (path->string (current-collects-path))
+        "-l"
+        "setup/parallel-build-worker.rkt"))
+  
+(define (parallel-compile-files list-of-files
+  #:worker-count [worker-count (processor-count)]
+  #:handler [handler (lambda args (void))])
+
+  (parallel-do-event-loop #f
+                          values ; identity function
+                          (build-parallel-build-worker-args)
+                          (make-object FileListQueue% list-of-files handler)
+                          worker-count 999999999))
+
 (define (parallel-compile worker-count setup-fprintf append-error collects-tree)
-  (let ([collects-dir (current-collects-path)]) 
   (setup-fprintf (current-output-port) #f "--- parallel build using ~a processor cores ---" worker-count)
   (parallel-do-event-loop #f
                           values ; identity function
-                            (list (current-executable-path)
+                          (build-parallel-build-worker-args)
-                                  "-X"
+                          (make-object CollectsQueue% collects-tree setup-fprintf append-error)
-                                  (path->string collects-dir)
+                          worker-count 999999999))
-                                  "-l"
-                                  "setup/parallel-build-worker.rkt")
-                            (make-object CollectsQueue% collects-tree collects-dir setup-fprintf append-error)
-                            worker-count 999999999)))