From 5bb2e148de87457ebb4790287d3b83b872c91a78 Mon Sep 17 00:00:00 2001 From: Kevin Tew Date: Tue, 6 Jul 2010 16:27:12 -0600 Subject: [PATCH] Parallel docs build --- collects/compiler/cm.rkt | 3 +- collects/scribble/base-render.rkt | 2 +- collects/scribblings/raco/make.scrbl | 11 + collects/setup/parallel-build.rkt | 169 ++++------ collects/setup/parallel-do.rkt | 229 ++++++++++++++ collects/setup/scribble.rkt | 447 ++++++++++++++++----------- collects/setup/setup-unit.rkt | 2 + 7 files changed, 562 insertions(+), 301 deletions(-) create mode 100644 collects/setup/parallel-do.rkt diff --git a/collects/compiler/cm.rkt b/collects/compiler/cm.rkt index 7a71c4b364..3f491d5482 100644 --- a/collects/compiler/cm.rkt +++ b/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)) diff --git a/collects/scribble/base-render.rkt b/collects/scribble/base-render.rkt index 47682e9ba4..7de7a0b3ce 100644 --- a/collects/scribble/base-render.rkt +++ b/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]) diff --git a/collects/scribblings/raco/make.scrbl b/collects/scribblings/raco/make.scrbl index a78e063870..cdbe3ee883 100644 --- a/collects/scribblings/raco/make.scrbl +++ b/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.} +@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 +@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 +@racket[with-compile-output] call.} + @; ---------------------------------------------------------------------- @section{Compilation Manager Hook for Syntax Transformers} diff --git a/collects/setup/parallel-build.rkt b/collects/setup/parallel-build.rkt index 5fd1969710..d3e7f3328a 100644 --- a/collects/setup/parallel-build.rkt +++ b/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))])))) diff --git a/collects/setup/parallel-do.rkt b/collects/setup/parallel-do.rkt new file mode 100644 index 0000000000..9061895536 --- /dev/null +++ b/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))]))])) diff --git a/collects/setup/scribble.rkt b/collects/setup/scribble.rkt index 443133cad9..88eaaf7c05 100644 --- a/collects/setup/scribble.rkt +++ b/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- 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 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-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))) diff --git a/collects/setup/setup-unit.rkt b/collects/setup/setup-unit.rkt index 5570d2707a..a3deca9f30 100644 --- a/collects/setup/setup-unit.rkt +++ b/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))