mbutterick
/
pollen
3
3
Fork 0
Code Issues 1 Pull Requests Projects Releases Wiki Activity

parallel-rendering fixes

Browse Source
dev-jobs-flag
Matthew Butterick 5 years ago
parent 88fe03e83b
commit 7b47cac273
3 changed files with 125 additions and 87 deletions
Show Stats Download Patch File Download Diff File

57
pollen/private/preheat-cache.rkt
Unescape Escape View File

@ -21,36 +21,43 @@
(define (preheat-cache starting-dir) (define (preheat-cache starting-dir)
(unless (and (path-string? starting-dir) (directory-exists? starting-dir)) (unless (and (path-string? starting-dir) (directory-exists? starting-dir))
(raise-argument-error 'preheat-cache "directory" starting-dir)) (raise-argument-error 'preheat-cache "directory" starting-dir))
(define worker-places (for/list ([i (in-range (processor-count))])
(place ch ;; if a file is already in the cache, no need to hit it again.
(let loop () ;; this allows partially completed preheat jobs to resume.
(define result (with-handlers ([exn:fail? (λ (e) #false)]) (define uncached-paths
(path->hash (place-channel-get ch))))
(place-channel-put ch result)
(loop)))))
(define paths-that-should-be-cached
(for/list ([path (in-directory starting-dir)] (for/list ([path (in-directory starting-dir)]
#:when (for/or ([proc (in-list (list preproc-source? #:when (for/or ([proc (in-list (list preproc-source?
markup-source? markup-source?
markdown-source? markdown-source?
pagetree-source?))]) pagetree-source?))])
(proc path))) (proc path))
#:unless (path-cached? path))
path)) path))
;; if a file is already in the cache, no need to hit it again. (define worker-evts
;; this allows partially completed preheat jobs to resume. (for/list ([wpidx (in-range (processor-count))])
(define uncached-paths (filter-not path-cached? paths-that-should-be-cached)) (define wp
(place ch
(let loop ()
(define path (place-channel-put/get ch (list 'want-job)))
(place-channel-put ch (list 'job-finished path
(with-handlers ([exn:fail? (λ (e) #f)])
(path->hash path))))
(loop))))
(handle-evt wp (λ (val) (list* wpidx wp val)))))
;; compile the paths in groups, so they can be incrementally saved. (let loop ([paths uncached-paths][actives null])
;; that way, if there's a failure, the progress is preserved. (unless (and (null? paths) (null? actives))
;; but the slowest file in a group will prevent further progress. (match (apply sync worker-evts)
(for ([path-group (in-list (slice-at uncached-paths (length worker-places)))]) [(list wpidx wp 'want-job)
(for ([path (in-list path-group)] (match paths
[wp (in-list worker-places)]) [(? null?) (loop null actives)]
(message (format "caching: ~a" (find-relative-path starting-dir path))) [(cons path rest)
(place-channel-put wp path)) (place-channel-put wp path)
(for ([path (in-list path-group)] (message (format "caching on core ~a: ~a" (add1 wpidx) (find-relative-path starting-dir path)))
[wp (in-list worker-places)]) (loop rest (cons wpidx actives))])]
(match (place-channel-get wp) [(list wpidx wp 'job-finished path result)
[#false (message (format "compile failed: ~a" path))] (if result
[result (cache-ref! (paths->key path) (λ () result))])))) (cache-ref! (paths->key path) (λ () result))
(message (format "caching failed on core ~a: ~a" (add1 wpidx) (find-relative-path starting-dir path))))
(loop paths (remq wpidx actives))]))))

2
pollen/private/ts.rktd
Unescape Escape View File

@ -1 +1 @@
1560481034 1561571116

153
pollen/render.rkt
Unescape Escape View File

@ -4,6 +4,7 @@
racket/match racket/match
racket/place racket/place
racket/list racket/list
racket/dict
sugar/test sugar/test
sugar/define sugar/define
sugar/file sugar/file
@ -55,55 +56,79 @@
;; Using reset-modification-dates is sort of like session control. ;; Using reset-modification-dates is sort of like session control.
(reset-mod-date-hash!) (reset-mod-date-hash!)
(cond (cond
;; disable parallel processing until concurrency problems are sorted [parallel?
#;[parallel?
(define worker-places (define source-paths
(for/list ([i (in-range (processor-count))]) (let ()
(place ch (define flattened-paths
(let loop () (remove-duplicates
(match-define (list path poly-target) (place-channel-get ch)) (sort
(define render-result (let loop ([paths paths])
(let render ([failures 0][exn-msg #f]) (if (null? paths)
(cond null
[(= 3 failures) exn-msg] (match (->complete-path (car paths))
[else [(? pagetree-source? pt) (append (loop (pagetree->paths pt)) (loop (cdr paths)))]
(with-handlers ([exn:fail? [path (cons path (loop (cdr paths)))])))
(λ (e) string<?
(sleep 0.01) #:key path->string)))
(render (add1 failures) (exn-message e)))]) (for*/list ([p (in-list flattened-paths)]
(parameterize ([current-poly-target poly-target]) [maybe-source-path (in-value (->source-path p))]
(match-define-values (_ _ ms _) #:when (and maybe-source-path (file-exists? maybe-source-path)))
(time-apply render-from-source-or-output-path (list path))) maybe-source-path)))
ms))])))
(place-channel-put ch render-result) ;; initialize the workers
(loop))))) (define worker-evts
(for/list ([wpidx (in-range (processor-count))])
(define flattened-paths (define wp (place ch
(let loop ([paths paths]) (let loop ()
(if (null? paths) (match-define (cons path poly-target)
null (place-channel-put/get ch (list 'wants-job)))
(match (->complete-path (car paths)) (parameterize ([current-poly-target poly-target])
[(? pagetree-source? pt) (append (loop (pagetree->paths pt)) (loop (cdr paths)))] (place-channel-put/get ch (list 'wants-lock (->output-path path)))
[path (cons path (loop (cdr paths)))])))) (match-define-values (_ _ ms _)
(time-apply render-from-source-or-output-path (list path)))
(define source-paths (for*/list ([p (in-list flattened-paths)] (place-channel-put ch (list 'finished-job path ms)))
[maybe-source-path (in-value (->source-path p))] (loop))))
#:when (and maybe-source-path (file-exists? maybe-source-path))) (handle-evt wp (λ (val) (list* wpidx wp val)))))
maybe-source-path))
(for ([source-path-group (in-list (slice-at (shuffle source-paths) (length worker-places)))]) (define poly-target (current-poly-target))
(for ([source-path (in-list source-path-group)]
[(wp wpidx) (in-indexed worker-places)]) ;; `locks` and `blocks` are (listof (cons/c evt? path?))
(place-channel-put wp (list source-path (current-poly-target)))) (let loop ([source-paths source-paths][locks-in null][blocks-in null])
(for ([source-path (in-list source-path-group)] ;; try to unblock blocked workers
[(wp wpidx) (in-indexed worker-places)]) (define-values (locks blocks)
(match (place-channel-get wp) (for/fold ([locks locks-in]
[(? number? ms) [blocks null])
(message (format "rendered parallel on core ~a /~a ~a" ([block (in-list blocks-in)])
(add1 wpidx) (match-define (cons wp path) block)
(find-relative-path (current-project-root) (->output-path source-path)) (cond
(if (< ms 1000) (format "(~a ms)" ms) (format "(~a s)" (/ ms 1000.0)))))] [(member path (dict-values locks))
[exn-msg (raise (exn:fail exn-msg (current-continuation-marks)))])))] (values locks (cons block blocks))]
[else
(place-channel-put wp 'lock-approved)
(values (cons block locks) blocks)])))
;; no source paths means all jobs have been assigned
;; no locks means no jobs are in progress
;; therefore we must be done.
(unless (and (null? source-paths) (null? locks))
(match (apply sync worker-evts)
[(list wpidx wp 'wants-job)
(match source-paths
[(? null?) (loop null locks blocks)]
[(cons path rest)
(place-channel-put wp (cons path poly-target))
(loop rest locks blocks)])]
[(list wpidx wp 'finished-job path ms)
(message
(format "rendered parallel on core ~a /~a ~a"
(add1 wpidx)
(find-relative-path (current-project-root) (->output-path path))
(if (< ms 1000) (format "(~a ms)" ms) (format "(~a s)" (/ ms 1000.0)))))
(loop source-paths (match (assoc wp locks)
[#false locks]
[lock (remove lock locks)]) blocks)]
[(list wpidx wp 'wants-lock path)
(loop source-paths locks (append blocks (list (cons wp path))))])))]
[else (for-each render-from-source-or-output-path paths)])) [else (for-each render-from-source-or-output-path paths)]))
(define (pagetree->paths pagetree-or-path) (define (pagetree->paths pagetree-or-path)
@ -272,22 +297,28 @@
(define template-path (or maybe-template-path (get-template-for source-path output-path))) (define template-path (or maybe-template-path (get-template-for source-path output-path)))
(unless template-path (unless template-path
(raise-argument-error 'render-markup-or-markdown-source (format "valid template path~a" (if (has-inner-poly-ext? source-path) (format " for target ~a" (current-poly-target)) "")) template-path)) (raise-argument-error 'render-markup-or-markdown-source (format "valid template path~a" (if (has-inner-poly-ext? source-path) (format " for target ~a" (current-poly-target)) "")) template-path))
(render-from-source-or-output-path template-path) ; because template might have its own preprocessor source ;; use a temp file so that multiple (possibly parallel) renders
;; do not compete for write access to the same template
(define temp-template (make-temporary-file "pollentmp~a"
(or (->source-path template-path) template-path)))
(render-from-source-or-output-path temp-template) ; because template might have its own preprocessor source
(parameterize ([current-output-port (current-error-port)] (parameterize ([current-output-port (current-error-port)]
[current-namespace (make-base-namespace)]) [current-namespace (make-base-namespace)])
(define outer-ns (namespace-anchor->namespace render-module-ns)) (define outer-ns (namespace-anchor->namespace render-module-ns))
(namespace-attach-module outer-ns 'pollen/setup) (namespace-attach-module outer-ns 'pollen/setup)
(eval (with-syntax ([MODNAME (gensym)] (begin0
[SOURCE-PATH-STRING (->string source-path)] (eval (with-syntax ([MODNAME (gensym)]
[TEMPLATE-PATH-STRING (->string template-path)]) [SOURCE-PATH-STRING (->string source-path)]
#'(begin [TEMPLATE-PATH-STRING (->string temp-template)])
(module MODNAME pollen/private/render-helper #'(begin
#:source SOURCE-PATH-STRING (module MODNAME pollen/private/render-helper
#:template TEMPLATE-PATH-STRING #:source SOURCE-PATH-STRING
#:result-id result) #:template TEMPLATE-PATH-STRING
(require 'MODNAME) #:result-id result)
result))))) (require 'MODNAME)
result)))
(delete-file temp-template))))
(define (templated-source? path) (define (templated-source? path)
(or (markup-source? path) (markdown-source? path))) (or (markup-source? path) (markdown-source? path)))

Write Preview
Loading…
Cancel
Save