diff --git a/pollen/private/preheat-cache.rkt b/pollen/private/preheat-cache.rkt index 5033ab7..ca7e29f 100644 --- a/pollen/private/preheat-cache.rkt +++ b/pollen/private/preheat-cache.rkt @@ -21,36 +21,43 @@ (define (preheat-cache starting-dir) (unless (and (path-string? starting-dir) (directory-exists? starting-dir)) (raise-argument-error 'preheat-cache "directory" starting-dir)) - (define worker-places (for/list ([i (in-range (processor-count))]) - (place ch - (let loop () - (define result (with-handlers ([exn:fail? (λ (e) #false)]) - (path->hash (place-channel-get ch)))) - (place-channel-put ch result) - (loop))))) - (define paths-that-should-be-cached + + ;; if a file is already in the cache, no need to hit it again. + ;; this allows partially completed preheat jobs to resume. + (define uncached-paths (for/list ([path (in-directory starting-dir)] #:when (for/or ([proc (in-list (list preproc-source? markup-source? markdown-source? pagetree-source?))]) - (proc path))) + (proc path)) + #:unless (path-cached? path)) path)) - ;; if a file is already in the cache, no need to hit it again. - ;; this allows partially completed preheat jobs to resume. - (define uncached-paths (filter-not path-cached? paths-that-should-be-cached)) + (define worker-evts + (for/list ([wpidx (in-range (processor-count))]) + (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. - ;; that way, if there's a failure, the progress is preserved. - ;; but the slowest file in a group will prevent further progress. - (for ([path-group (in-list (slice-at uncached-paths (length worker-places)))]) - (for ([path (in-list path-group)] - [wp (in-list worker-places)]) - (message (format "caching: ~a" (find-relative-path starting-dir path))) - (place-channel-put wp path)) - (for ([path (in-list path-group)] - [wp (in-list worker-places)]) - (match (place-channel-get wp) - [#false (message (format "compile failed: ~a" path))] - [result (cache-ref! (paths->key path) (λ () result))])))) \ No newline at end of file + (let loop ([paths uncached-paths][actives null]) + (unless (and (null? paths) (null? actives)) + (match (apply sync worker-evts) + [(list wpidx wp 'want-job) + (match paths + [(? null?) (loop null actives)] + [(cons path rest) + (place-channel-put wp path) + (message (format "caching on core ~a: ~a" (add1 wpidx) (find-relative-path starting-dir path))) + (loop rest (cons wpidx actives))])] + [(list wpidx wp 'job-finished path result) + (if 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))])))) \ No newline at end of file diff --git a/pollen/render.rkt b/pollen/render.rkt index 7540d71..c812437 100644 --- a/pollen/render.rkt +++ b/pollen/render.rkt @@ -4,6 +4,7 @@ racket/match racket/place racket/list + racket/dict sugar/test sugar/define sugar/file @@ -56,53 +57,78 @@ (reset-mod-date-hash!) (cond [parallel? - (define worker-places - (for/list ([i (in-range (processor-count))]) - (place ch - (let loop () - (match-define (list path poly-target) (place-channel-get ch)) - (define render-result - (let render ([failures 0][exn-msg #f]) - (cond - [(= 3 failures) exn-msg] - [else - (with-handlers ([exn:fail? - (λ (e) - (sleep 0.01) - (render (add1 failures) (exn-message e)))]) - (parameterize ([current-poly-target poly-target]) - (match-define-values (_ _ ms _) - (time-apply render-from-source-or-output-path (list path))) - ms))]))) - (place-channel-put ch render-result) - (loop))))) - - (define flattened-paths - (let loop ([paths paths]) - (if (null? paths) - null - (match (->complete-path (car paths)) - [(? pagetree-source? pt) (append (loop (pagetree->paths pt)) (loop (cdr paths)))] - [path (cons path (loop (cdr paths)))])))) - - (define source-paths (for*/list ([p (in-list flattened-paths)] - [maybe-source-path (in-value (->source-path p))] - #:when (and maybe-source-path (file-exists? maybe-source-path))) - maybe-source-path)) + + (define source-paths + (let () + (define flattened-paths + (remove-duplicates + (sort + (let loop ([paths paths]) + (if (null? paths) + null + (match (->complete-path (car paths)) + [(? pagetree-source? pt) (append (loop (pagetree->paths pt)) (loop (cdr paths)))] + [path (cons path (loop (cdr paths)))]))) + stringstring))) + (for*/list ([p (in-list flattened-paths)] + [maybe-source-path (in-value (->source-path p))] + #:when (and maybe-source-path (file-exists? maybe-source-path))) + maybe-source-path))) + + ;; initialize the workers + (define worker-evts + (for/list ([wpidx (in-range (processor-count))]) + (define wp (place ch + (let loop () + (match-define (cons path poly-target) + (place-channel-put/get ch (list 'wants-job))) + (parameterize ([current-poly-target poly-target]) + (place-channel-put/get ch (list 'wants-lock (->output-path path))) + (match-define-values (_ _ ms _) + (time-apply render-from-source-or-output-path (list path))) + (place-channel-put ch (list 'finished-job path ms))) + (loop)))) + (handle-evt wp (λ (val) (list* wpidx wp val))))) - (for ([source-path-group (in-list (slice-at (shuffle source-paths) (length worker-places)))]) - (for ([source-path (in-list source-path-group)] - [(wp wpidx) (in-indexed worker-places)]) - (place-channel-put wp (list source-path (current-poly-target)))) - (for ([source-path (in-list source-path-group)] - [(wp wpidx) (in-indexed worker-places)]) - (match (place-channel-get wp) - [(? number? ms) - (message (format "rendered parallel on core ~a /~a ~a" - (add1 wpidx) - (find-relative-path (current-project-root) (->output-path source-path)) - (if (< ms 1000) (format "(~a ms)" ms) (format "(~a s)" (/ ms 1000.0)))))] - [exn-msg (raise (exn:fail exn-msg (current-continuation-marks)))])))] + (define poly-target (current-poly-target)) + + ;; `locks` and `blocks` are (listof (cons/c evt? path?)) + (let loop ([source-paths source-paths][locks-in null][blocks-in null]) + ;; try to unblock blocked workers + (define-values (locks blocks) + (for/fold ([locks locks-in] + [blocks null]) + ([block (in-list blocks-in)]) + (match-define (cons wp path) block) + (cond + [(member path (dict-values locks)) + (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)])) (define (pagetree->paths pagetree-or-path) @@ -271,22 +297,28 @@ (define template-path (or maybe-template-path (get-template-for source-path output-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)) - - (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)] [current-namespace (make-base-namespace)]) (define outer-ns (namespace-anchor->namespace render-module-ns)) - (namespace-attach-module outer-ns 'pollen/setup) - (eval (with-syntax ([MODNAME (gensym)] - [SOURCE-PATH-STRING (->string source-path)] - [TEMPLATE-PATH-STRING (->string template-path)]) - #'(begin - (module MODNAME pollen/private/render-helper - #:source SOURCE-PATH-STRING - #:template TEMPLATE-PATH-STRING - #:result-id result) - (require 'MODNAME) - result))))) + (namespace-attach-module outer-ns 'pollen/setup) + (begin0 + (eval (with-syntax ([MODNAME (gensym)] + [SOURCE-PATH-STRING (->string source-path)] + [TEMPLATE-PATH-STRING (->string temp-template)]) + #'(begin + (module MODNAME pollen/private/render-helper + #:source SOURCE-PATH-STRING + #:template TEMPLATE-PATH-STRING + #:result-id result) + (require 'MODNAME) + result))) + (delete-file temp-template)))) (define (templated-source? path) (or (markup-source? path) (markdown-source? path)))