suzanne.soy/racket
1
0
Fork 0
Code Issues Pull Requests Actions Packages Projects Releases Wiki Activity

raco make -j

Browse Source
This commit is contained in:
Kevin Tew 2011-01-31 12:31:23 -07:00
parent aed0980f1b
commit 2e1dffbfcc
3 changed files with 149 additions and 25 deletions
Show Stats Download Patch File Download Diff File Expand all files Collapse all files

25
collects/compiler/commands/make.rkt
View File

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

64
collects/scribblings/raco/make.scrbl
View File

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

85
collects/setup/parallel-build.rkt
View File

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