Skip to content

Commit b6c8f11

Browse files
gerdintgerdint
committed
Add process pool to lower memory usage
Defaults to 1.5*<number-of-cores> concurrent processes
1 parent f99986e commit b6c8f11

File tree

1 file changed

+89
-47
lines changed

1 file changed

+89
-47
lines changed

‎frog/responsive-images.rkt

+89-47
Original file line numberDiff line numberDiff line change
@@ -10,6 +10,8 @@
1010
racket/port
1111
racket/system
1212
racket/string
13+
(only-in racket/future processor-count)
14+
(only-in racket/match match-let-values)
1315
rackjure/threading
1416
rackjure/str
1517
"params.rkt"
@@ -22,7 +24,7 @@
2224
(module+ test
2325
(require rackunit))
2426

25-
(define resize-procs '()) ; Use hash?
27+
(define *max-jobs* (* 1.5 (processor-count))) ; Arbitrary heuristic
2628

2729
;; Depend on ImageMagick
2830
(define identify (find-executable-path "identify"))
@@ -31,65 +33,105 @@
3133
(define magick-available? (and identify mogrify))
3234

3335
(define (image-width path)
34-
(~> (with-output-to-string
35-
(λ ()
36-
(system* identify "-format" "%w" path)))
37-
string-trim
38-
string->number))
36+
(if (file-exists? path)
37+
(~> (with-output-to-string
38+
(λ ()
39+
(system* identify "-format" "%w" path)))
40+
string-trim
41+
string->number)
42+
(raise-argument-error 'image-width "Existing file" path)))
3943

4044
(module+ test
4145
(when magick-available?
4246
(parameterize ([top example]
4347
[current-verbosity 99])
4448
(check-eq? (image-width (build-path (www/img-path) "800px-image.gif")) 800))))
4549

50+
(struct job (input out-path width) #:transparent)
51+
52+
(define (magick-args j)
53+
;; Imagemagick options from
54+
;; https://www.smashingmagazine.com/2015/06/efficient-image-resizing-with-
55+
;; imagemagick/
56+
`("-filter" "Triangle"
57+
"-define" "filter:support=2"
58+
"-unsharp" "0.25x0.08+8.3+0.045"
59+
"-dither" "None"
60+
"-posterize" "136"
61+
"-quality" "82"
62+
"-define" "jpeg:fancy-upsampling=off"
63+
"-define" "png:compression-filter=5"
64+
"-define" "png:compression-level=9"
65+
"-define" "png:compression-strategy=1"
66+
"-define" "png:exclude-chunk=all"
67+
"-interlace" "none"
68+
"-colorspace" "sRGB"
69+
"-thumbnail" ,(number->string (job-width j))
70+
"-path" ,(job-out-path j)
71+
,(job-input j)))
72+
73+
(define master-worker
74+
(thread
75+
(λ ()
76+
(define (start-job j)
77+
(match-let-values ([(proc _ _ _) (apply subprocess
78+
(current-output-port)
79+
(current-input-port)
80+
(current-error-port)
81+
mogrify (magick-args j))])
82+
proc))
83+
;; N.B: Config parameters set in the main thread are reset here
84+
;; so make sure we do not rely on them. In particular prn1 and
85+
;; prn2 will not output anything.
86+
(let ([finish #f]
87+
[mailbox (thread-receive-evt)])
88+
(let loop ([queue '()]
89+
[procs '()])
90+
(let ([res (apply sync mailbox procs)])
91+
(cond
92+
[(subprocess? res) ; Process terminated?
93+
(let ([status (subprocess-status res)])
94+
(unless (zero? status)
95+
(eprintf "~a terminated with non-zero exit code: ~a\n"
96+
mogrify status)))
97+
(let ([next-procs (remq res procs)])
98+
(if (not (empty? queue))
99+
(begin
100+
(let ([proc (start-job (first queue))])
101+
(loop (rest queue) (cons proc next-procs))))
102+
(unless (and (empty? next-procs) finish)
103+
(loop queue next-procs))))]
104+
[(eq? res mailbox)
105+
(let ([msg (thread-receive)])
106+
(cond
107+
[(eq? msg 'finish)
108+
(set! finish #t)
109+
(unless (empty? procs)
110+
(displayln "Waiting for ImageMagick processes to finish.")
111+
(loop queue procs))]
112+
[(job? msg)
113+
(let ([j msg])
114+
(if (>= (length procs) *max-jobs*)
115+
(loop (append queue (list j)) procs) ; FIFO queue semantics
116+
(let ([proc (start-job j)])
117+
(loop queue (cons proc procs)))))]))]
118+
[else
119+
(error "Unknown sync result: " res)
120+
(loop queue procs)])))))))
121+
46122
(define/contract (resize-image input new-width out-path)
47123
(path? number? path? . -> . void?)
48-
(prn1 "Shrinking ~a to ~a pixels... " (abs->rel/www input) new-width)
49-
;; Imagemagick options from
50-
;; https://www.smashingmagazine.com/2015/06/efficient-image-resizing-with-imagemagick/
51-
(define args
52-
`("-filter" "Triangle" "-define" "filter:support=2"
53-
"-unsharp" "0.25x0.08+8.3+0.045" "-dither" "None" "-posterize" "136"
54-
"-quality" "82" "-define" "jpeg:fancy-upsampling=off"
55-
"-define" "png:compression-filter=5" "-define" "png:compression-level=9"
56-
"-define" "png:compression-strategy=1" "-define" "png:exclude-chunk=all"
57-
"-interlace" "none" "-colorspace" "sRGB"
58-
"-thumbnail" ,(number->string new-width)
59-
"-path" ,out-path ,input))
60-
;; Make simple job server using dispatcher thread and thread mailboxes?
61-
;;
124+
(prn1 "Shrinking ~a to ~a pixels asynchronously." (abs->rel/www input) new-width)
62125
;; One problem with the async approach is that if Frog is killed before
63126
;; subprocesses are finished they will not be triggered again if Frog is
64127
;; invoked again and the source post has not been touched. Ideally we would
65128
;; trap SIGINT and write out unfinished work to disk, or at least
66-
;; detect that work was finished prematurely and restart everything somehow.
67-
(let-values ([(proc in out err) (apply subprocess
68-
(current-output-port)
69-
(current-input-port)
70-
(current-error-port)
71-
mogrify args)])
72-
(set! resize-procs (cons proc resize-procs))
73-
(prn2 "Spawned ImageMagick in subprocess for ~a" (abs->rel/www input))))
74-
75-
(define wait-resize-images
76-
(let ([wait-notice-displayed? #f])
77-
(λ ()
78-
(unless (empty? resize-procs)
79-
(unless wait-notice-displayed?
80-
;; Indicate number of processes left?
81-
(prn0 "Waiting for any image resize processes to finish.")
82-
(set! wait-notice-displayed? #t))
83-
(let* ([p (apply sync resize-procs)]
84-
[status (subprocess-status p)])
85-
(if (eq? status 'running)
86-
(wait-resize-images)
87-
(begin
88-
(unless (zero? status)
89-
(eprintf "~a finished with non-zero exit code: ~a\n"
90-
mogrify status))
91-
(set! resize-procs (remq p resize-procs))
92-
(wait-resize-images))))))))
129+
;; detect that work was finished prematurely and clean and restart everything.
130+
(thread-send master-worker (job input out-path new-width)))
131+
132+
(define (wait-resize-images)
133+
(thread-send master-worker 'finish)
134+
(thread-wait master-worker))
93135

94136
(module+ test
95137
(when magick-available?

0 commit comments

Comments
 (0)