draw: keep PNG write rows stable across callbacks

draw-lib/racket/draw/unsafe/png.rkt

@@ -330,14 +330,14 @@
                   b&w?
                   alpha?))))))
 
-(define (malloc-rows h row-bytes)
+(define (malloc-rows h row-bytes [memory-mode 'atomic-interior])
   (let* ([align (lambda (v) (if (positive? (remainder v 8))
                                 (+ v (- 8 (remainder v 8)))
                                 v))]
          [table-size (align (* h (ctype-sizeof _pointer)))]
          [row-size (align row-bytes)]
          [memory (malloc (+ table-size (* row-size h))
-                         'atomic-interior)]
+                         memory-mode)]
          [rows memory])
     (for ([i (in-range h)])
       (ptr-set! rows _pointer i (ptr-add memory (+ table-size (* i row-size)))))
@@ -406,12 +406,17 @@
       (png_write_image (writer-png writer) #f)
       (let* ([h (vector-length vector-of-rows)]
              [w (bytes-length (vector-ref vector-of-rows 0))]
-             [rows (malloc-rows h w)])
-        (for/list ([i (in-range h)])
-          (memcpy (ptr-ref rows _pointer i)
-                  (vector-ref vector-of-rows i)
-                  w))
-        (png_write_image (writer-png writer) rows)))
+             [rows (malloc-rows h w 'raw)])
+        (dynamic-wind
+          void
+          (lambda ()
+            (for ([i (in-range h)])
+              (memcpy (ptr-ref rows _pointer i)
+                      (vector-ref vector-of-rows i)
+                      w))
+            (png_write_image (writer-png writer) rows))
+          (lambda ()
+            (free rows)))))
   (png_write_end (writer-png writer) (writer-info writer))
   (flush-sanitized-output (writer-info writer)))
 

draw-test/tests/racket/draw/bitmap-stress.rkt

@@ -47,6 +47,32 @@
 (check "help16x16.xbm" 'png 'unknown)
 (check "help.bmp" 'png 'unknown)
 
+;; A PNG output callback allocates while libpng uses the row-pointer table.
+;; Repeatedly write a large bitmap after reloading it, so that the table stays
+;; valid across a possible GC in the callback.
+(let ()
+  (define source (make-temporary-file "png-source-~a.png"))
+  (define target (make-temporary-file "png-target-~a.png"))
+  (dynamic-wind
+   void
+   (lambda ()
+     (define bitmap (make-object bitmap% 1920 1080 #f #t))
+     (define dc (new bitmap-dc% [bitmap bitmap]))
+     (send dc set-brush "midnightblue" 'solid)
+     (send dc draw-rectangle 0 0 1920 1080)
+     (send dc set-bitmap #f)
+     (unless (send bitmap save-file source 'png)
+       (error 'bitmap-stress "could not write PNG source"))
+     (define reloaded (make-object bitmap% source))
+     (unless (send reloaded ok?)
+       (error 'bitmap-stress "could not reload PNG source"))
+     (for ([i (in-range 25)])
+       (unless (send reloaded save-file target 'png)
+         (error 'bitmap-stress "could not write PNG target"))))
+   (lambda ()
+     (when (file-exists? source) (delete-file source))
+     (when (file-exists? target) (delete-file target)))))
+
 ;; Also check that we don't run out of C stack space due to error escapes
 (define (ones)
   (if (eq? 'racket (system-type 'vm))