diff --git a/pollen/private/ts.rktd b/pollen/private/ts.rktd index b5d5b89..1f7abd7 100644 --- a/pollen/private/ts.rktd +++ b/pollen/private/ts.rktd @@ -1 +1 @@ -1572991771 +1572993457 diff --git a/pollen/render.rkt b/pollen/render.rkt index 9e59105..3d5936b 100644 --- a/pollen/render.rkt +++ b/pollen/render.rkt @@ -84,50 +84,70 @@ (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))) + (with-handlers ([exn:fail? (λ (e) (place-channel-put ch (list 'crashed-job path #f)))]) + (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))))) (define poly-target (current-poly-target)) ;; `locks` and `blocks` are (listof (cons/c evt? path?)) - (let loop ([source-paths (sort source-paths stringstring)][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 @ job ~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))))])))] + (define crashed-jobs + (let loop ([source-paths (sort source-paths stringstring)] + [locks-in null] + [blocks-in null] + [crashed-jobs 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. + (cond + [(and (null? source-paths) (null? locks)) crashed-jobs] + [else + (match (apply sync worker-evts) + [(list wpidx wp 'wants-job) + (match source-paths + [(? null?) (loop null locks blocks crashed-jobs)] + [(cons path rest) + (place-channel-put wp (cons path poly-target)) + (loop rest locks blocks crashed-jobs)])] + [(list wpidx wp (and (or 'finished-job 'crashed-job) tag) path ms) + (match tag + ['finished-job + (message + (format "rendered parallel @ job ~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)))))] + [_ + (message + (format "render crash @ job ~a /~a (retry pending)" + (add1 wpidx) + (find-relative-path (current-project-root) (->output-path path))))]) + (loop source-paths + (match (assoc wp locks) + [#false locks] + [lock (remove lock locks)]) + blocks + (match tag + ['crashed-job (cons path crashed-jobs)] + [_ crashed-jobs]))] + [(list wpidx wp 'wants-lock path) + (loop source-paths locks (append blocks (list (cons wp path))) crashed-jobs)])]))) + (for-each render-from-source-or-output-path crashed-jobs)] [else (for-each render-from-source-or-output-path paths-in)])) (define (pagetree->paths pagetree-or-path)