Parallel docs build
This commit is contained in:
parent
ca106a4134
commit
5bb2e148de
|
@ -19,7 +19,8 @@
|
||||||
file-stamp-in-paths
|
file-stamp-in-paths
|
||||||
(rename-out [trace manager-trace-handler])
|
(rename-out [trace manager-trace-handler])
|
||||||
get-file-sha1
|
get-file-sha1
|
||||||
get-compiled-file-sha1)
|
get-compiled-file-sha1
|
||||||
|
with-compile-output)
|
||||||
|
|
||||||
(define manager-compile-notify-handler (make-parameter void))
|
(define manager-compile-notify-handler (make-parameter void))
|
||||||
(define trace (make-parameter void))
|
(define trace (make-parameter void))
|
||||||
|
|
|
@ -207,7 +207,7 @@
|
||||||
;; marshal info
|
;; marshal info
|
||||||
|
|
||||||
(define/public (get-serialize-version)
|
(define/public (get-serialize-version)
|
||||||
2)
|
3)
|
||||||
|
|
||||||
(define/public (serialize-info ri)
|
(define/public (serialize-info ri)
|
||||||
(parameterize ([current-serialize-resolve-info ri])
|
(parameterize ([current-serialize-resolve-info ri])
|
||||||
|
|
|
@ -294,6 +294,17 @@ available (i.e., the suffix on @racket[p] is replaced by
|
||||||
@filepath{.dep} to locate dependency information). The result is
|
@filepath{.dep} to locate dependency information). The result is
|
||||||
@racket[#f] if @racket[p] cannot be opened.}
|
@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}
|
@section{Compilation Manager Hook for Syntax Transformers}
|
||||||
|
|
|
@ -1,115 +1,21 @@
|
||||||
#lang racket/base
|
#lang racket/base
|
||||||
|
|
||||||
(require racket/future
|
(require compiler/cm
|
||||||
racket/list
|
racket/list
|
||||||
racket/match
|
racket/match
|
||||||
racket/path
|
racket/path
|
||||||
setup/collects
|
setup/collects
|
||||||
|
setup/parallel-do
|
||||||
unstable/generics)
|
unstable/generics)
|
||||||
|
|
||||||
(provide parallel-compile)
|
(provide parallel-compile
|
||||||
|
parallel-build-worker)
|
||||||
(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))))))
|
|
||||||
|
|
||||||
|
|
||||||
(define-struct collects-queue (cclst hash collects-dir printer) #:transparent
|
(define-struct collects-queue (cclst hash collects-dir printer) #:transparent
|
||||||
#:mutable
|
#:mutable
|
||||||
#:property prop:jobqueue
|
#:property prop:jobqueue
|
||||||
(define-methods jobqueue
|
(define-methods jobqueue
|
||||||
(define (initial-queue jobqueue) null)
|
(define (work-done jobqueue work workerid msg)
|
||||||
(define (work-done jobqueue queue work workerid msg)
|
|
||||||
(match (list work msg)
|
(match (list work msg)
|
||||||
[(list (list cc file) (list result-type out err))
|
[(list (list cc file) (list result-type out err))
|
||||||
(let ([cc-name (cc-name cc)])
|
(let ([cc-name (cc-name cc)])
|
||||||
|
@ -123,7 +29,7 @@
|
||||||
(eprintf "STDERR:~n~a=====~n" err)))]))
|
(eprintf "STDERR:~n~a=====~n" err)))]))
|
||||||
;; assigns a collection to each worker to be compiled
|
;; assigns a collection to each worker to be compiled
|
||||||
;; when it runs out of collections, steals work from other workers collections
|
;; 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)
|
(define (hash/first-pair hash)
|
||||||
(match (hash-iterate-first hash)
|
(match (hash-iterate-first hash)
|
||||||
[#f #f]
|
[#f #f]
|
||||||
|
@ -148,7 +54,7 @@
|
||||||
[cc-path (cc-path cc)]
|
[cc-path (cc-path cc)]
|
||||||
[full-path (path->string (build-path cc-path file))])
|
[full-path (path->string (build-path cc-path file))])
|
||||||
;(printf "JOB ~a ~a ~a ~a~n" workerid cc-name 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 ()
|
(let retry ()
|
||||||
(define (find-job-in-cc cc id)
|
(define (find-job-in-cc cc id)
|
||||||
(match cc
|
(match cc
|
||||||
|
@ -172,20 +78,15 @@
|
||||||
(match (hash/first-pair w-hash)
|
(match (hash/first-pair w-hash)
|
||||||
[(cons id cc) (find-job-in-cc cc id)])]
|
[(cons id cc) (find-job-in-cc cc id)])]
|
||||||
[cc (find-job-in-cc cc workerid)]))))
|
[cc (find-job-in-cc cc workerid)]))))
|
||||||
(define (has-jobs? jobqueue queue)
|
(define (has-jobs? jobqueue)
|
||||||
(define (hasjob? cct)
|
(define (hasjob? cct)
|
||||||
(let loop ([cct cct])
|
(let loop ([cct cct])
|
||||||
(ormap (lambda (x) (or ((length (second x)) . > . 0) (loop (third x)))) cct)))
|
(ormap (lambda (x) (or ((length (second x)) . > . 0) (loop (third x)))) cct)))
|
||||||
|
|
||||||
(let ([jc (jobs-cnt jobqueue queue)]
|
(or (hasjob? (collects-queue-cclst jobqueue))
|
||||||
[hj (or (hasjob? (collects-queue-cclst jobqueue))
|
(for/or ([cct (in-hash-values (collects-queue-hash jobqueue))])
|
||||||
(for/or ([cct (in-hash-values (collects-queue-hash jobqueue))])
|
(hasjob? cct))))
|
||||||
(hasjob? cct)))])
|
(define (jobs-cnt jobqueue)
|
||||||
;(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)
|
|
||||||
(define (count-cct cct)
|
(define (count-cct cct)
|
||||||
(let loop ([cct cct])
|
(let loop ([cct cct])
|
||||||
(apply + (map (lambda (x) (+ (length (second x)) (loop (third x)))) 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))])
|
(for/fold ([cnt 0]) ([cct (in-hash-values (collects-queue-hash jobqueue))])
|
||||||
(+ cnt (count-cct cct)))))))
|
(+ cnt (count-cct cct)))))))
|
||||||
|
|
||||||
(define (parallel-compile worker-count setup-fprintf collects)
|
(define (parallel-compile worker-count setup-fprintf collects-tree)
|
||||||
(let ([cd (find-system-path 'collects-dir)])
|
(let ([collects-dir (current-collects-path)])
|
||||||
(setup-fprintf (current-output-port) #f "--- parallel build using ~a processor cores ---" worker-count)
|
(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))]))))
|
||||||
|
|
229
collects/setup/parallel-do.rkt
Normal file
229
collects/setup/parallel-do.rkt
Normal file
|
@ -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))]))]))
|
|
@ -5,10 +5,12 @@
|
||||||
"private/path-utils.ss"
|
"private/path-utils.ss"
|
||||||
"main-collects.ss"
|
"main-collects.ss"
|
||||||
"main-doc.ss"
|
"main-doc.ss"
|
||||||
|
"parallel-do.rkt"
|
||||||
scheme/class
|
scheme/class
|
||||||
scheme/list
|
scheme/list
|
||||||
scheme/file
|
scheme/file
|
||||||
scheme/fasl
|
scheme/fasl
|
||||||
|
scheme/match
|
||||||
scheme/serialize
|
scheme/serialize
|
||||||
compiler/cm
|
compiler/cm
|
||||||
syntax/modread
|
syntax/modread
|
||||||
|
@ -22,15 +24,22 @@
|
||||||
|
|
||||||
(provide setup-scribblings
|
(provide setup-scribblings
|
||||||
verbose
|
verbose
|
||||||
run-pdflatex)
|
run-pdflatex
|
||||||
|
)
|
||||||
|
|
||||||
(define verbose (make-parameter #t))
|
(define verbose (make-parameter #t))
|
||||||
|
|
||||||
(define-struct doc (src-dir src-spec src-file dest-dir flags under-main? category))
|
(define-serializable-struct doc (src-dir src-spec src-file dest-dir flags under-main? category) #:transparent)
|
||||||
(define-struct info (doc get-sci provides undef searches deps known-deps
|
(define-serializable-struct info (doc ; doc structure above
|
||||||
|
provides ; provides
|
||||||
|
undef ; unresolved requires
|
||||||
|
searches
|
||||||
|
deps
|
||||||
|
known-deps
|
||||||
build? time out-time need-run?
|
build? time out-time need-run?
|
||||||
need-in-write? need-out-write?
|
need-in-write? need-out-write?
|
||||||
vers rendered? failed?)
|
vers rendered? failed?)
|
||||||
|
#:transparent
|
||||||
#:mutable)
|
#:mutable)
|
||||||
|
|
||||||
(define (main-doc? doc)
|
(define (main-doc? doc)
|
||||||
|
@ -50,6 +59,8 @@
|
||||||
[else (filter main-doc? docs)])) ; Don't need them, so drop them
|
[else (filter main-doc? docs)])) ; Don't need them, so drop them
|
||||||
|
|
||||||
(define (setup-scribblings
|
(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
|
only-dirs ; limits doc builds
|
||||||
latex-dest ; if not #f, generate Latex output
|
latex-dest ; if not #f, generate Latex output
|
||||||
auto-start-doc? ; if #t, expands `only-dir' with [user-]start to
|
auto-start-doc? ; if #t, expands `only-dir' with [user-]start to
|
||||||
|
@ -119,9 +130,36 @@
|
||||||
(define infos
|
(define infos
|
||||||
(and (ormap can-build*? docs)
|
(and (ormap can-build*? docs)
|
||||||
(filter values
|
(filter values
|
||||||
(map (get-doc-info only-dirs latex-dest auto-main? auto-user?
|
(if (not (worker-count . > . 1))
|
||||||
with-record-error setup-printf)
|
(map (get-doc-info only-dirs latex-dest auto-main? auto-user? with-record-error setup-printf) docs)
|
||||||
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)
|
(define (make-loop first? iter)
|
||||||
(let ([ht (make-hash)]
|
(let ([ht (make-hash)]
|
||||||
[infos (filter-not info-failed? infos)]
|
[infos (filter-not info-failed? infos)]
|
||||||
|
@ -244,10 +282,56 @@
|
||||||
;; Iterate, if any need to run:
|
;; Iterate, if any need to run:
|
||||||
(when (and (ormap info-need-run? infos) (iter . < . 30))
|
(when (and (ormap info-need-run? infos) (iter . < . 30))
|
||||||
;; Build again, using dependencies
|
;; Build again, using dependencies
|
||||||
(for ([i infos] #:when (info-need-run? i))
|
(let ([need-rerun (filter-map (lambda (i)
|
||||||
(set-info-deps! i (filter info? (info-deps i)))
|
(and (info-need-run? i)
|
||||||
(set-info-need-run?! i #f)
|
(begin
|
||||||
(build-again! latex-dest i with-record-error setup-printf))
|
(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
|
;; If we only build 1, then it reaches it own fixpoint
|
||||||
;; even if the info doesn't seem to converge immediately.
|
;; even if the info doesn't seem to converge immediately.
|
||||||
;; This is a useful shortcut when re-building a single
|
;; This is a useful shortcut when re-building a single
|
||||||
|
@ -261,7 +345,7 @@
|
||||||
(make-loop #t 0)
|
(make-loop #t 0)
|
||||||
;; cache info to disk
|
;; cache info to disk
|
||||||
(unless latex-dest
|
(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)
|
(define (make-renderer latex-dest doc)
|
||||||
(if latex-dest
|
(if latex-dest
|
||||||
|
@ -316,37 +400,41 @@
|
||||||
(and (path? base) (loop base)))))))
|
(and (path? base) (loop base)))))))
|
||||||
only-dirs)))
|
only-dirs)))
|
||||||
|
|
||||||
(define (ensure-doc-prefix v src-spec)
|
(define (load-doc/ensure-prefix doc)
|
||||||
(let ([p (module-path-prefix->string src-spec)])
|
(define (ensure-doc-prefix v src-spec)
|
||||||
(when (and (part-tag-prefix v)
|
(let ([p (module-path-prefix->string src-spec)])
|
||||||
(not (equal? p (part-tag-prefix v))))
|
(when (and (part-tag-prefix v)
|
||||||
(error 'setup
|
(not (equal? p (part-tag-prefix v))))
|
||||||
"bad tag prefix: ~e for: ~a expected: ~e"
|
(error 'setup
|
||||||
(part-tag-prefix v)
|
"bad tag prefix: ~e for: ~a expected: ~e"
|
||||||
src-spec
|
(part-tag-prefix v)
|
||||||
p))
|
src-spec
|
||||||
(let ([tag-prefix p]
|
p))
|
||||||
[tags (if (member '(part "top") (part-tags v))
|
(let ([tag-prefix p]
|
||||||
(part-tags v)
|
[tags (if (member '(part "top") (part-tags v))
|
||||||
(cons '(part "top") (part-tags v)))]
|
(part-tags v)
|
||||||
[style (part-style v)])
|
(cons '(part "top") (part-tags v)))]
|
||||||
(make-part
|
[style (part-style v)])
|
||||||
tag-prefix
|
(make-part
|
||||||
tags
|
tag-prefix
|
||||||
(part-title-content v)
|
tags
|
||||||
(let* ([v (style-properties style)]
|
(part-title-content v)
|
||||||
[v (if (ormap body-id? v)
|
(let* ([v (style-properties style)]
|
||||||
v
|
[v (if (ormap body-id? v)
|
||||||
(cons (make-body-id "doc-racket-lang-org")
|
v
|
||||||
v))]
|
(cons (make-body-id "doc-racket-lang-org")
|
||||||
[v (if (ormap document-version? v)
|
v))]
|
||||||
v
|
[v (if (ormap document-version? v)
|
||||||
(cons (make-document-version (version))
|
v
|
||||||
v))])
|
(cons (make-document-version (version))
|
||||||
(make-style (style-name style) v))
|
v))])
|
||||||
(part-to-collect v)
|
(make-style (style-name style) v))
|
||||||
(part-blocks v)
|
(part-to-collect v)
|
||||||
(part-parts v)))))
|
(part-blocks v)
|
||||||
|
(part-parts v)))))
|
||||||
|
(ensure-doc-prefix
|
||||||
|
(dynamic-require-doc (doc-src-spec doc))
|
||||||
|
(doc-src-spec doc)))
|
||||||
|
|
||||||
(define (omit? cat)
|
(define (omit? cat)
|
||||||
(or (eq? cat 'omit)
|
(or (eq? cat 'omit)
|
||||||
|
@ -358,27 +446,8 @@
|
||||||
(for-each (lambda (k) (hash-set! ht k #t)) keys)
|
(for-each (lambda (k) (hash-set! ht k #t)) keys)
|
||||||
ht))
|
ht))
|
||||||
|
|
||||||
(define (read-sxref)
|
(define (load-sxref filename)
|
||||||
(fasl->s-exp (current-input-port)))
|
(call-with-input-file filename (lambda (x) (fasl->s-exp x))))
|
||||||
|
|
||||||
(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 (file-or-directory-modify-seconds/stamp file
|
(define (file-or-directory-modify-seconds/stamp file
|
||||||
stamp-time stamp-data pos
|
stamp-time stamp-data pos
|
||||||
|
@ -456,30 +525,27 @@
|
||||||
(cond [up-to-date? "using"] [can-run? "running"] [else "skipping"])
|
(cond [up-to-date? "using"] [can-run? "running"] [else "skipping"])
|
||||||
"~a"
|
"~a"
|
||||||
(path->name (doc-src-file doc))))
|
(path->name (doc-src-file doc))))
|
||||||
|
|
||||||
(if up-to-date?
|
(if up-to-date?
|
||||||
;; Load previously calculated info:
|
;; Load previously calculated info:
|
||||||
(render-time
|
(render-time
|
||||||
"use"
|
"use"
|
||||||
(with-handlers ([exn:fail? (lambda (exn)
|
(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-out-file)
|
||||||
(delete-file info-in-file)
|
(delete-file info-in-file)
|
||||||
((get-doc-info only-dirs latex-dest auto-main?
|
((get-doc-info only-dirs latex-dest auto-main?
|
||||||
auto-user? with-record-error
|
auto-user? with-record-error
|
||||||
setup-printf)
|
setup-printf)
|
||||||
doc))])
|
doc))])
|
||||||
(let* ([v-in (with-input-from-file info-in-file read-sxref)]
|
(let* ([v-in (load-sxref info-in-file)]
|
||||||
[v-out (with-input-from-file info-out-file read-sxref)])
|
[v-out (load-sxref info-out-file)])
|
||||||
(unless (and (equal? (car v-in) (list vers (doc-flags doc)))
|
(unless (and (equal? (car v-in) (list vers (doc-flags doc)))
|
||||||
(equal? (car v-out) (list vers (doc-flags doc))))
|
(equal? (car v-out) (list vers (doc-flags doc))))
|
||||||
(error "old info has wrong version or flags"))
|
(error "old info has wrong version or flags"))
|
||||||
(make-info
|
(make-info
|
||||||
doc
|
doc
|
||||||
(make-sci-cached
|
(let ([v (list-ref v-out 2)]) ; provides
|
||||||
(list-ref v-out 1) ; sci (leave serialized)
|
|
||||||
info-out-file
|
|
||||||
setup-printf)
|
|
||||||
(let ([v (list-ref v-out 2)]) ; provides
|
|
||||||
(with-my-namespace
|
(with-my-namespace
|
||||||
(lambda ()
|
(lambda ()
|
||||||
(deserialize v))))
|
(deserialize v))))
|
||||||
|
@ -496,7 +562,8 @@
|
||||||
can-run?
|
can-run?
|
||||||
my-time info-out-time
|
my-time info-out-time
|
||||||
(and can-run? (memq 'always-run (doc-flags doc)))
|
(and can-run? (memq 'always-run (doc-flags doc)))
|
||||||
#f #f
|
#f
|
||||||
|
#f
|
||||||
vers
|
vers
|
||||||
#f
|
#f
|
||||||
#f))))
|
#f))))
|
||||||
|
@ -506,21 +573,21 @@
|
||||||
(doc-src-file doc)
|
(doc-src-file doc)
|
||||||
(lambda ()
|
(lambda ()
|
||||||
(parameterize ([current-directory (doc-src-dir doc)])
|
(parameterize ([current-directory (doc-src-dir doc)])
|
||||||
(let* ([v (ensure-doc-prefix
|
(let* ([v (load-doc/ensure-prefix doc)]
|
||||||
(dynamic-require-doc (doc-src-spec doc))
|
|
||||||
(doc-src-spec doc))]
|
|
||||||
[dest-dir (pick-dest latex-dest doc)]
|
[dest-dir (pick-dest latex-dest doc)]
|
||||||
[fp (send renderer traverse (list v) (list dest-dir))]
|
[fp (send renderer traverse (list v) (list dest-dir))]
|
||||||
[ci (send renderer collect (list v) (list dest-dir) fp)]
|
[ci (send renderer collect (list v) (list dest-dir) fp)]
|
||||||
[ri (send renderer resolve (list v) (list dest-dir) ci)]
|
[ri (send renderer resolve (list v) (list dest-dir) ci)]
|
||||||
[out-v (and info-out-time
|
[out-v (and info-out-time
|
||||||
|
(info-out-time . >= . src-time)
|
||||||
(with-handlers ([exn:fail? (lambda (exn) #f)])
|
(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)))
|
(unless (equal? (car v) (list vers (doc-flags doc)))
|
||||||
(error "old info has wrong version or flags"))
|
(error "old info has wrong version or flags"))
|
||||||
v)))]
|
v)))]
|
||||||
[sci (send renderer serialize-info ri)]
|
[sci (send renderer serialize-info ri)]
|
||||||
[defs (send renderer get-defined ci)]
|
[defs (send renderer get-defined ci)]
|
||||||
|
[undef (send renderer get-undefined ri)]
|
||||||
[searches (resolve-info-searches ri)]
|
[searches (resolve-info-searches ri)]
|
||||||
[need-out-write?
|
[need-out-write?
|
||||||
(or (not out-v)
|
(or (not out-v)
|
||||||
|
@ -534,11 +601,8 @@
|
||||||
(gc-point)
|
(gc-point)
|
||||||
(let ([info
|
(let ([info
|
||||||
(make-info doc
|
(make-info doc
|
||||||
(if need-out-write?
|
defs ; provides
|
||||||
(make-sci-computed sci)
|
undef
|
||||||
(make-sci-cached sci info-out-file setup-printf))
|
|
||||||
defs
|
|
||||||
(send renderer get-undefined ri)
|
|
||||||
searches
|
searches
|
||||||
null ; no deps, yet
|
null ; no deps, yet
|
||||||
null ; no known deps, yet
|
null ; no known deps, yet
|
||||||
|
@ -548,18 +612,20 @@
|
||||||
(/ (current-inexact-milliseconds) 1000)
|
(/ (current-inexact-milliseconds) 1000)
|
||||||
info-out-time)
|
info-out-time)
|
||||||
#t
|
#t
|
||||||
can-run? need-out-write?
|
can-run?
|
||||||
|
need-out-write?
|
||||||
vers
|
vers
|
||||||
#f
|
#f
|
||||||
#f)])
|
#f)])
|
||||||
(when need-out-write?
|
(when need-out-write?
|
||||||
(unless latex-dest
|
(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))
|
(set-info-need-out-write?! info #f))
|
||||||
(when (info-need-in-write? info)
|
(when (info-need-in-write? info)
|
||||||
(unless latex-dest
|
(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))
|
(set-info-need-in-write?! info #f))
|
||||||
|
|
||||||
(when (or (stamp-time . < . aux-time)
|
(when (or (stamp-time . < . aux-time)
|
||||||
(stamp-time . < . src-time))
|
(stamp-time . < . src-time))
|
||||||
(let ([data (list (get-compiled-file-sha1 src-zo)
|
(let ([data (list (get-compiled-file-sha1 src-zo)
|
||||||
|
@ -597,83 +663,86 @@
|
||||||
(time expr)
|
(time expr)
|
||||||
(collect-garbage) (collect-garbage) (printf "post ~a ~s\n" what (current-memory-use)))))
|
(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 (load-sxrefs doc vers)
|
||||||
(define doc (info-doc info))
|
(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))
|
(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
|
(with-record-error
|
||||||
(doc-src-file doc)
|
(doc-src-file doc)
|
||||||
(lambda ()
|
(lambda ()
|
||||||
(parameterize ([current-directory (doc-src-dir doc)])
|
(define vers (send renderer get-serialize-version))
|
||||||
(let* ([v (ensure-doc-prefix (render-time
|
(define-values (ff-undef ff-deps-rel ff-searches ff-dep-dirs ff-sci ff-provides)
|
||||||
"load"
|
(if (info? info)
|
||||||
(dynamic-require-doc (doc-src-spec doc)))
|
(values (info-undef info)
|
||||||
(doc-src-spec doc))]
|
(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)]
|
[dest-dir (pick-dest latex-dest doc)]
|
||||||
[fp (render-time "traverse"
|
[fp (render-time "traverse" (send renderer traverse (list v) (list dest-dir)))]
|
||||||
(send renderer traverse (list v) (list dest-dir)))]
|
[ci (render-time "collect" (send renderer collect (list v) (list dest-dir) fp))]
|
||||||
[ci (render-time "collect"
|
[ri (begin
|
||||||
(send renderer collect (list v) (list dest-dir) fp))])
|
(render-time "deserialize" (with-my-namespace* (for ([dest-dir ff-dep-dirs])
|
||||||
(render-time
|
(send renderer deserialize-info (load-doc-sci dest-dir) ci))))
|
||||||
"deserialize"
|
(render-time "resolve" (send renderer resolve (list v) (list dest-dir) ci)))]
|
||||||
(for ([i (info-deps info)])
|
[sci (render-time "serialize" (send renderer serialize-info ri))]
|
||||||
(when (info? i)
|
[defs (render-time "defined" (send renderer get-defined ci))]
|
||||||
(with-my-namespace
|
[undef (render-time "undefined" (send renderer get-undefined ri))]
|
||||||
(lambda ()
|
[in-delta? (not (equal? (any-order undef) (any-order ff-undef)))]
|
||||||
(send renderer deserialize-info ((info-get-sci i)) ci))))))
|
[out-delta? (or (not (serialized=? sci ff-sci))
|
||||||
(let* ([ri (render-time "resolve" (send renderer resolve (list v) (list dest-dir) ci))]
|
(not (equal? (any-order defs) (any-order ff-provides))))])
|
||||||
[sci (render-time "serialize" (send renderer serialize-info ri))]
|
(when (verbose)
|
||||||
[defs (render-time "defined" (send renderer get-defined ci))]
|
(printf " [~a~afor ~a]\n"
|
||||||
[undef (render-time "undefined" (send renderer get-undefined ri))]
|
(if in-delta? "New in " "")
|
||||||
[in-delta? (not (equal? (any-order undef)
|
(cond [out-delta? "New out "]
|
||||||
(any-order (info-undef info))))]
|
[in-delta? ""]
|
||||||
[out-delta? (or (not (serialized=? sci ((info-get-sci info))))
|
[else "No change "])
|
||||||
(not (equal? (any-order defs)
|
(doc-src-file doc)))
|
||||||
(any-order (info-provides info)))))])
|
|
||||||
(when (verbose)
|
(when in-delta?
|
||||||
(printf " [~a~afor ~a]\n"
|
(unless latex-dest
|
||||||
(if in-delta? "New in " "")
|
(render-time "xref-in" (write-in vers doc undef ff-deps-rel ff-searches ff-dep-dirs))))
|
||||||
(cond [out-delta? "New out "]
|
(when out-delta?
|
||||||
[in-delta? ""]
|
(unless latex-dest
|
||||||
[else "No change "])
|
(render-time "xref-out" (write-out vers doc sci defs))))
|
||||||
(doc-src-file doc)))
|
|
||||||
(when out-delta?
|
(cleanup-dest-dir doc)
|
||||||
(set-info-out-time! info (/ (current-inexact-milliseconds) 1000)))
|
(render-time
|
||||||
(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
|
|
||||||
"render"
|
"render"
|
||||||
(with-record-error
|
(with-record-error
|
||||||
(doc-src-file doc)
|
(doc-src-file doc)
|
||||||
(lambda () (send renderer render (list v) (list dest-dir) ri))
|
(lambda () (send renderer render (list v) (list dest-dir) ri))
|
||||||
void))
|
void))
|
||||||
(set-info-time! info (/ (current-inexact-milliseconds) 1000))
|
(gc-point)
|
||||||
(gc-point)
|
(list in-delta? out-delta? defs undef))))
|
||||||
(void)))))
|
(lambda () #f)))
|
||||||
(lambda () (set-info-failed?! info #t))))
|
|
||||||
|
|
||||||
(define (gc-point)
|
(define (gc-point)
|
||||||
;; Forcing a GC on document boundaries helps keep peak memory use down.
|
;; Forcing a GC on document boundaries helps keep peak memory use down.
|
||||||
|
@ -685,6 +754,10 @@
|
||||||
(parameterize ([current-namespace (namespace-anchor->empty-namespace anchor)])
|
(parameterize ([current-namespace (namespace-anchor->empty-namespace anchor)])
|
||||||
(thunk)))
|
(thunk)))
|
||||||
|
|
||||||
|
(define-syntax-rule (with-my-namespace* body ...)
|
||||||
|
(parameterize ([current-namespace (namespace-anchor->empty-namespace anchor)])
|
||||||
|
body ...))
|
||||||
|
|
||||||
(define (dynamic-require-doc mod-path)
|
(define (dynamic-require-doc mod-path)
|
||||||
;; Use a separate namespace so that we don't end up with all the
|
;; Use a separate namespace so that we don't end up with all the
|
||||||
;; documentation loaded at once.
|
;; documentation loaded at once.
|
||||||
|
@ -703,32 +776,36 @@
|
||||||
(parameterize ([current-namespace p])
|
(parameterize ([current-namespace p])
|
||||||
(call-in-nested-thread (lambda () (dynamic-require mod-path 'doc)))))))
|
(call-in-nested-thread (lambda () (dynamic-require mod-path 'doc)))))))
|
||||||
|
|
||||||
(define (write- info name sel)
|
(define (write- vers doc name data)
|
||||||
(let* ([doc (info-doc info)]
|
(let* ([filename (build-path (doc-dest-dir doc) name)])
|
||||||
[info-file (build-path (doc-dest-dir doc) name)])
|
(when (verbose) (printf " [Caching to disk ~a]\n" filename))
|
||||||
(when (verbose) (printf " [Caching ~a]\n" info-file))
|
(make-directory* (doc-dest-dir doc))
|
||||||
(with-output-to-file info-file #:exists 'truncate/replace
|
(with-compile-output filename
|
||||||
(lambda ()
|
(lambda (out tmp-filename)
|
||||||
(sel (lambda ()
|
(write-bytes (s-exp->fasl (append (list (list vers (doc-flags doc))) data)) out)))))
|
||||||
(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)
|
(define (write-out vers doc sci provides)
|
||||||
(make-directory* (doc-dest-dir (info-doc info)))
|
(write- vers doc "out.sxref"
|
||||||
(write- info "out.sxref" (lambda (o i) (write-bytes (s-exp->fasl (o)))))
|
(list sci
|
||||||
(set-info-get-sci! info
|
(serialize provides))))
|
||||||
(make-sci-cached ((info-get-sci info))
|
|
||||||
(build-path (doc-dest-dir (info-doc info)) "out.sxref")
|
(define (write-out/info info sci)
|
||||||
setup-printf)))
|
(write-out (info-vers info) (info-doc info) sci (info-provides info)))
|
||||||
(define (write-in info)
|
|
||||||
(make-directory* (doc-dest-dir (info-doc info)))
|
(define (write-in vers doc undef rels searches dest-dirs)
|
||||||
(write- info "in.sxref" (lambda (o i) (write-bytes (s-exp->fasl (i))))))
|
(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)
|
(define (rel->path r)
|
||||||
(if (bytes? r)
|
(if (bytes? r)
|
||||||
|
@ -741,10 +818,10 @@
|
||||||
(path->bytes r)
|
(path->bytes r)
|
||||||
r)))
|
r)))
|
||||||
|
|
||||||
(define (convert-deps deps)
|
(define (info-deps->rel-doc-src-file info)
|
||||||
(filter
|
(filter-map (lambda (i) (and (info? i)
|
||||||
values
|
(path->rel (doc-src-file (info-doc i)))))
|
||||||
(map (lambda (i)
|
(info-deps info)))
|
||||||
(and (info? i)
|
|
||||||
(path->rel (doc-src-file (info-doc i)))))
|
(define (info-deps->doc-dest-dir info)
|
||||||
deps)))
|
(filter-map (lambda (i) (and (info? i) (doc-dest-dir (info-doc i)))) (info-deps info)))
|
||||||
|
|
|
@ -786,6 +786,8 @@
|
||||||
|
|
||||||
(define (doc:setup-scribblings latex-dest auto-start-doc?)
|
(define (doc:setup-scribblings latex-dest auto-start-doc?)
|
||||||
(scr:call 'setup-scribblings
|
(scr:call 'setup-scribblings
|
||||||
|
(parallel-workers)
|
||||||
|
name-str
|
||||||
(if no-specific-collections? #f (map cc-path ccs-to-compile))
|
(if no-specific-collections? #f (map cc-path ccs-to-compile))
|
||||||
latex-dest auto-start-doc? (make-user)
|
latex-dest auto-start-doc? (make-user)
|
||||||
(lambda (what go alt) (record-error what "Building docs" go alt))
|
(lambda (what go alt) (record-error what "Building docs" go alt))
|
||||||
|
|
Loading…
Reference in New Issue
Block a user