diff --git a/collects/compiler/commands/make.rkt b/collects/compiler/commands/make.rkt index 5cfd96af01..03dd574409 100644 --- a/collects/compiler/commands/make.rkt +++ b/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) - ;; Just compile one file: +(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)) - ;; Normal make: + '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)])))]) diff --git a/collects/scribblings/raco/make.scrbl b/collects/scribblings/raco/make.scrbl index ffdbc02a92..b01d84f27f 100644 --- a/collects/scribblings/raco/make.scrbl +++ b/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] diff --git a/collects/setup/parallel-build.rkt b/collects/setup/parallel-build.rkt index 6d82e4db8c..f7f255e7ce 100644 --- a/collects/setup/parallel-build.rkt +++ b/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) - "-X" - (path->string collects-dir) - "-l" - "setup/parallel-build-worker.rkt") - (make-object CollectsQueue% collects-tree collects-dir setup-fprintf append-error) - worker-count 999999999))) + (setup-fprintf (current-output-port) #f "--- parallel build using ~a processor cores ---" worker-count) + (parallel-do-event-loop #f + values ; identity function + (build-parallel-build-worker-args) + (make-object CollectsQueue% collects-tree setup-fprintf append-error) + worker-count 999999999))