[racket-dev] [plt] Push #20749: master branch updated

From: Robby Findler (robby at eecs.northwestern.edu)
Date: Thu Jul 22 17:43:51 EDT 2010

Yeah, I'm loving this too. It now only takes 80 minutes for a clean
build on my netbook. Much faster than whatever it was before.

Robby

On Thu, Jul 22, 2010 at 8:16 AM, Jay McCarthy <jay.mccarthy at gmail.com> wrote:
> 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
> _________________________________________________
>  For list-related administrative tasks:
>  http://lists.racket-lang.org/listinfo/dev

Posted on the dev mailing list.