suzanne.soy/racket
1
0
Fork 0
Code Issues Pull Requests Actions Packages Projects Releases Wiki Activity

racket/draw: fix problem with concurrent PNG read and write

Browse Source 
Same memory-management mistake as for the JPEG binding.
This commit is contained in:
Matthew Flatt 2012-12-22 08:17:51 -07:00
parent a09c8f1857
commit 1545ed42c8
3 changed files with 68 additions and 44 deletions
Show Stats Download Patch File Download Diff File Expand all files Collapse all files

31
collects/racket/draw/unsafe/png.rkt
View File

@ -116,20 +116,25 @@
_int _int _int _int
-> _void))
(define current-fun-keep (make-parameter #f))
(define-png png_set_read_fn (_fun _png_structp
_pointer
(_fun _png_structp
(_fun #:keep (lambda (v) ((current-fun-keep) v))
_png_structp
_pointer
_png_size_t
-> _void)
-> _void))
(define-png png_set_write_fn (_fun _png_structp
_pointer
(_fun _png_structp
(_fun #:keep (lambda (v) ((current-fun-keep) v))
_png_structp
_pointer
_png_size_t
-> _void)
(_fun _png_structp
(_fun #:keep (lambda (v) ((current-fun-keep) v))
_png_structp
-> _void)
-> _void))
(define-png png_get_io_ptr (_fun _png_structp -> _pointer))
@ -205,7 +210,7 @@
(define (read-png-bytes png p len)
(let ([bstr (scheme_make_sized_byte_string p len 0)])
(read-bytes! bstr (ptr-ref (png_get_io_ptr png) _scheme))))
(read-bytes! bstr (car (ptr-ref (png_get_io_ptr png) _scheme)))))
(define free-cell ((deallocator) free-immobile-cell))
(define make-cell ((allocator free-cell) malloc-immobile-cell))
@ -213,8 +218,11 @@
(define (create-png-reader in keep-alpha? bg-rgb)
(let* ([png (png_create_read_struct PNG_LIBPNG_VER_STRING #f error-esc void)]
[info (png_create_info_struct png)]
[ib (make-cell in)])
(png_set_read_fn png ib read-png-bytes)
[funs (box null)]
[ib (make-cell (cons in funs))])
(parameterize ([current-fun-keep (lambda (v)
(set-box! funs (cons v (unbox funs))))])
(png_set_read_fn png ib read-png-bytes))
(png_read_info png info)
(let-values ([(w h depth color-type
interlace-type compression-type filter-type)
@ -327,16 +335,19 @@
(define (write-png-bytes png p len)
(let ([bstr (scheme_make_sized_byte_string p len 0)])
(write-bytes bstr (ptr-ref (png_get_io_ptr png) _scheme))))
(write-bytes bstr (car (ptr-ref (png_get_io_ptr png) _scheme)))))
(define (flush-png-bytes png)
(flush-output (ptr-ref (png_get_io_ptr png) _scheme)))
(flush-output (car (ptr-ref (png_get_io_ptr png) _scheme))))
(define (create-png-writer out w h b&w? alpha?)
(let* ([png (png_create_write_struct PNG_LIBPNG_VER_STRING #f error-esc void)]
[info (png_create_info_struct png)]
[ob (make-cell out)])
(png_set_write_fn png ob write-png-bytes flush-png-bytes)
[funs (box null)]
[ob (make-cell (cons out funs))])
(parameterize ([current-fun-keep (lambda (v)
(set-box! funs (cons v (unbox funs))))])
(png_set_write_fn png ob write-png-bytes flush-png-bytes))
(png_set_IHDR png info w h (if b&w? 1 8)
(cond
[b&w? PNG_COLOR_TYPE_GRAY]

47
collects/tests/gracket/bitmap-stress.rkt Normal file
View File

@ -0,0 +1,47 @@
#lang racket/base
(require racket/class
racket/draw
racket/file)
;; Check memory-management in the bitmap/PNG/JPEG/etc. library by reading
;; and writing in many threads at the same time.
(define (check src save-type [read-type 'unknown/alpha])
(define ts
(for/list ([i (in-range 40)])
(thread
(lambda()
(for ([i (in-range 10)])
(define bm (read-bitmap (collection-file-path src "icons")))
(define t (make-temporary-file))
(send bm save-file t save-type)
(define bm2 (read-bitmap t read-type))
(define w (send bm get-width))
(define h (send bm get-width))
(define s1 (make-bytes (* w h 4)))
(define s2 (make-bytes (* w h 4)))
(send bm get-argb-pixels 0 0 w h s1)
(send bm2 get-argb-pixels 0 0 w h s2)
(case save-type
[(jpeg)
;; JPEG is lossy, so use a fuzzy compare:
(define diff (for/sum ([b1 (in-bytes s1)]
[b2 (in-bytes s2)])
(- b2 b1)))
(unless ((abs diff) . < . (* w h 1))
(error 'bitmap-stress "mismatch for ~s ~s: ~s ~s ~e"
src save-type
w h diff))]
[else
(unless (equal? s1 s2)
(error 'bitmap-stress "mismatch for ~s ~s" src save-type))])
(delete-file t))))))
(for ([t (in-list ts)]) (sync t)))
(check "PLT-206.png" 'png)
(check "plt.jpg" 'jpeg)
(check "htdp-icon.gif" 'png 'unknown)
(check "help16x16.xpm" 'png 'unknown)
(check "help16x16.xbm" 'png 'unknown)
(check "help.bmp" 'png 'unknown)

34
collects/tests/gracket/jpeg-stress.rkt
View File

@ -1,34 +0,0 @@
#lang racket/base
(require racket/class
racket/draw
racket/file)
;; Check memory-management in the JPEG library by reading and writing
;; in many threads at the same time.
(define ts
(for/list ([i (in-range 40)])
(thread
(lambda()
(for ([i (in-range 10)])
(define bm (read-bitmap (collection-file-path "plt.jpg" "icons")))
(define t (make-temporary-file))
(send bm save-file t 'jpeg)
(define bm2 (read-bitmap t))
(define w (send bm get-width))
(define h (send bm get-width))
(define s1 (make-bytes (* w h 4)))
(define s2 (make-bytes (* w h 4)))
(send bm get-argb-pixels 0 0 w h s1)
(send bm2 get-argb-pixels 0 0 w h s2)
;; JPEG is lossy, so use a fuzzy compare:
(define diff (for/sum ([b1 (in-bytes s1)]
[b2 (in-bytes s2)])
(- b2 b1)))
(unless ((abs diff) . < . (* w h 1))
(error 'jpeg-stree "mismatch ~s ~s ~e" w h diff))
(delete-file t))))))
(for ([t (in-list ts)]) (sync t))