diff --git a/collects/racket/draw/unsafe/png.rkt b/collects/racket/draw/unsafe/png.rkt index a39b92ecab..596fcb46bd 100644 --- a/collects/racket/draw/unsafe/png.rkt +++ b/collects/racket/draw/unsafe/png.rkt @@ -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] diff --git a/collects/tests/gracket/bitmap-stress.rkt b/collects/tests/gracket/bitmap-stress.rkt new file mode 100644 index 0000000000..1089a3ed23 --- /dev/null +++ b/collects/tests/gracket/bitmap-stress.rkt @@ -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) diff --git a/collects/tests/gracket/jpeg-stress.rkt b/collects/tests/gracket/jpeg-stress.rkt deleted file mode 100644 index 1d30732925..0000000000 --- a/collects/tests/gracket/jpeg-stress.rkt +++ /dev/null @@ -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)) - - \ No newline at end of file