recover from crashed parallel renders

pollen/private/ts.rktd

@@ -1 +1 @@
-1572991771
+1572993457

pollen/render.rkt

@@ -84,16 +84,21 @@
                                        (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)))
+                                       (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)))
+                                         (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 string<? #:key path->string)][locks-in null][blocks-in null])
+     (define crashed-jobs
+       (let loop ([source-paths (sort source-paths string<? #:key path->string)]
+                  [locks-in null]
+                  [blocks-in null]
+                  [crashed-jobs null])
          ;; try to unblock blocked workers
          (define-values (locks blocks)
            (for/fold ([locks locks-in]
@@ -109,25 +114,40 @@
          ;; 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))
+         (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)]
+                 [(? null?) (loop null locks blocks crashed-jobs)]
                  [(cons path rest)
                   (place-channel-put wp (cons path poly-target))
-               (loop rest locks blocks)])]
+                  (loop rest locks blocks crashed-jobs)])]
-           [(list wpidx wp 'finished-job path ms)
+              [(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)))))
+                           (if (< ms 1000) (format "(~a ms)" ms) (format "(~a s)" (/ ms 1000.0)))))]
-            (loop source-paths (match (assoc wp locks)
+                 [_
+                  (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)]
+                       [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))))])))]
+               (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)