[plt-scheme] mred, bitmaps, and X memory usage/leak

On Mon, 15 Dec 2008, Dimitris Vyzovitis wrote:

> After running a number of animation steps (about a 1000), X memory usage 
> climbs to over 1GB, even when I explicitly collect-garbage. X memory is not 
> released until I kill the process (at which point the memory is released).

Leak trigger attached.
1) fire top
2) mred -iqz
> (require "xleak.ss")
> (go)
3) sort top by memory (M) and watch X's memory go nooooooorth

-- vyzo

PS: terrible flicker!
-------------- next part --------------
#lang scheme/gui
(provide (all-defined-out))

(define-syntax-rule (color r g b)
  (make-object color% r g b))

(define-syntax-rule (palette a b e)
  (for/list ((a (in-range 0 255))
             (b (in-range 255 0 -1)))
    e))

(define (leaking-canvas dt)
  (let ((colors
         (list->vector
          (append
           (palette g r (color r g 0))
           (palette b g (color 0 g b))
           (palette r b (color r 0 b))))))
    (class canvas%
      (inherit get-width get-height refresh)
      
      (define next 0)
      (define current #f)
      (define timer #f)
      
      (define (on-superwindow-show shown?)
        (if shown?
          (set! timer (new timer% (notify-callback notify) (interval dt)))
          (begin
            (send timer stop)
            (set! timer #f))))
      (override on-superwindow-show)
      
      (define (notify)
        (set! current #f)
        (set! next (modulo (add1 next) (vector-length colors)))
        (refresh))
      
      (define (repaint _self dc)
        (unless (and current
                     (= (get-width) (send current get-width))
                     (= (get-height) (send current get-height)))
          (let ((c (vector-ref colors next)))
            (printf "draw ~a ~a ~a~n"
                    (send c red)
                    (send c green)
                    (send c blue)))
          (set! current (make-object bitmap% (get-width) (get-height)))
          (let ((bdc (new bitmap-dc% (bitmap current))))
            (send bdc clear)
            (send bdc set-smoothing 'smoothed)
            (send bdc set-brush 
                  (send the-brush-list find-or-create-brush
                        (vector-ref colors next) 'solid))
            (send bdc draw-ellipse 0 0 (get-width) (get-height))))
        (send dc draw-bitmap current 0 0))
      
      (super-new (paint-callback repaint) 
                 (min-width 200)
                 (min-height 200)))))

(define xframe%
  (class frame%
    (define (can-close?) #t)
    (augment can-close?)
    (super-new)))
      
(define (go (dt 100))
  (let ((f (new xframe% (label "I am leaking!") (width 800) (height 800))))
    (new (leaking-canvas dt) (parent f))
    (send f show #t)
    (yield 'wait)))