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

better handling of job-count and completed-jobs

Browse Source
pull/218/head
Matthew Butterick 5 years ago
parent 20ab9371d8
commit 0345260119
3 changed files with 44 additions and 37 deletions
Show Stats Download Patch File Download Diff File

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

@ -30,9 +30,9 @@
markup-source? markup-source?
markdown-source? markdown-source?
pagetree-source?))]) pagetree-source?))])
(proc path)) (proc path))
#:unless (path-cached? path)) #:unless (path-cached? path))
(path->complete-path path))) (path->complete-path path)))
(cond (cond
[(null? uncached-paths) [(null? uncached-paths)
@ -40,22 +40,24 @@
[wants-parallel-setup [wants-parallel-setup
(define job-count (define job-count
(match wants-parallel-setup (min
[#true (processor-count)] (length uncached-paths)
[(? exact-positive-integer? count) count] (match wants-parallel-setup
[_ (raise-argument-error 'preheat-cache "exact positive integer" wants-parallel-setup)])) [#true (processor-count)]
[(? exact-positive-integer? count) count]
[_ (raise-argument-error 'preheat-cache "exact positive integer" wants-parallel-setup)])))
(define worker-evts (define worker-evts
(for/list ([wpidx (in-range job-count)]) (for/list ([wpidx (in-range job-count)])
(define wp (define wp
(place ch (place ch
(let loop () (let loop ()
(define path (place-channel-put/get ch (list 'want-job))) (define path (place-channel-put/get ch (list 'want-job)))
(place-channel-put ch (list 'job-finished path (place-channel-put ch (list 'job-finished path
(with-handlers ([exn:fail? (λ (e) #f)]) (with-handlers ([exn:fail? (λ (e) #f)])
(path->hash path)))) (path->hash path))))
(loop)))) (loop))))
(handle-evt wp (λ (val) (list* wpidx wp val))))) (handle-evt wp (λ (val) (list* wpidx wp val)))))
(let loop ([paths uncached-paths][actives null]) (let loop ([paths uncached-paths][actives null])
(unless (and (null? paths) (null? actives)) (unless (and (null? paths) (null? actives))
@ -73,7 +75,7 @@
(message (format "caching failed on job ~a: ~a" (add1 wpidx) (find-relative-path starting-dir path)))) (message (format "caching failed on job ~a: ~a" (add1 wpidx) (find-relative-path starting-dir path))))
(loop paths (remq wpidx actives))])))] (loop paths (remq wpidx actives))])))]
[else (for ([path (in-list uncached-paths)]) [else (for ([path (in-list uncached-paths)])
(message (format "caching: ~a" (find-relative-path starting-dir path))) (message (format "caching: ~a" (find-relative-path starting-dir path)))
(match (with-handlers ([exn:fail? (λ (e) #f)]) (path->hash path)) (match (with-handlers ([exn:fail? (λ (e) #f)]) (path->hash path))
[#false (message (format "caching failed: ~a" (find-relative-path starting-dir path)))] [#false (message (format "caching failed: ~a" (find-relative-path starting-dir path)))]
[result (cache-ref! (paths->key path) (λ () result))]))])) [result (cache-ref! (paths->key path) (λ () result))]))]))

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

@ -1 +1 @@
1572998291 1573004144

39
pollen/render.rkt
Unescape Escape View File

@ -67,10 +67,12 @@
[_ (loop (cdr paths) acc)]))) [_ (loop (cdr paths) acc)])))
(define job-count (define job-count
(match wants-parallel-render (min
[#true (processor-count)] (length source-paths)
[(? exact-positive-integer? count) count] (match wants-parallel-render
[_ (raise-argument-error 'render-batch "exact positive integer" wants-parallel-render)])) [#true (processor-count)]
[(? exact-positive-integer? count) count]
[_ (raise-argument-error 'render-batch "exact positive integer" wants-parallel-render)])))
;; initialize the workers ;; initialize the workers
(define worker-evts (define worker-evts
@ -93,11 +95,14 @@
(define poly-target (current-poly-target)) (define poly-target (current-poly-target))
;; `locks` and `blocks` are (listof (cons/c evt? path?)) ;; `locks` and `blocks` are (listof (cons/c evt? path?))
(define starting-source-paths (sort source-paths string<? #:key path->string))
(define crashed-jobs (define crashed-jobs
(let loop ([source-paths (sort source-paths string<? #:key path->string)] (let loop ([source-paths starting-source-paths]
[locks-in null] [locks-in null]
[blocks-in null] [blocks-in null]
[crashed-jobs null]) ;; `completed-jobs` is (listof (cons/c path? boolean?))
[completed-jobs null]
[completed-job-count 0])
;; try to unblock blocked workers ;; try to unblock blocked workers
(define-values (locks blocks) (define-values (locks blocks)
(for/fold ([locks locks-in] (for/fold ([locks locks-in]
@ -109,20 +114,21 @@
(values locks (cons block blocks))] (values locks (cons block blocks))]
[else [else
(place-channel-put wp 'lock-approved) (place-channel-put wp 'lock-approved)
(values (cons block locks) blocks)]))) (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 (other than crashed jobs)
(cond (cond
[(and (null? source-paths) (null? locks)) crashed-jobs] [(eq? completed-job-count (length starting-source-paths))
;; crashed jobs are completed jobs that weren't finished
(for/list ([(path finished?) (in-dict completed-jobs)]
#:unless finished?)
path)]
[else [else
(match (apply sync worker-evts) (match (apply sync worker-evts)
[(list wpidx wp 'wants-job) [(list wpidx wp 'wants-job)
(match source-paths (match source-paths
[(? null?) (loop null locks blocks crashed-jobs)] [(? null?) (loop null locks blocks completed-jobs completed-job-count)]
[(cons path rest) [(cons path rest)
(place-channel-put wp (cons path poly-target)) (place-channel-put wp (cons path poly-target))
(loop rest locks blocks crashed-jobs)])] (loop rest locks blocks completed-jobs completed-job-count)])]
[(list wpidx wp (and (or 'finished-job 'crashed-job) tag) path ms) [(list wpidx wp (and (or 'finished-job 'crashed-job) tag) path ms)
(match tag (match tag
['finished-job ['finished-job
@ -141,11 +147,10 @@
[#false locks] [#false locks]
[lock (remove lock locks)]) [lock (remove lock locks)])
blocks blocks
(match tag (cons (cons path (eq? tag 'finished-job)) completed-jobs)
['crashed-job (cons path crashed-jobs)] (add1 completed-job-count))]
[_ crashed-jobs]))]
[(list wpidx wp 'wants-lock path) [(list wpidx wp 'wants-lock path)
(loop source-paths locks (append blocks (list (cons wp path))) crashed-jobs)])]))) (loop source-paths locks (append blocks (list (cons wp path))) completed-jobs completed-job-count)])])))
;; second bite at the apple for crashed jobs. ;; second bite at the apple for crashed jobs.
;; 1) many crashes that arise in parallel rendering are ;; 1) many crashes that arise in parallel rendering are
;; a result of concurrency issues (e.g. shared files not being readable at the right moment). ;; a result of concurrency issues (e.g. shared files not being readable at the right moment).

Write Preview
Loading…
Cancel
Save