parallel rendering

pollen/private/command.rkt

@@ -83,6 +83,7 @@ version                print the version" (current-server-port) (make-publish-di
   (define make-project-pagetree (dynamic-require 'pollen/pagetree 'make-project-pagetree))
   (define render-target-wanted (make-parameter (current-poly-target)))
   (define render-with-subdirs? (make-parameter #f))
+  (define render-parallel? (make-parameter #f))
   (define parsed-args
     (command-line #:program "raco pollen render"
                   #:argv (vector-drop (current-command-line-arguments) 1) ; snip the 'render' from the front
@@ -92,6 +93,7 @@ version                print the version" (current-server-port) (make-publish-di
                   [("-r" "--recursive") "Render subdirectories recursively"
                                         (render-with-subdirs? 'recursive)]
                   [("-s" "--subdir") "Render subdirectories nonrecursively" (render-with-subdirs? 'include)]
+                  [("-p" "--parallel") "Render in parallel" (render-parallel? #true)]
                   #:args other-args
                   other-args)) 
   (parameterize ([current-poly-target (render-target-wanted)]) ;; applies to both cases
@@ -120,7 +122,7 @@ version                print the version" (current-server-port) (make-publish-di
                       [else
                        (message (format "rendering preproc & pagetree files in directory ~a" dir))
                        (append preprocs static-pagetrees)])))
-             (apply render-batch batch-to-render)
+             (keyword-apply render-batch '(#:parallel) (list (render-parallel?)) batch-to-render)
              (when (render-with-subdirs?)
                (for ([path (in-list dirlist)]
                      #:when (and (directory-exists? path)
@@ -128,7 +130,7 @@ version                print the version" (current-server-port) (make-publish-di
                     (render-one-dir (->complete-path path))))))]
         [path-args ;; path mode
          (message (format "rendering ~a" (string-join (map ->string path-args) " ")))
-         (apply render-batch (map very-nice-path path-args))]))))
+         (keyword-apply render-batch '(#:parallel) (list (render-parallel?)) (map very-nice-path path-args))]))))
 
 (define (handle-start)
   (define launch-wanted #f)

pollen/private/ts.rktd

@@ -1 +1 @@
-1556040851
+1556041577

pollen/render.rkt

@@ -2,10 +2,12 @@
 (require racket/file
          racket/path
          racket/match
+         racket/place
          sugar/test
          sugar/define
          sugar/file
          sugar/coerce
+         sugar/list
          version/utils
          "private/file-utils.rkt"
          "cache.rkt"
@@ -44,22 +46,59 @@
 
 (define (list-of-pathish? x) (and (list? x) (andmap pathish? x)))
 
-(define+provide/contract (render-batch . xs)
+(define+provide/contract (render-batch #:parallel [parallel? #false] . paths)
-  (() #:rest list-of-pathish? . ->* . void?)
+  ((#:parallel any/c) #:rest list-of-pathish? . ->* . void?)
   ;; Why not just (for-each render ...)?
   ;; Because certain files will pass through multiple times (e.g., templates)
   ;; And with render, they would be rendered repeatedly.
   ;; Using reset-modification-dates is sort of like session control.
-  (reset-mod-date-hash!) 
+  (reset-mod-date-hash!)
-  (for-each render-from-source-or-output-path xs))
+  (cond
+    [parallel?
+     (define worker-places
+       (for/list ([i (in-range (processor-count))])
+         (place ch
+                (let loop ()
+                  (define result
+                    (with-handlers ([exn:fail? (λ (e) #false)])
+                      (render-from-source-or-output-path (place-channel-get ch))
+                      #true))
+                  (place-channel-put ch result)
+                  (loop)))))
 
-(define+provide/contract (render-pagenodes pagetree-or-path)
+     (define flattened-paths
-  ((or/c pagetree? pathish?) . -> . void?)
+       (filter file-exists?
+               (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)))])))))
+           
+     (for ([path-group (in-list (slice-at flattened-paths (length worker-places)))])
+       (for ([path (in-list path-group)]
+             [(wp wpidx) (in-indexed worker-places)])
+         (message (format "rendering parallel on core ~a /~a" (add1 wpidx)
+                          (find-relative-path (current-project-root) (->source-path path))))
+         (place-channel-put wp path))
+       (for ([path (in-list path-group)]
+             [(wp wpidx) (in-indexed worker-places)])
+         (message (format "rendered parallel on core ~a /~a" (add1 wpidx)
+                          (find-relative-path (current-project-root) (->output-path path))))
+         (place-channel-get wp)))]
+    [else
+     (for-each render-from-source-or-output-path paths)]))
+
+(define (pagetree->paths pagetree-or-path)
   (define pagetree (if (pagetree? pagetree-or-path)
                        pagetree-or-path
                        (cached-doc pagetree-or-path)))
   (parameterize ([current-directory (current-project-root)])
-    (apply render-batch (map ->complete-path (pagetree->list pagetree)))))
+    (map ->complete-path (pagetree->list pagetree))))
+
+(define+provide/contract (render-pagenodes pagetree-or-path)
+  ((or/c pagetree? pathish?) . -> . void?)
+  (apply render-batch (pagetree->paths pagetree-or-path)))
 
 (define+provide/contract (render-from-source-or-output-path so-pathish)
   (pathish? . -> . void?)