[racket-dev] [plt] Push #20749: master branch updated
From
35.77 minutes: http://drdr.racket-lang.org/20650/src/build/make-install
to
19.37 minutes: http://drdr.racket-lang.org/20748/src/build/make-install
to
6.21 minutes: http://drdr.racket-lang.org/20749/src/build/make-install
Nice job!
Jay
On Thu, Jul 22, 2010 at 3:07 AM, <tewk at racket-lang.org> wrote:
> tewk has updated `master' from ca106a4134 to 5bb2e148de.
> http://git.racket-lang.org/plt/ca106a4134..5bb2e148de
>
> =====[ 1 Commits ]======================================================
>
> Directory summary:
> 98.2% collects/setup/
>
> ~~~~~~~~~~
>
> 5bb2e14 Kevin Tew <tewk at racket-lang.org> 2010-07-06 16:27
> :
> | Parallel docs build
> :
> M collects/compiler/cm.rkt | 3 +-
> M collects/scribble/base-render.rkt | 2 +-
> M collects/scribblings/raco/make.scrbl | 11 +
> M collects/setup/parallel-build.rkt | 169 ++++--------
> A collects/setup/parallel-do.rkt
> M collects/setup/scribble.rkt | 449 ++++++++++++++++++-------------
> M collects/setup/setup-unit.rkt | 2 +
>
> =====[ Overall Diff ]===================================================
>
> collects/compiler/cm.rkt
> ~~~~~~~~~~~~~~~~~~~~~~~~
> --- OLD/collects/compiler/cm.rkt
> +++ NEW/collects/compiler/cm.rkt
> @@ -19,7 +19,8 @@
> file-stamp-in-paths
> (rename-out [trace manager-trace-handler])
> get-file-sha1
> - get-compiled-file-sha1)
> + get-compiled-file-sha1
> + with-compile-output)
>
> (define manager-compile-notify-handler (make-parameter void))
> (define trace (make-parameter void))
>
> collects/scribble/base-render.rkt
> ~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~
> --- OLD/collects/scribble/base-render.rkt
> +++ NEW/collects/scribble/base-render.rkt
> @@ -207,7 +207,7 @@
> ;; marshal info
>
> (define/public (get-serialize-version)
> - 2)
> + 3)
>
> (define/public (serialize-info ri)
> (parameterize ([current-serialize-resolve-info ri])
>
> collects/scribblings/raco/make.scrbl
> ~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~
> --- OLD/collects/scribblings/raco/make.scrbl
> +++ NEW/collects/scribblings/raco/make.scrbl
> @@ -294,6 +294,17 @@ available (i.e., the suffix on @racket[p] is replaced by
> @filepath{.dep} to locate dependency information). The result is
> @racket[#f] if @racket[p] cannot be opened.}
>
> + at defproc[(with-compile-output [p path-string?] [proc ([port input-port?] [tmp-path path?] . -> . any)]) any]{
> +
> +Opens a temporary path for writing and calls @racket[proc] passing the
> +resulting @racket[port] and @racket[tmp-path]. Once @racket[proc]
> +returns, @racket[with-compile-output] renames @racket[tmp-path] to
> + at racket[p] and arranges to delete @racket[temp-path] if there's an
> +exception. Breaks are managed so that the @racket[port] is reliably
> +closed and the @racket[tmp-path] file is reliably deleted if there's a
> +break. The result of @racket[proc] is the result of the
> + at racket[with-compile-output] call.}
> +
> @; ----------------------------------------------------------------------
>
> @section{Compilation Manager Hook for Syntax Transformers}
>
> collects/setup/parallel-build.rkt
> ~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~
> --- OLD/collects/setup/parallel-build.rkt
> +++ NEW/collects/setup/parallel-build.rkt
> @@ -1,115 +1,21 @@
> #lang racket/base
>
> -(require racket/future
> +(require compiler/cm
> racket/list
> racket/match
> racket/path
> setup/collects
> + setup/parallel-do
> unstable/generics)
>
> -(provide parallel-compile)
> -
> -(define-generics (jobqueue prop:jobqueue jobqueue?)
> - (work-done jobqueue queue work workerid msg)
> - (get-job jobqueue queue workerid)
> - (has-jobs? jobqueue queue)
> - (jobs-cnt jobqueue queue)
> - (job-desc jobqueue wokr)
> - (initial-queue jobqueue))
> -
> -(define (process-comp jobqueue nprocs stopat)
> - (define process-worker-library "setup/parallel-build-worker")
> -
> - (define executable (parameterize ([current-directory (find-system-path 'orig-dir)])
> - (find-executable-path (find-system-path 'exec-file) #f)))
> - (define collects-dir (let ([p (find-system-path 'collects-dir)])
> - (if (complete-path? p)
> - p
> - (path->complete-path p (or (path-only executable)
> - (find-system-path 'orig-dir))))))
> -
> - (define (send/msg x ch)
> - (write x ch)
> - (flush-output ch))
> - (define (spawn i)
> - (let-values ([(s o in e) (subprocess #f #f (current-error-port)
> - executable
> - "-X"
> - (path->string collects-dir)
> - "-l"
> - process-worker-library)])
> - (send/msg i in)
> - (list i s o in e)))
> - (define (kill-worker i nw o in)
> - (eprintf "KILLING WORKER ~a ~a ~n" i nw)
> - (close-input-port o)
> - (close-output-port in))
> - (define workers #f)
> - (define (jobs? queue)
> - (has-jobs? jobqueue queue))
> - (define (empty? queue)
> - (not (has-jobs? jobqueue queue)))
> -
> - (parameterize-break #f
> - (set! workers (for/list ([i (in-range nprocs)]) (spawn i))))
> -
> - (dynamic-wind
> - (lambda () (void))
> - (lambda ()
> - (letrec ([loop (match-lambda*
> - ;; QUEUE IDLE INFLIGHT COUNT
> - ;; Reached stopat count STOP
> - [(list queue idle inflight (? (lambda (x) (= x stopat)))) (printf "DONE AT LIMIT~n")]
> - ;; Send work to idle worker
> - [(list (? jobs? queue) (cons worker idle) inflight count)
> - (let-values ([(queue-state job cmd-list) (get-job jobqueue queue (first worker))])
> - (let retry-loop ([worker worker])
> - (match worker
> - [(list i s o in e)
> - (with-handlers* ([exn:fail? (lambda (nw)
> - (kill-worker i nw i o)
> - (retry-loop (spawn i)))])
> - (send/msg cmd-list in))])
> - (loop queue-state idle (cons (list job worker) inflight) count)))]
> - ;; Queue empty and all workers idle, we are all done
> - [(list (? empty?) idle (list) count) (void)]
> - ;; Wait for reply from worker
> - [(list queue idle inflight count)
> - (apply sync (map (λ (node-worker) (match node-worker
> - [(list node worker)
> - (match worker
> - [(list i s o in e)
> - (handle-evt o (λ (e)
> - (let ([msg
> - (with-handlers* ([exn:fail? (lambda (nw)
> - (printf "READ ERROR - reading worker: ~a ~n" nw)
> - (kill-worker i nw i o)
> - (loop queue
> - (cons (spawn i) idle)
> - (remove node-worker inflight)
> - count))])
> - (read o))])
> - ;(list count i (length idle) (length inflight) (length queue))
> - (loop (work-done jobqueue queue node i msg)
> - (cons worker idle)
> - (remove node-worker inflight)
> - (+ count 1)))))])]))
> -
> - inflight))])])
> - (loop (initial-queue jobqueue) workers null 0)))
> - (lambda ()
> - (for ([p workers])
> - (with-handlers ([exn? void])
> - (send/msg (list 'DIE) (fourth p))))
> - (for ([p workers]) (subprocess-wait (second p))))))
> -
> +(provide parallel-compile
> + parallel-build-worker)
>
> (define-struct collects-queue (cclst hash collects-dir printer) #:transparent
> #:mutable
> #:property prop:jobqueue
> (define-methods jobqueue
> - (define (initial-queue jobqueue) null)
> - (define (work-done jobqueue queue work workerid msg)
> + (define (work-done jobqueue work workerid msg)
> (match (list work msg)
> [(list (list cc file) (list result-type out err))
> (let ([cc-name (cc-name cc)])
> @@ -123,7 +29,7 @@
> (eprintf "STDERR:~n~a=====~n" err)))]))
> ;; assigns a collection to each worker to be compiled
> ;; when it runs out of collections, steals work from other workers collections
> - (define (get-job jobqueue queue workerid)
> + (define (get-job jobqueue workerid)
> (define (hash/first-pair hash)
> (match (hash-iterate-first hash)
> [#f #f]
> @@ -148,7 +54,7 @@
> [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 null (list cc file) (list cc-name (->bytes cc-path) (->bytes file)))))
> + (values (list cc file) (list cc-name (->bytes cc-path) (->bytes file)))))
> (let retry ()
> (define (find-job-in-cc cc id)
> (match cc
> @@ -172,20 +78,15 @@
> (match (hash/first-pair w-hash)
> [(cons id cc) (find-job-in-cc cc id)])]
> [cc (find-job-in-cc cc workerid)]))))
> - (define (has-jobs? jobqueue queue)
> + (define (has-jobs? jobqueue)
> (define (hasjob? cct)
> (let loop ([cct cct])
> (ormap (lambda (x) (or ((length (second x)) . > . 0) (loop (third x)))) cct)))
>
> - (let ([jc (jobs-cnt jobqueue queue)]
> - [hj (or (hasjob? (collects-queue-cclst jobqueue))
> - (for/or ([cct (in-hash-values (collects-queue-hash jobqueue))])
> - (hasjob? cct)))])
> - ;(printf "JOBCNT ~a ~a ~a ~a~n" hj jc (length (collects-queue-cclst jobqueue)) (hash-count (collects-queue-hash jobqueue)))
> - hj))
> - (define (job-desc jobqueue work)
> - work)
> - (define (jobs-cnt jobqueue queue)
> + (or (hasjob? (collects-queue-cclst jobqueue))
> + (for/or ([cct (in-hash-values (collects-queue-hash jobqueue))])
> + (hasjob? cct))))
> + (define (jobs-cnt jobqueue)
> (define (count-cct cct)
> (let loop ([cct cct])
> (apply + (map (lambda (x) (+ (length (second x)) (loop (third x)))) cct))))
> @@ -194,8 +95,48 @@
> (for/fold ([cnt 0]) ([cct (in-hash-values (collects-queue-hash jobqueue))])
> (+ cnt (count-cct cct)))))))
>
> -(define (parallel-compile worker-count setup-fprintf collects)
> - (let ([cd (find-system-path 'collects-dir)])
> +(define (parallel-compile worker-count setup-fprintf collects-tree)
> + (let ([collects-dir (current-collects-path)])
> (setup-fprintf (current-output-port) #f "--- parallel build using ~a processor cores ---" worker-count)
> - (process-comp (make-collects-queue collects (make-hash) cd setup-fprintf) worker-count 999999999)))
> + (parallel-do-event-loop #f
> + (lambda (id) id)
> + (list (current-executable-path)
> + "-X"
> + (path->string collects-dir)
> + "-l"
> + "setup/parallel-build-worker.rkt")
> + (make-collects-queue collects-tree (make-hash) collects-dir setup-fprintf)
> + worker-count 999999999)))
> +
> +(define (parallel-build-worker)
> + (let ([cmc (make-caching-managed-compile-zo)]
> + [worker-id (read)])
> + (let loop ()
> + (match (read)
> + [(list 'DIE) void]
> + [(list name dir file)
> + (let ([dir (bytes->path dir)]
> + [file (bytes->path file)])
> + (let ([out-str-port (open-output-string)]
> + [err-str-port (open-output-string)])
> + (define (send/resp type)
> + (let ([msg (list type (get-output-string out-str-port) (get-output-string err-str-port))])
> + (write msg)))
> + (let ([cep (current-error-port)])
> + (define (pp x)
> + (fprintf cep "COMPILING ~a ~a ~a ~a~n" worker-id name file x))
> + (with-handlers ([exn:fail? (lambda (x)
> + (send/resp (list 'ERROR (exn-message x))))])
> + (parameterize (
> + [current-namespace (make-base-empty-namespace)]
> + [current-directory dir]
> + [current-load-relative-directory dir]
> + [current-output-port out-str-port]
> + [current-error-port err-str-port]
> + ;[manager-compile-notify-handler pp]
> + )
>
> + (cmc (build-path dir file)))
> + (send/resp 'DONE))))
> + (flush-output)
> + (loop))]))))
>
> collects/setup/parallel-do.rkt
> ~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~
> --- /dev/null
> +++ NEW/collects/setup/parallel-do.rkt
> @@ -0,0 +1,229 @@
> +#lang racket/base
> +
> +(require racket/file
> + racket/future
> + racket/match
> + racket/path
> + unstable/generics
> + racket/stxparam
> + (for-syntax syntax/parse
> + racket/base))
> +
> +(provide parallel-do
> + parallel-do-event-loop
> + parallel-do-default-error-handler
> + current-executable-path
> + current-collects-path
> + match-message-loop
> + send/success
> + send/error
> + jobqueue
> + prop:jobqueue)
> +
> +(define-generics (jobqueue prop:jobqueue jobqueue?)
> + (work-done jobqueue work workerid msg)
> + (get-job jobqueue workerid)
> + (has-jobs? jobqueue)
> + (jobs-cnt jobqueue))
> +
> +(define-struct worker (id process-handle out in err))
> +(define (current-executable-path)
> + (parameterize ([current-directory (find-system-path 'orig-dir)])
> + (find-executable-path (find-system-path 'exec-file) #f)))
> +(define (current-collects-path)
> + (let ([p (find-system-path 'collects-dir)])
> + (if (complete-path? p)
> + p
> + (path->complete-path p (or (path-only (current-executable-path))
> + (find-system-path 'orig-dir))))))
> +
> +
> +(define (parallel-do-event-loop initialcode initialmsg worker-cmdline-list jobqueue nprocs stopat)
> + (define (send/msg x ch)
> + (write x ch)
> + (flush-output ch))
> + (define (spawn id)
> + (let-values ([(process-handle out in err) (apply subprocess #f #f (current-error-port) worker-cmdline-list)])
> + (when initialcode
> + (send/msg initialcode in))
> + (when initialmsg
> + (send/msg (initialmsg id) in))
> + (make-worker id process-handle out in err)))
> + (define (kill-worker wrkr)
> + (match wrkr
> + [(worker id process-handle out in err)
> + (eprintf "KILLING WORKER ~a ~a~n" id wrkr)
> + (close-output-port in)
> + (close-input-port out)
> + (subprocess-kill process-handle #t)]))
> + (define (jobs? x) (has-jobs? jobqueue))
> + (define (empty? x) (not (has-jobs? jobqueue )))
> + (define workers #f)
> +
> + (dynamic-wind
> + (lambda ()
> + (parameterize-break #f
> + (set! workers (for/list ([i (in-range nprocs)]) (spawn i)))))
> + (lambda ()
> + (letrec ([loop (match-lambda*
> + ;; QUEUE IDLE INFLIGHT COUNT
> + ;; Reached stopat count STOP
> + [(list idle inflight (? (lambda (x) (= x stopat)))) (printf "DONE AT LIMIT~n")]
> + ;; Send work to idle worker
> + [(list (and (? jobs?) (cons wrkr idle)) inflight count)
> + (let-values ([(job cmd-list) (get-job jobqueue (worker-id wrkr))])
> + (let retry-loop ([wrkr wrkr])
> + (match wrkr
> + [(worker i s o in e)
> + (with-handlers* ([exn:fail? (lambda (e)
> + (printf "MASTER WRITE ERROR - writing to worker: ~a~n" (exn-message e))
> + (kill-worker wrkr)
> + (retry-loop (spawn i)))])
> + (send/msg cmd-list in))])
> + (loop idle (cons (list job wrkr) inflight) count)))]
> + ;; Queue empty and all workers idle, we are all done
> + [(list (and (? empty?) idle) (list) count) (void)]
> + ;; Wait for reply from worker
> + [(list idle inflight count)
> + (apply sync (map (λ (node-worker) (match node-worker
> + [(list node (and wrkr (worker id sh out in err)))
> + (handle-evt out (λ (e)
> + (let ([msg
> + (with-handlers* ([exn:fail? (lambda (e)
> + (printf "MASTER READ ERROR - reading from worker: ~a~n" (exn-message e))
> + (kill-worker wrkr)
> + (loop (cons (spawn id) idle)
> + (remove node-worker inflight)
> + count))])
> + (read out))])
> + (work-done jobqueue node id msg)
> + (loop
> + (cons wrkr idle)
> + (remove node-worker inflight)
> + (+ count 1)))))]))
> +
> + inflight))])])
> + (loop workers null 0)))
> + (lambda ()
> + (for ([p workers])
> + (with-handlers ([exn? void])
> + (send/msg (list 'DIE) (worker-in p))))
> + (for ([p workers]) (subprocess-wait (worker-process-handle p))))))
> +
> +(define (parallel-do-default-error-handler work error-message outstr errstr)
> + (printf "WORKER ERROR ~a~n" error-message)
> + (printf "STDOUT~n~a=====~n" outstr)
> + (printf "STDERR~N~a=====~n" errstr))
> +
> +(define-struct list-queue (queue results create-job-thunk success-thunk failure-thunk) #:transparent
> + #:mutable
> + #:property prop:jobqueue
> + (define-methods jobqueue
> + (define (work-done jobqueue work workerid msg)
> + (match msg
> + [(list (list 'DONE result) stdout stderr)
> + (let ([result ((list-queue-success-thunk jobqueue) work result stdout stderr)])
> + (set-list-queue-results! jobqueue (cons result (list-queue-results jobqueue))))]
> + [(list (list 'ERROR errmsg) stdout stderr)
> + ((list-queue-failure-thunk jobqueue) work errmsg stdout stderr)]))
> + (define (get-job jobqueue workerid)
> + (match (list-queue-queue jobqueue)
> + [(cons h t)
> + (set-list-queue-queue! jobqueue t)
> + (values h ((list-queue-create-job-thunk jobqueue) h))]))
> + (define (has-jobs? jobqueue)
> + (not (null? (list-queue-queue jobqueue))))
> + (define (jobs-cnt jobqueue)
> + (length (list-queue-queue jobqueue)))))
> +
> +(define match-message-loop
> + (lambda (stx)
> + (raise-syntax-error 'match-message-loop "only allowed inside a parallel worker definition" stx)))
> +(define-syntax-parameter send/success
> + (lambda (stx)
> + (raise-syntax-error 'send/success "only allowed inside parallel worker definition" stx)))
> +(define-syntax-parameter send/error
> + (lambda (stx)
> + (raise-syntax-error 'send/error "only allowed inside parallel worker definition" stx)))
> +
> +
> +(define-for-syntax (gen-worker-body globals-list globals-body work-body)
> + (with-syntax ([globals-list globals-list]
> + [(globals-body ...) globals-body]
> + [(work work-body ...) work-body])
> + #'(begin
> + (define orig-err (current-error-port))
> + (define orig-out (current-output-port))
> + (define (pdo-send msg)
> + (with-handlers ([exn:fail?
> + (lambda (x)
> + (fprintf orig-err "WORKER SEND MESSAGE ERROR ~a~n" (exn-message x)))])
> + (write msg orig-out)
> + (flush-output orig-out)))
> + (define (pdo-recv)
> + (with-handlers ([exn:fail?
> + (lambda (x)
> + (fprintf orig-err "WORKER RECEIVE MESSAGE ERROR ~a~n" (exn-message x)))])
> + (read)))
> + (match (pdo-recv)
> + [globals-list
> + globals-body ...
> + (let loop ()
> + (match (pdo-recv)
> + [(list 'DIE) void]
> + [work
> + (let ([out-str-port (open-output-string)]
> + [err-str-port (open-output-string)])
> + (define (send/resp type)
> + (pdo-send (list type (get-output-string out-str-port) (get-output-string err-str-port))))
> + (define (send/successp result)
> + (send/resp (list 'DONE result)))
> + (define (send/errorp message)
> + (send/resp (list 'ERROR message)))
> + (with-handlers ([exn:fail? (lambda (x) (send/errorp (exn-message x)))])
> + (parameterize ([current-output-port out-str-port]
> + [current-error-port err-str-port])
> + (syntax-parameterize ([send/success (make-rename-transformer #'send/successp)]
> + [send/error (make-rename-transformer #'send/errorp)])
> + work-body ...
> + (loop)))))]))]))))
> +
> +(define-syntax (lambda-worker stx)
> + (syntax-parse stx #:literals(match-message-loop)
> + [(_ (globals-list:id ...)
> + globals-body:expr ...
> + (match-message-loop
> + [work:id work-body:expr ...]))
> +
> + (with-syntax ([body (gen-worker-body #'(list globals-list ...) #'(globals-body ...) #'(work work-body ...))])
> + #'(lambda ()
> + body))]))
> +
> +(define-syntax (parallel-do stx)
> + (syntax-case stx ()
> + [(_ initalmsg list-of-work create-job-thunk job-success-thunk job-failure-thunk workerthunk)
> + (begin
> + (define (gen-parallel-do-event-loop-syntax cmdline initial-stdin-data)
> + (with-syntax ([cmdline cmdline]
> + [initial-stdin-data initial-stdin-data])
> + #`(begin
> + ;(printf "CMDLINE ~v~n" cmdline)
> + ;(printf "INITIALTHUNK ~v~n" initial-stdin-data)
> + (let ([jobqueue (make-list-queue list-of-work null create-job-thunk job-success-thunk job-failure-thunk)])
> + (parallel-do-event-loop initial-stdin-data initalmsg cmdline jobqueue (processor-count) 999999999)
> + (reverse (list-queue-results jobqueue))))))
> + (define (gen-dynamic-require-current-module funcname)
> + (with-syntax ([funcname funcname])
> + #'(let ([module-path (path->string (resolved-module-path-name (variable-reference->resolved-module-path (#%variable-reference))))])
> + `((dynamic-require (string->path ,module-path) (quote funcname))))))
> + (syntax-case #'workerthunk (define-worker)
> + [(define-worker (name args ...) body ...)
> + (with-syntax ([interal-def-name (syntax-local-lift-expression #'(lambda-worker (args ...) body ...))])
> + (syntax-local-lift-provide #'(rename interal-def-name name)))
> + (gen-parallel-do-event-loop-syntax
> + #'(list (current-executable-path) "-X" (path->string (current-collects-path)) "-e" "(eval(read))")
> + (gen-dynamic-require-current-module #'name))]
> + [funcname
> + (gen-parallel-do-event-loop-syntax
> + #'(list (current-executable-path) "-X" (path->string (current-collects-path)) "-e" "(eval(read))")
> + (gen-dynamic-require-current-module #'funcname))]))]))
>
> collects/setup/scribble.rkt
> ~~~~~~~~~~~~~~~~~~~~~~~~~~~
> --- OLD/collects/setup/scribble.rkt
> +++ NEW/collects/setup/scribble.rkt
> @@ -5,10 +5,12 @@
> "private/path-utils.ss"
> "main-collects.ss"
> "main-doc.ss"
> + "parallel-do.rkt"
> scheme/class
> scheme/list
> scheme/file
> scheme/fasl
> + scheme/match
> scheme/serialize
> compiler/cm
> syntax/modread
> @@ -22,15 +24,22 @@
>
> (provide setup-scribblings
> verbose
> - run-pdflatex)
> + run-pdflatex
> +)
>
> (define verbose (make-parameter #t))
>
> -(define-struct doc (src-dir src-spec src-file dest-dir flags under-main? category))
> -(define-struct info (doc get-sci provides undef searches deps known-deps
> +(define-serializable-struct doc (src-dir src-spec src-file dest-dir flags under-main? category) #:transparent)
> +(define-serializable-struct info (doc ; doc structure above
> + provides ; provides
> + undef ; unresolved requires
> + searches
> + deps
> + known-deps
> build? time out-time need-run?
> need-in-write? need-out-write?
> vers rendered? failed?)
> + #:transparent
> #:mutable)
>
> (define (main-doc? doc)
> @@ -50,6 +59,8 @@
> [else (filter main-doc? docs)])) ; Don't need them, so drop them
>
> (define (setup-scribblings
> + worker-count ; number of cores to use to create documentation
> + program-name ; name of program that calls setup-scribblings
> only-dirs ; limits doc builds
> latex-dest ; if not #f, generate Latex output
> auto-start-doc? ; if #t, expands `only-dir' with [user-]start to
> @@ -119,9 +130,36 @@
> (define infos
> (and (ormap can-build*? docs)
> (filter values
> - (map (get-doc-info only-dirs latex-dest auto-main? auto-user?
> - with-record-error setup-printf)
> - docs))))
> + (if (not (worker-count . > . 1))
> + (map (get-doc-info only-dirs latex-dest auto-main? auto-user? with-record-error setup-printf) docs)
> + (parallel-do
> + (lambda (workerid) (list workerid program-name (verbose) only-dirs latex-dest auto-main? auto-user?))
> + docs
> + (lambda (x) (s-exp->fasl (serialize x)))
> + (lambda (work r outstr errstr) (printf "~a" outstr) (deserialize (fasl->s-exp r)))
> + (lambda (work errmsg outstr errstr) (parallel-do-default-error-handler work errmsg outstr errstr) #f)
> + (define-worker (get-doc-info-worker workerid program-name verbosev only-dirs latex-dest auto-main? auto-user?)
> + (define ((get-doc-info-local program-name only-dirs latex-dest auto-main? auto-user?) doc)
> + (define (setup-printf subpart formatstr . rest)
> + (let ([task
> + (if subpart
> + (format "~a: " subpart)
> + "")])
> + (printf "~a: ~a~a~n" program-name task (apply format formatstr rest))))
> + (define (with-record-error cc go fail-k)
> + (with-handlers ([exn:fail?
> + (lambda (exn)
> + (eprintf "get-doc-info-worker error: ~a\n" (exn-message exn))
> + (raise exn))])
> + (go)))
> + (s-exp->fasl (serialize ((get-doc-info only-dirs latex-dest auto-main? auto-user? with-record-error setup-printf)
> + (deserialize (fasl->s-exp doc))))))
> +
> +
> + (verbose verbosev)
> + (match-message-loop
> + [doc (send/success ((get-doc-info-local program-name only-dirs latex-dest auto-main? auto-user?) doc))])))))))
> +
> (define (make-loop first? iter)
> (let ([ht (make-hash)]
> [infos (filter-not info-failed? infos)]
> @@ -244,10 +282,56 @@
> ;; Iterate, if any need to run:
> (when (and (ormap info-need-run? infos) (iter . < . 30))
> ;; Build again, using dependencies
> - (for ([i infos] #:when (info-need-run? i))
> - (set-info-deps! i (filter info? (info-deps i)))
> - (set-info-need-run?! i #f)
> - (build-again! latex-dest i with-record-error setup-printf))
> + (let ([need-rerun (filter-map (lambda (i)
> + (and (info-need-run? i)
> + (begin
> + (when (info-need-in-write? i)
> + (write-in/info i)
> + (set-info-need-in-write?! i #f))
> + (set-info-deps! i (filter info? (info-deps i)))
> + (set-info-need-run?! i #f)
> + i)))
> + infos)])
> + (define (say-rendering i)
> + (setup-printf (if (info-rendered? i) "re-rendering" "rendering") "~a"
> + (path->name (doc-src-file (info-doc i)))))
> + (define (update-info info response)
> + (match response
> + [#f (set-info-failed?! info #t)]
> + [(list in-delta? out-delta? defs undef)
> + (set-info-rendered?! info #t)
> + (set-info-provides! info defs)
> + (set-info-undef! info undef)
> + (when out-delta?
> + (set-info-out-time! info (/ (current-inexact-milliseconds) 1000)))
> + (when in-delta?
> + ;; Reset expected dependencies to known dependencies, and recompute later:
> + (set-info-deps! info (info-known-deps info))
> + (set-info-need-in-write?! info #t))
> + (set-info-time! info (/ (current-inexact-milliseconds) 1000))]))
> + (if (not (worker-count . > . 1))
> + (map (lambda (i)
> + (say-rendering i)
> + (update-info i (build-again! latex-dest i with-record-error))) need-rerun)
> + (parallel-do
> + (lambda (workerid) (list workerid (verbose) latex-dest))
> + need-rerun
> + (lambda (i)
> + (say-rendering i)
> + (s-exp->fasl (serialize (info-doc i))))
> + (lambda (i r outstr errstr) (update-info i (deserialize (fasl->s-exp r))))
> + (lambda (i errmsg outstr errstr) (parallel-do-default-error-handler i errmsg outstr errstr) #f)
> + (define-worker (build-again!-worker2 workerid verbosev latex-dest)
> + (define (with-record-error cc go fail-k)
> + (with-handlers ([exn:fail?
> + (lambda (x)
> + (eprintf "build-again!-worker error: ~a\n" (exn-message x))
> + (raise x))])
> + (go)))
> + (verbose verbosev)
> + (match-message-loop
> + [info (send/success
> + (s-exp->fasl (serialize (build-again! latex-dest (deserialize (fasl->s-exp info)) with-record-error))))])))))
> ;; If we only build 1, then it reaches it own fixpoint
> ;; even if the info doesn't seem to converge immediately.
> ;; This is a useful shortcut when re-building a single
> @@ -261,7 +345,7 @@
> (make-loop #t 0)
> ;; cache info to disk
> (unless latex-dest
> - (for ([i infos] #:when (info-need-in-write? i)) (write-in i)))))
> + (for ([i infos] #:when (info-need-in-write? i)) (write-in/info i)))))
>
> (define (make-renderer latex-dest doc)
> (if latex-dest
> @@ -316,37 +400,41 @@
> (and (path? base) (loop base)))))))
> only-dirs)))
>
> -(define (ensure-doc-prefix v src-spec)
> - (let ([p (module-path-prefix->string src-spec)])
> - (when (and (part-tag-prefix v)
> - (not (equal? p (part-tag-prefix v))))
> - (error 'setup
> - "bad tag prefix: ~e for: ~a expected: ~e"
> - (part-tag-prefix v)
> - src-spec
> - p))
> - (let ([tag-prefix p]
> - [tags (if (member '(part "top") (part-tags v))
> - (part-tags v)
> - (cons '(part "top") (part-tags v)))]
> - [style (part-style v)])
> - (make-part
> - tag-prefix
> - tags
> - (part-title-content v)
> - (let* ([v (style-properties style)]
> - [v (if (ormap body-id? v)
> - v
> - (cons (make-body-id "doc-racket-lang-org")
> - v))]
> - [v (if (ormap document-version? v)
> - v
> - (cons (make-document-version (version))
> - v))])
> - (make-style (style-name style) v))
> - (part-to-collect v)
> - (part-blocks v)
> - (part-parts v)))))
> +(define (load-doc/ensure-prefix doc)
> + (define (ensure-doc-prefix v src-spec)
> + (let ([p (module-path-prefix->string src-spec)])
> + (when (and (part-tag-prefix v)
> + (not (equal? p (part-tag-prefix v))))
> + (error 'setup
> + "bad tag prefix: ~e for: ~a expected: ~e"
> + (part-tag-prefix v)
> + src-spec
> + p))
> + (let ([tag-prefix p]
> + [tags (if (member '(part "top") (part-tags v))
> + (part-tags v)
> + (cons '(part "top") (part-tags v)))]
> + [style (part-style v)])
> + (make-part
> + tag-prefix
> + tags
> + (part-title-content v)
> + (let* ([v (style-properties style)]
> + [v (if (ormap body-id? v)
> + v
> + (cons (make-body-id "doc-racket-lang-org")
> + v))]
> + [v (if (ormap document-version? v)
> + v
> + (cons (make-document-version (version))
> + v))])
> + (make-style (style-name style) v))
> + (part-to-collect v)
> + (part-blocks v)
> + (part-parts v)))))
> + (ensure-doc-prefix
> + (dynamic-require-doc (doc-src-spec doc))
> + (doc-src-spec doc)))
>
> (define (omit? cat)
> (or (eq? cat 'omit)
> @@ -358,27 +446,8 @@
> (for-each (lambda (k) (hash-set! ht k #t)) keys)
> ht))
>
> -(define (read-sxref)
> - (fasl->s-exp (current-input-port)))
> -
> -(define (make-sci-cached sci info-out-file setup-printf)
> - (when (verbose)
> - (fprintf (current-error-port) " [Lazy ~a]\n" info-out-file))
> - (let ([b (make-weak-box sci)])
> - (lambda ()
> - (let ([v (weak-box-value b)])
> - (or v
> - (begin
> - (when (verbose)
> - (void)
> - #;
> - (fprintf (current-error-port) " [Re-load ~a]\n" info-out-file))
> - (let ([v (cadr (with-input-from-file info-out-file read-sxref))])
> - (set! b (make-weak-box v))
> - v)))))))
> -
> -(define (make-sci-computed sci)
> - (lambda () sci))
> +(define (load-sxref filename)
> + (call-with-input-file filename (lambda (x) (fasl->s-exp x))))
>
> (define (file-or-directory-modify-seconds/stamp file
> stamp-time stamp-data pos
> @@ -456,30 +525,27 @@
> (cond [up-to-date? "using"] [can-run? "running"] [else "skipping"])
> "~a"
> (path->name (doc-src-file doc))))
> +
> (if up-to-date?
> ;; Load previously calculated info:
> (render-time
> "use"
> (with-handlers ([exn:fail? (lambda (exn)
> - (fprintf (current-error-port) "~a\n" (exn-message exn))
> + (fprintf (current-error-port) "get-doc-info ERROR ~a\n" (exn-message exn))
> (delete-file info-out-file)
> (delete-file info-in-file)
> ((get-doc-info only-dirs latex-dest auto-main?
> auto-user? with-record-error
> setup-printf)
> doc))])
> - (let* ([v-in (with-input-from-file info-in-file read-sxref)]
> - [v-out (with-input-from-file info-out-file read-sxref)])
> + (let* ([v-in (load-sxref info-in-file)]
> + [v-out (load-sxref info-out-file)])
> (unless (and (equal? (car v-in) (list vers (doc-flags doc)))
> (equal? (car v-out) (list vers (doc-flags doc))))
> (error "old info has wrong version or flags"))
> (make-info
> doc
> - (make-sci-cached
> - (list-ref v-out 1) ; sci (leave serialized)
> - info-out-file
> - setup-printf)
> - (let ([v (list-ref v-out 2)]) ; provides
> + (let ([v (list-ref v-out 2)]) ; provides
> (with-my-namespace
> (lambda ()
> (deserialize v))))
> @@ -496,7 +562,8 @@
> can-run?
> my-time info-out-time
> (and can-run? (memq 'always-run (doc-flags doc)))
> - #f #f
> + #f
> + #f
> vers
> #f
> #f))))
> @@ -506,21 +573,21 @@
> (doc-src-file doc)
> (lambda ()
> (parameterize ([current-directory (doc-src-dir doc)])
> - (let* ([v (ensure-doc-prefix
> - (dynamic-require-doc (doc-src-spec doc))
> - (doc-src-spec doc))]
> + (let* ([v (load-doc/ensure-prefix doc)]
> [dest-dir (pick-dest latex-dest doc)]
> [fp (send renderer traverse (list v) (list dest-dir))]
> [ci (send renderer collect (list v) (list dest-dir) fp)]
> [ri (send renderer resolve (list v) (list dest-dir) ci)]
> [out-v (and info-out-time
> + (info-out-time . >= . src-time)
> (with-handlers ([exn:fail? (lambda (exn) #f)])
> - (let ([v (with-input-from-file info-out-file read-sxref)])
> + (let ([v (load-sxref info-out-file)])
> (unless (equal? (car v) (list vers (doc-flags doc)))
> (error "old info has wrong version or flags"))
> v)))]
> [sci (send renderer serialize-info ri)]
> [defs (send renderer get-defined ci)]
> + [undef (send renderer get-undefined ri)]
> [searches (resolve-info-searches ri)]
> [need-out-write?
> (or (not out-v)
> @@ -534,11 +601,8 @@
> (gc-point)
> (let ([info
> (make-info doc
> - (if need-out-write?
> - (make-sci-computed sci)
> - (make-sci-cached sci info-out-file setup-printf))
> - defs
> - (send renderer get-undefined ri)
> + defs ; provides
> + undef
> searches
> null ; no deps, yet
> null ; no known deps, yet
> @@ -548,18 +612,20 @@
> (/ (current-inexact-milliseconds) 1000)
> info-out-time)
> #t
> - can-run? need-out-write?
> + can-run?
> + need-out-write?
> vers
> #f
> #f)])
> (when need-out-write?
> (unless latex-dest
> - (render-time "xref-out" (write-out info setup-printf)))
> + (render-time "xref-out" (write-out/info info sci)))
> (set-info-need-out-write?! info #f))
> (when (info-need-in-write? info)
> (unless latex-dest
> - (render-time "xref-in" (write-in info)))
> + (render-time "xref-in" (write-in/info info)))
> (set-info-need-in-write?! info #f))
> +
> (when (or (stamp-time . < . aux-time)
> (stamp-time . < . src-time))
> (let ([data (list (get-compiled-file-sha1 src-zo)
> @@ -597,83 +663,86 @@
> (time expr)
> (collect-garbage) (collect-garbage) (printf "post ~a ~s\n" what (current-memory-use)))))
>
> -(define (build-again! latex-dest info with-record-error setup-printf)
> - (define doc (info-doc info))
> +(define (load-sxrefs doc vers)
> + (define dest-dir (doc-dest-dir doc))
> + (match (list (load-sxref (build-path dest-dir "in.sxref")) (load-sxref (build-path dest-dir "out.sxref")))
> + [(list (list in-version undef deps-rel searches dep-dirs) (list out-version sci provides))
> + (unless (and (equal? in-version (list vers (doc-flags doc)))
> + (equal? out-version (list vers (doc-flags doc))))
> + (error "old info has wrong version or flags"))
> + (with-my-namespace*
> + (values (deserialize undef) deps-rel (deserialize searches) dep-dirs sci (deserialize provides)))]))
> +
> +(define (build-again! latex-dest info with-record-error)
> + (define (cleanup-dest-dir doc)
> + (unless latex-dest
> + (let ([dir (doc-dest-dir doc)])
> + (if (not (directory-exists? dir))
> + (make-directory dir)
> + (for ([f (directory-list dir)]
> + #:when
> + (and (file-exists? f)
> + (not (regexp-match? #"[.]sxref$"
> + (path-element->bytes f)))))
> + (delete-file (build-path dir f)))))))
> + (define (load-doc-sci dest-dir)
> + (cadr (load-sxref (build-path (or latex-dest dest-dir) "out.sxref"))))
> + (define doc (if (info? info ) (info-doc info) info))
> (define renderer (make-renderer latex-dest doc))
> - (setup-printf (format "~arendering"
> - (if (info-rendered? info) "re-" ""))
> - "~a"
> - (path->name (doc-src-file doc)))
> - (set-info-rendered?! info #t)
> (with-record-error
> - (doc-src-file doc)
> - (lambda ()
> - (parameterize ([current-directory (doc-src-dir doc)])
> - (let* ([v (ensure-doc-prefix (render-time
> - "load"
> - (dynamic-require-doc (doc-src-spec doc)))
> - (doc-src-spec doc))]
> + (doc-src-file doc)
> + (lambda ()
> + (define vers (send renderer get-serialize-version))
> + (define-values (ff-undef ff-deps-rel ff-searches ff-dep-dirs ff-sci ff-provides)
> + (if (info? info)
> + (values (info-undef info)
> + (info-deps->rel-doc-src-file info)
> + (info-searches info)
> + (info-deps->doc-dest-dir info)
> + (load-doc-sci (doc-dest-dir doc))
> + (info-provides info))
> + (load-sxrefs doc vers)))
> +
> + (parameterize ([current-directory (doc-src-dir doc)])
> + (let* ([v (render-time "load" (load-doc/ensure-prefix doc))]
> [dest-dir (pick-dest latex-dest doc)]
> - [fp (render-time "traverse"
> - (send renderer traverse (list v) (list dest-dir)))]
> - [ci (render-time "collect"
> - (send renderer collect (list v) (list dest-dir) fp))])
> - (render-time
> - "deserialize"
> - (for ([i (info-deps info)])
> - (when (info? i)
> - (with-my-namespace
> - (lambda ()
> - (send renderer deserialize-info ((info-get-sci i)) ci))))))
> - (let* ([ri (render-time "resolve" (send renderer resolve (list v) (list dest-dir) ci))]
> - [sci (render-time "serialize" (send renderer serialize-info ri))]
> - [defs (render-time "defined" (send renderer get-defined ci))]
> - [undef (render-time "undefined" (send renderer get-undefined ri))]
> - [in-delta? (not (equal? (any-order undef)
> - (any-order (info-undef info))))]
> - [out-delta? (or (not (serialized=? sci ((info-get-sci info))))
> - (not (equal? (any-order defs)
> - (any-order (info-provides info)))))])
> - (when (verbose)
> - (printf " [~a~afor ~a]\n"
> - (if in-delta? "New in " "")
> - (cond [out-delta? "New out "]
> - [in-delta? ""]
> - [else "No change "])
> - (doc-src-file doc)))
> - (when out-delta?
> - (set-info-out-time! info (/ (current-inexact-milliseconds) 1000)))
> - (set-info-provides! info defs)
> - (set-info-undef! info undef)
> - (when in-delta?
> - ;; Reset expected dependencies to known dependencies, and recompute later:
> - (set-info-deps! info (info-known-deps info)))
> - (when (or out-delta? (info-need-out-write? info))
> - (set-info-get-sci! info (make-sci-computed sci))
> - (unless latex-dest
> - (render-time "xref-out" (write-out info setup-printf)))
> - (set-info-need-out-write?! info #f))
> - (when in-delta? (set-info-need-in-write?! info #t))
> - (unless latex-dest
> - (let ([dir (doc-dest-dir doc)])
> - (if (not (directory-exists? dir))
> - (make-directory dir)
> - (for ([f (directory-list dir)]
> - #:when
> - (and (file-exists? f)
> - (not (regexp-match? #"[.]sxref$"
> - (path-element->bytes f)))))
> - (delete-file (build-path dir f))))))
> - (render-time
> + [fp (render-time "traverse" (send renderer traverse (list v) (list dest-dir)))]
> + [ci (render-time "collect" (send renderer collect (list v) (list dest-dir) fp))]
> + [ri (begin
> + (render-time "deserialize" (with-my-namespace* (for ([dest-dir ff-dep-dirs])
> + (send renderer deserialize-info (load-doc-sci dest-dir) ci))))
> + (render-time "resolve" (send renderer resolve (list v) (list dest-dir) ci)))]
> + [sci (render-time "serialize" (send renderer serialize-info ri))]
> + [defs (render-time "defined" (send renderer get-defined ci))]
> + [undef (render-time "undefined" (send renderer get-undefined ri))]
> + [in-delta? (not (equal? (any-order undef) (any-order ff-undef)))]
> + [out-delta? (or (not (serialized=? sci ff-sci))
> + (not (equal? (any-order defs) (any-order ff-provides))))])
> + (when (verbose)
> + (printf " [~a~afor ~a]\n"
> + (if in-delta? "New in " "")
> + (cond [out-delta? "New out "]
> + [in-delta? ""]
> + [else "No change "])
> + (doc-src-file doc)))
> +
> + (when in-delta?
> + (unless latex-dest
> + (render-time "xref-in" (write-in vers doc undef ff-deps-rel ff-searches ff-dep-dirs))))
> + (when out-delta?
> + (unless latex-dest
> + (render-time "xref-out" (write-out vers doc sci defs))))
> +
> + (cleanup-dest-dir doc)
> + (render-time
> "render"
> (with-record-error
> (doc-src-file doc)
> (lambda () (send renderer render (list v) (list dest-dir) ri))
> void))
> - (set-info-time! info (/ (current-inexact-milliseconds) 1000))
> - (gc-point)
> - (void)))))
> - (lambda () (set-info-failed?! info #t))))
> + (gc-point)
> + (list in-delta? out-delta? defs undef))))
> + (lambda () #f)))
>
> (define (gc-point)
> ;; Forcing a GC on document boundaries helps keep peak memory use down.
> @@ -685,6 +754,10 @@
> (parameterize ([current-namespace (namespace-anchor->empty-namespace anchor)])
> (thunk)))
>
> +(define-syntax-rule (with-my-namespace* body ...)
> + (parameterize ([current-namespace (namespace-anchor->empty-namespace anchor)])
> + body ...))
> +
> (define (dynamic-require-doc mod-path)
> ;; Use a separate namespace so that we don't end up with all the
> ;; documentation loaded at once.
> @@ -703,32 +776,36 @@
> (parameterize ([current-namespace p])
> (call-in-nested-thread (lambda () (dynamic-require mod-path 'doc)))))))
>
> -(define (write- info name sel)
> - (let* ([doc (info-doc info)]
> - [info-file (build-path (doc-dest-dir doc) name)])
> - (when (verbose) (printf " [Caching ~a]\n" info-file))
> - (with-output-to-file info-file #:exists 'truncate/replace
> - (lambda ()
> - (sel (lambda ()
> - (list (list (info-vers info) (doc-flags doc))
> - ((info-get-sci info))
> - (serialize (info-provides info))))
> - (lambda ()
> - (list (list (info-vers info) (doc-flags doc))
> - (serialize (info-undef info))
> - (convert-deps (info-deps info))
> - (serialize (info-searches info)))))))))
> -
> -(define (write-out info setup-printf)
> - (make-directory* (doc-dest-dir (info-doc info)))
> - (write- info "out.sxref" (lambda (o i) (write-bytes (s-exp->fasl (o)))))
> - (set-info-get-sci! info
> - (make-sci-cached ((info-get-sci info))
> - (build-path (doc-dest-dir (info-doc info)) "out.sxref")
> - setup-printf)))
> -(define (write-in info)
> - (make-directory* (doc-dest-dir (info-doc info)))
> - (write- info "in.sxref" (lambda (o i) (write-bytes (s-exp->fasl (i))))))
> +(define (write- vers doc name data)
> + (let* ([filename (build-path (doc-dest-dir doc) name)])
> + (when (verbose) (printf " [Caching to disk ~a]\n" filename))
> + (make-directory* (doc-dest-dir doc))
> + (with-compile-output filename
> + (lambda (out tmp-filename)
> + (write-bytes (s-exp->fasl (append (list (list vers (doc-flags doc))) data)) out)))))
> +
> +(define (write-out vers doc sci provides)
> + (write- vers doc "out.sxref"
> + (list sci
> + (serialize provides))))
> +
> +(define (write-out/info info sci)
> + (write-out (info-vers info) (info-doc info) sci (info-provides info)))
> +
> +(define (write-in vers doc undef rels searches dest-dirs)
> + (write- vers doc "in.sxref"
> + (list (serialize undef)
> + rels
> + (serialize searches)
> + dest-dirs)))
> +
> +(define (write-in/info info)
> + (write-in (info-vers info)
> + (info-doc info)
> + (info-undef info)
> + (info-deps->rel-doc-src-file info)
> + (info-searches info)
> + (info-deps->doc-dest-dir info)))
>
> (define (rel->path r)
> (if (bytes? r)
> @@ -741,10 +818,10 @@
> (path->bytes r)
> r)))
>
> -(define (convert-deps deps)
> - (filter
> - values
> - (map (lambda (i)
> - (and (info? i)
> - (path->rel (doc-src-file (info-doc i)))))
> - deps)))
> +(define (info-deps->rel-doc-src-file info)
> + (filter-map (lambda (i) (and (info? i)
> + (path->rel (doc-src-file (info-doc i)))))
> + (info-deps info)))
> +
> +(define (info-deps->doc-dest-dir info)
> + (filter-map (lambda (i) (and (info? i) (doc-dest-dir (info-doc i)))) (info-deps info)))
>
> collects/setup/setup-unit.rkt
> ~~~~~~~~~~~~~~~~~~~~~~~~~~~~~
> --- OLD/collects/setup/setup-unit.rkt
> +++ NEW/collects/setup/setup-unit.rkt
> @@ -786,6 +786,8 @@
>
> (define (doc:setup-scribblings latex-dest auto-start-doc?)
> (scr:call 'setup-scribblings
> + (parallel-workers)
> + name-str
> (if no-specific-collections? #f (map cc-path ccs-to-compile))
> latex-dest auto-start-doc? (make-user)
> (lambda (what go alt) (record-error what "Building docs" go alt))
>
--
Jay McCarthy <jay at cs.byu.edu>
Assistant Professor / Brigham Young University
http://teammccarthy.org/jay
"The glory of God is Intelligence" - D&C 93
![[logo]](/logo.png){kind=logo}