new cocoa canvas-refresh strategy

2010-08-06 11:45:15 -06:00 · 2010-08-06 11:45:15 -06:00 · 7a7658e86d
commit 7a7658e86d
parent bb68137829
10 changed files with 339 additions and 221 deletions
--- a/collects/mred/private/wx/cocoa/canvas.rkt
+++ b/collects/mred/private/wx/cocoa/canvas.rkt
@ -12,6 +12,7 @@
         "dc.rkt"
         "queue.rkt"
         "item.rkt"
+         "../common/backing-dc.rkt"
         "../common/event.rkt"
         "../common/queue.rkt"
         "../../syntax.rkt"
@ -26,26 +27,29 @@

 (import-protocol NSComboBoxDelegate)

+;; Called when a canvas has no backing store ready
+(define (clear-background wx)
+  (let ([bg (send wx get-canvas-background-for-clearing)])
+    (when bg
+      (let ([ctx (tell NSGraphicsContext currentContext)])
+        (tellv ctx saveGraphicsState)
+        (let ([cg (tell #:type _CGContextRef ctx graphicsPort)]
+              [adj (lambda (v) (/ v 255.0))])
+          (CGContextSetRGBFillColor cg
+                                    (adj (color-red bg))
+                                    (adj (color-blue bg))
+                                    (adj (color-green bg))
+                                    1.0)
+          (CGContextFillRect cg (make-NSRect (make-NSPoint 0 0)
+                                             (make-NSSize 32000 32000))))
+        (tellv ctx restoreGraphicsState)))))
+
 (define-objc-class MyView NSView 
  #:mixins (FocusResponder KeyMouseResponder) 
  [wx]
  (-a _void (drawRect: [_NSRect r])
-      (unless (send wx reject-partial-update r)
-        (let ([bg (send wx get-canvas-background-for-clearing)])
-          (when bg
-            (let ([ctx (tell NSGraphicsContext currentContext)])
-              (tellv ctx saveGraphicsState)
-              (let ([cg (tell #:type _CGContextRef ctx graphicsPort)]
-                    [adj (lambda (v) (/ v 255.0))])
-                (CGContextSetRGBFillColor cg
-                                          (adj (color-red bg))
-                                          (adj (color-blue bg))
-                                          (adj (color-green bg))
-                                          1.0)
-                (CGContextFillRect cg (make-NSRect (make-NSPoint 0 0)
-                                                   (make-NSSize 32000 32000))))
-              (tellv ctx restoreGraphicsState))))
-        (send wx queue-paint)
+      (unless (send wx paint-or-queue-paint)
+        (clear-background wx)
        ;; ensure that `nextEventMatchingMask:' returns
        (post-dummy-event)))
  (-a _void (viewWillMoveToWindow: [_id w])
@ -117,24 +121,11 @@
  [wx]
  (-a _void (drawRect: [_NSRect r])
      (super-tell #:type _void drawRect: #:type _NSRect r)
-      (unless (send wx during-menu-click?)
-        (let ([bg (send wx get-canvas-background-for-clearing)])
-          (when bg
-            (let ([ctx (tell NSGraphicsContext currentContext)])
-              (tellv ctx saveGraphicsState)
-              (let ([cg (tell #:type _CGContextRef ctx graphicsPort)]
-                    [adj (lambda (v) (/ v 255.0))])
-                (CGContextSetRGBFillColor cg
-                                          (adj (color-red bg))
-                                          (adj (color-blue bg))
-                                          (adj (color-green bg))
-                                          1.0)
-                (CGContextFillRect cg (make-NSRect (make-NSPoint 0 0)
-                                                   (make-NSSize 32000 32000))))
-              (tellv ctx restoreGraphicsState))))
-        (send wx queue-paint)
-        ;; ensure that `nextEventMatchingMask:' returns
-        (post-dummy-event)))
+      (unless (send wx paint-or-queue-paint)
+        (unless (send wx during-menu-click?)
+          (clear-background wx)
+          ;; ensure that `nextEventMatchingMask:' returns
+          (post-dummy-event))))
  (-a _void (comboBoxWillPopUp: [_id notification])
      (send wx starting-combo))
  (-a _void (comboBoxWillDismiss: [_id notification])
@ -154,7 +145,7 @@
          [ignored-name #f]
          [gl-config #f])

-    (inherit get-cocoa
+    (inherit get-cocoa get-cocoa-window
             get-eventspace
             make-graphics-context
             is-shown-to-root?
@ -173,55 +164,69 @@
    (define virtual-height #f)
    (define virtual-width #f)

+    (define is-combo? (memq 'combo style))
+    (define has-control-border? (and (not is-combo?)
+                                     (memq 'control-border style)))
+
    (define-values (x-margin y-margin x-sb-margin y-sb-margin)
      (cond
-       [(memq 'control-border style) (values 3 3 3 3)]
+       [has-control-border? (values 3 3 3 3)]
       [(memq 'border style) (values 1 1 0 0)]
       [else (values 0 0 0 0)]))

    (define canvas-style style)

    (define/override (focus-is-on on?)
-      (when (memq 'control-border canvas-style)
+      (when has-control-border?
        (tellv cocoa setFocusState: #:type _BOOL on?)
-        (tellv cocoa setNeedsDisplay: #:type _BOOL #t)))
+        (tellv cocoa setNeedsDisplay: #:type _BOOL #t))
+      (super focus-is-on on?))

    ;; Avoid multiple queued paints:
    (define paint-queued? #f)
-    ;; To handle paint requests that happen while on-paint
-    ;;  is being called already:
-    (define now-drawing? #f)
-    (define refresh-after-drawing? #f)

    (define/public (queue-paint)
      ;; can be called from any thread, including the event-pump thread
      (unless paint-queued?
        (set! paint-queued? #t)
-        (queue-window-event this (lambda () 
-                                   (set! paint-queued? #f)
-                                   (when (is-shown-to-root?)
-                                     (set! now-drawing? #t)
-                                     (fix-dc)
-                                     (on-paint)
-                                     (set! now-drawing? #f)
-                                     (when refresh-after-drawing?
-                                       (set! refresh-after-drawing? #f)
-                                       (refresh)))))))
+        (let ([req (request-flush-delay (get-cocoa-window))])
+          (queue-window-event this (lambda () 
+                                     (set! paint-queued? #f)
+                                     (when (is-shown-to-root?)
+                                       (send dc reset-backing-retained) ; start with a clean slate
+                                       (let ([bg (get-canvas-background)])
+                                         (when bg 
+                                           (let ([old-bg (send dc get-background)])
+                                             (send dc set-background bg)
+                                             (send dc clear)
+                                             (send dc set-background old-bg))))
+                                       (on-paint)
+                                       (queue-backing-flush)
+                                       (cancel-flush-delay req)))))))
+
+    (define/public (paint-or-queue-paint)
+      (or (do-backing-flush this dc (tell NSGraphicsContext currentContext)
+                            (if is-combo? 2 0) (if is-combo? 2 0))
+          (begin
+            (queue-paint)
+            #f)))
+
    (define/override (refresh)
      ;; can be called from any thread, including the event-pump thread
+      (queue-paint))
+
+    (define/public (queue-backing-flush)
      (tellv content-cocoa setNeedsDisplay: #:type _BOOL #t))

    (define/override (get-cocoa-content) content-cocoa)

-    (define is-combo? (memq 'combo style))
-
    (super-new 
     [parent parent]
     [cocoa
      (as-objc-allocation
       (tell (tell (cond
                    [is-combo? NSView]
-                    [(memq 'control-border style) FocusView]
+                    [has-control-border? FocusView]
                    [(memq 'border style) (if (memq 'vscroll style)
                                              CornerlessFrameView
                                              FrameView)]
@ -249,34 +254,18 @@
      (tellv content-cocoa setDelegate: content-cocoa)
      (install-control-font content-cocoa #f))

-    (define dc (make-object dc% (make-graphics-context) 0 0 10 10
-                            (lambda ()
-                              (let ([w (box 0)]
-                                    [h (box 0)])
-                                (get-virtual-size w h)
-                                (values (unbox w) (unbox h))))))
+    (define dc (make-object dc% this))
+
+    (send dc start-backing-retained)

    (queue-paint)
    
    (define/public (get-dc) dc)

-    (define/public (fix-dc)
+    (define/public (fix-dc [refresh? #t])
      (when (dc . is-a? . dc%)
-        (if (is-shown-to-before-root?)
-            (let ([p (tell #:type _NSPoint content-cocoa 
-                           convertPoint: #:type _NSPoint (make-NSPoint 0 0)
-                           toView: #f)]
-                  [xb (box 0)]
-                  [yb (box 0)])
-              (get-client-size xb yb)
-              (send dc reset-bounds 
-                    (+ (NSPoint-x p) (if is-combo? 2 0))
-                    (- (NSPoint-y p) (if is-combo? 22 0))
-                    (max 1 (- (unbox xb) (if is-combo? 22 0)))
-                    (unbox yb)
-                    (if auto-scroll? (scroll-pos h-scroller) 0)
-                    (if auto-scroll? (scroll-pos v-scroller) 0)))
-            (send dc reset-bounds  0 0 0 0 0 0))))
+        (send dc reset-backing-retained))
+      (when refresh? (refresh)))

    (define/override (get-client-size xb yb)
      (super get-client-size xb yb)
@ -532,13 +521,9 @@
                                               bg-col))
    (define/public (set-canvas-background col) (set! bg-col col))
    (define/public (get-canvas-background-for-clearing) 
-      (if now-drawing?
-          (begin
-            (set! refresh-after-drawing? #t)
-            #f)
-          (and (not (memq 'transparent canvas-style)) 
-               (not (memq 'no-autoclear canvas-style)) 
-               bg-col)))
+      (and (not (memq 'transparent canvas-style)) 
+           (not (memq 'no-autoclear canvas-style)) 
+           bg-col))

    (define/public (reject-partial-update r)
      ;; Called in the event-pump thread.
@ -657,6 +642,14 @@
    (define/public (set-resize-corner on?)
      (void))

+    (define/public (get-backing-size xb yb)
+      (get-client-size xb yb)
+      (when is-combo?
+        (set-box! xb (- (unbox xb) 22))))
+
+    (define/public (is-flipped?)
+      (tell #:type _BOOL (get-cocoa-content) isFlipped))
+
    (define/public (get-virtual-size xb yb)
      (get-client-size xb yb)
      (when virtual-width (set-box! xb virtual-width))
--- a/collects/mred/private/wx/cocoa/dc.rkt
+++ b/collects/mred/private/wx/cocoa/dc.rkt
@ -1,16 +1,19 @@
 #lang racket/base
-(require ffi/unsafe/objc
+(require racket/class
         ffi/unsafe
-         racket/class
-         "utils.rkt"
-         "types.rkt"
+         ffi/unsafe/objc
         racket/draw/cairo
-         racket/draw/dc
         racket/draw/local
+         "types.rkt"
+         "utils.rkt"
+         "window.rkt"
+         "../../lock.rkt"
         "../common/queue.rkt"
-         "../../syntax.rkt")
+         "../common/backing-dc.rkt")

 (provide dc%
+         do-backing-flush
+
         _CGContextRef
         CGContextSetRGBFillColor
         CGContextFillRect
@ -19,79 +22,79 @@
         CGContextAddLines)

 (define _CGContextRef (_cpointer 'CGContextRef))
+(define-appserv CGContextSynchronize (_fun _CGContextRef -> _void))
 (define-appserv CGContextTranslateCTM (_fun _CGContextRef _CGFloat _CGFloat -> _void))
 (define-appserv CGContextScaleCTM (_fun _CGContextRef _CGFloat _CGFloat -> _void))
-(define-appserv CGContextFlush (_fun _CGContextRef -> _void))
+(define-appserv CGContextSaveGState (_fun _CGContextRef -> _void))
+(define-appserv CGContextRestoreGState (_fun _CGContextRef -> _void))
 (define-appserv CGContextSetRGBFillColor (_fun _CGContextRef _CGFloat _CGFloat _CGFloat _CGFloat -> _void))
 (define-appserv CGContextFillRect (_fun _CGContextRef _NSRect -> _void))
 (define-appserv CGContextAddRect (_fun _CGContextRef _NSRect -> _void))
 (define-appserv CGContextAddLines (_fun _CGContextRef (v : (_vector i _NSPoint)) (_long = (vector-length v)) -> _void))
 (define-appserv CGContextStrokePath (_fun _CGContextRef -> _void))
-(define-appserv CGContextConvertPointToUserSpace (_fun  _CGContextRef _NSPoint -> _NSPoint))
-(define-appserv CGContextConvertSizeToUserSpace (_fun  _CGContextRef _NSSize -> _NSSize))
-
-(define dc-backend%
-  (class* default-dc-backend% (dc-backend<%>)
-    (init context dx dy width height -get-virtual-size)
-    (super-new)
-
-    (inherit reset-cr set-auto-scroll)
-
-    (define the-context context) ;; retain as long as we need `cg'
-    (define cg (tell #:type _CGContextRef context graphicsPort))
-
-    (define old-dx 0)
-    (define old-dy 0)
-
-    (define/private (set-bounds dx dy width height)
-      (set! old-dx dx)
-      (set! old-dy (+ dy height))
-      (CGContextTranslateCTM cg old-dx old-dy)
-      (CGContextScaleCTM cg 1 -1)
-      (let ([surface (cairo_quartz_surface_create_for_cg_context cg width height)])
-        (set! cr (cairo_create surface))
-        (cairo_surface_destroy surface))
-      (set! clip-width width)
-      (set! clip-height height)
-      (reset-clip cr))
-
-    (define clip-width width)
-    (define clip-height height)
-
-    (define/override (reset-clip cr)
-      (super reset-clip cr)
-      (let ([m (make-cairo_matrix_t 0 0 0 0 0 0)])
-        (cairo_get_matrix cr m)
-        (cairo_set_matrix cr (make-cairo_matrix_t 1 0 0 1 0 0))
-        (cairo_rectangle cr 0 0 clip-width clip-height)
-        (cairo_clip cr)
-        (cairo_set_matrix cr m)))
-
-    (define cr #f)
-    (set-bounds dx dy width height)
-
-    (define/public (reset-bounds dx dy width height auto-dx auto-dy)
-      (let ([old-cr cr])
-        (when old-cr
-          (set! cr #f)
-          (cairo_destroy old-cr)))
-      (set-auto-scroll auto-dx auto-dy)
-      (CGContextScaleCTM cg 1 -1)
-      (CGContextTranslateCTM cg (- old-dx) (- old-dy))
-      (set-bounds dx dy width height)
-      (reset-cr cr))
-
-    (define get-virtual-size -get-virtual-size)
-    (def/override (get-size)
-      (let-values ([(w h) (get-virtual-size)])
-        (values (exact->inexact w)
-                (exact->inexact h))))
-
-    (define/override (get-cr) cr)
-    
-    (define/override (flush-cr)
-      (add-event-boundary-sometimes-callback! cg CGContextFlush))))

 (define dc%
-  (dc-mixin dc-backend%))
+  (class backing-dc%
+    (init [(cnvs canvas)])
+    (define canvas cnvs)

+    (super-new)
+
+    (define/override (get-backing-size xb yb)
+      (send canvas get-backing-size xb yb))
+
+    (define/override (get-size)
+      (let ([xb (box 0)]
+            [yb (box 0)])
+        (send canvas get-virtual-size xb yb)
+        (values (unbox xb) (unbox yb))))
+
+    (define/override (queue-backing-flush)
+      (send canvas queue-backing-flush))
+
+    (define suspend-count 0)
+    (define req #f)
+
+    (define/override (suspend-flush) 
+      (as-entry
+       (lambda ()
+         (when (zero? suspend-count)
+           (set! req (request-flush-delay (send canvas get-cocoa-window))))
+         (set! suspend-count (add1 suspend-count))
+         (super suspend-flush))))
+
+    (define/override (resume-flush) 
+      (as-entry
+       (lambda ()
+         (set! suspend-count (sub1 suspend-count))
+         (when (and (zero? suspend-count) req)
+           (cancel-flush-delay req)
+           (set! req #f))
+         (super resume-flush))))))
+
+(define (do-backing-flush canvas dc ctx dx dy)
+  (tellv ctx saveGraphicsState)
+  (begin0
+   (send dc on-backing-flush
+         (lambda (bm)
+           (let ([w (box 0)]
+                 [h (box 0)])
+             (send canvas get-client-size w h)
+             (let ([cg (tell #:type _CGContextRef ctx graphicsPort)])
+               (unless (send canvas is-flipped?)
+                 (CGContextTranslateCTM cg 0 (unbox h))
+                 (CGContextScaleCTM cg 1 -1))
+               (CGContextTranslateCTM cg dx dy)
+               (let* ([surface (cairo_quartz_surface_create_for_cg_context cg (unbox w) (unbox h))]
+                      [cr (cairo_create surface)])
+                 (cairo_surface_destroy surface)
+                 (let ([s (cairo_get_source cr)])
+                   (cairo_pattern_reference s)
+                   (cairo_set_source_surface cr (send bm get-cairo-surface) 0 0)
+                   (cairo_new_path cr)
+                   (cairo_rectangle cr 0 0 (unbox w) (unbox h))
+                   (cairo_fill cr)
+                   (cairo_set_source cr s)
+                   (cairo_pattern_destroy s))
+                 (cairo_destroy cr))))))
+   (tellv ctx restoreGraphicsState)))
--- a/collects/mred/private/wx/cocoa/frame.rkt
+++ b/collects/mred/private/wx/cocoa/frame.rkt
@ -55,12 +55,14 @@
      (when wx
        (set! front wx)
        (send wx install-mb)
+        (send wx notify-responder #t)
        (queue-window-event wx (lambda ()
                                 (send wx on-activate #t))))]
  [-a _void (windowDidResignMain: [_id notification])
      (when wx
        (when (eq? front wx) (set! front #f))
        (send empty-mb install)
+        (send wx notify-responder #f)
        (queue-window-event wx (lambda ()
                                 (send wx on-activate #f))))])

@ -150,6 +152,8 @@
    (define/override (get-wx-window) this)

    (define/override (make-graphics-context)
+      (tell cocoa graphicsContext)
+      #;
      (as-objc-allocation
       (tell NSGraphicsContext graphicsContextWithWindow: cocoa)))

@ -257,6 +261,28 @@

    (define/override (is-view?) #f)

+    (define is-main? #f)
+    (define first-responder #f)
+
+    (define/public (notify-responder on?)
+      (set! is-main? on?)
+      (when first-responder
+        (do-notify-responder first-responder on?)))
+
+    (define/private (do-notify-responder wx on?)
+      (send wx focus-is-on on?)
+      (queue-window-event wx
+                          (if on?
+                              (lambda () (send wx on-set-focus))
+                              (lambda () (send wx on-kill-focus)))))
+
+    (define/override (is-responder wx on?)
+      (if on?
+          (set! first-responder wx)
+          (set! first-responder #f))
+      (when is-main?
+        (do-notify-responder wx on?)))
+
    (define/public (flip-screen y)
      (let ([f (tell #:type _NSRect (tell cocoa screen) frame)])
        (- (NSSize-height (NSRect-size f)) y)))
--- a/collects/mred/private/wx/cocoa/queue.rkt
+++ b/collects/mred/private/wx/cocoa/queue.rkt
@ -206,8 +206,6 @@
                               (custodian-shutdown-all c)))))))
      (set! was-menu-bar #f)))

-(define o (current-error-port))
-
 ;; Call this function only in atomic mode:
 (define (check-one-event wait? dequeue?)
  (pre-event-sync wait?)
--- a/collects/mred/private/wx/cocoa/window.rkt
+++ b/collects/mred/private/wx/cocoa/window.rkt
@ -7,6 +7,7 @@
         "const.rkt"
         "types.rkt"
         "keycode.rkt"
+         "../../lock.rkt"
         "../common/event.rkt"
         "../common/queue.rkt"
         "../../syntax.rkt"
@ -15,9 +16,13 @@
 (objc-unsafe!)

 (provide window%
-         queue-window-event
+
         FocusResponder
-         KeyMouseResponder)
+         KeyMouseResponder
+
+         queue-window-event
+         request-flush-delay
+         cancel-flush-delay)

 (define-local-member-name flip-client)

@ -30,16 +35,12 @@
  [-a _BOOL (becomeFirstResponder)
      (and (super-tell becomeFirstResponder)
           (begin
-             (send wx focus-is-on #t)
-             (queue-window-event wx (lambda ()
-                                      (send wx on-set-focus)))
+             (send wx is-responder wx #t)
             #t))]
  [-a _BOOL (resignFirstResponder)
      (and (super-tell resignFirstResponder)
           (begin
-             (send wx focus-is-on #f)
-             (queue-window-event wx (lambda ()
-                                      (send wx on-kill-focus)))
+             (send wx is-responder wx #f)
             #t))])

 (define-objc-mixin (KeyMouseResponder Superclass)
@ -177,7 +178,11 @@
    (unless no-show?
      (show #t)) 

-    (define/public (focus-is-on on?) (void))
+    (define/public (focus-is-on on?)
+      (void))
+
+    (define/public (is-responder wx on?)
+      (send parent is-responder wx on?))

    (define/public (get-cocoa) cocoa)
    (define/public (get-cocoa-content) cocoa)
@ -384,5 +389,37 @@
    
    (def/public-unimplemented centre)))

+
+;; ----------------------------------------
+
 (define (queue-window-event win thunk)
  (queue-event (send win get-eventspace) thunk))
+
+(define depth 0)
+
+(define (request-flush-delay cocoa-win)
+  (as-entry
+   (lambda ()
+     (let ([req (box cocoa-win)])
+       (set! depth (add1 depth))
+       (tellv cocoa-win disableFlushWindow)
+       (add-event-boundary-sometimes-callback! 
+        req
+        (lambda (v) 
+          ;; in atomic mode
+          (when (unbox req) 
+            (set-box! req #f)
+            (set! depth (sub1 depth))
+            (tellv cocoa-win enableFlushWindow)
+            (tellv cocoa-win flushWindow))))
+       req))))
+
+(define (cancel-flush-delay req)
+  (as-entry
+   (lambda ()
+     (let ([cocoa-win (unbox req)])
+       (when cocoa-win
+         (set-box! req #f)
+         (set! depth (sub1 depth))
+         (tellv cocoa-win enableFlushWindow)
+         (remove-event-boundary-callback! req))))))
--- a/collects/mred/private/wx/common/backing-dc.rkt
+++ b/collects/mred/private/wx/common/backing-dc.rkt
@ -3,21 +3,27 @@
         racket/draw/dc
         racket/draw/bitmap-dc
         racket/draw/bitmap
-         racket/draw/local)
+         racket/draw/local
+         "../../lock.rkt"
+         "queue.rkt")

 (provide backing-dc%
         
         ;; scoped method names:
         get-backing-size
-         flush-backing
-         start-on-paint
-         end-on-paint)
+         queue-backing-flush
+         on-backing-flush
+         start-backing-retained
+         end-backing-retained
+         reset-backing-retained)

 (define-local-member-name
  get-backing-size
-  flush-backing
-  start-on-paint
-  end-on-paint)
+  queue-backing-flush
+  on-backing-flush
+  start-backing-retained
+  end-backing-retained
+  reset-backing-retained)

 (define backing-dc%
  (class (dc-mixin bitmap-dc-backend%)
@ -32,47 +38,83 @@
      (set-box! xb 1)
      (set-box! yb 1))

-    ;; override this method to push the bitmap to
-    ;;  the device that it backs
-    (define/public (flush-backing bm)
+    ;; override this method to set up a callback to
+    ;;  `on-backing-flush' when the backing store can be rendered
+    ;;  to the screen
+    (define/public (queue-backing-flush)
      (void))

-    (define on-paint-cr #f)
+    (define retained-cr #f)
+    (define retained-counter 0)
+    (define needs-flush? #f)

-    (define/public (start-on-paint)
+    ;; called with a procedure that is applied to a bitmap;
+    ;;  returns #f if there's nothing to flush
+    (define/public (on-backing-flush proc)
+      (cond
+       [(not retained-cr) #f]
+       [(positive? retained-counter) 
+        (proc (internal-get-bitmap)) 
+        #t]
+       [else 
+        (reset-backing-retained proc)
+        #t]))
+
+    (define/public (reset-backing-retained [proc void])
+      (let ([cr retained-cr])
+        (when cr
+          (let ([bm (internal-get-bitmap)])
+            (set! retained-cr #f)
+            (internal-set-bitmap #f #t)
+            (super release-cr retained-cr)
+            (proc bm)
+            (release-backing-bitmap bm)))))
+
+    (define/public (start-backing-retained)
      (call-with-cr-lock
       (lambda () 
-         (if on-paint-cr 
-             (log-error "nested start-on-paint")
-             (set! on-paint-cr (get-cr))))))
+         (set! retained-counter (add1 retained-counter)))))

-    (define/public (end-on-paint)
+    (define/public (end-backing-retained)
      (call-with-cr-lock
       (lambda () 
-         (if (not on-paint-cr)
+         (if (zero? retained-counter)
             (log-error "unbalanced end-on-paint")
-             (let ([cr on-paint-cr])
-               (set! on-paint-cr #f)
-               (release-cr cr))))))
+             (set! retained-counter (sub1 retained-counter))))))

    (define/override (get-cr)
-      (or on-paint-cr
+      (or retained-cr
          (let ([w (box 0)]
                [h (box 0)])
-            (get-backing-size)
+            (get-backing-size w h)
            (let ([bm (get-backing-bitmap (unbox w) (unbox h))])
-              (internal-set-bitmap bm))
-            (super get-cr))))
+              (internal-set-bitmap bm #t))
+            (let ([cr (super get-cr)])
+              (set! retained-cr cr)
+              cr))))

    (define/override (release-cr cr)
-      (unless (eq? cr on-paint-cr)
-        (let ([bm (internal-get-bitmap)])
-          (internal-set-bitmap #f)
-          (flush-backing bm)
-          (release-backing-bitmap bm))))))
+      (when (zero? flush-suspends)
+        (queue-backing-flush)))
+
+    (define flush-suspends 0)
+
+    (define/override (suspend-flush) 
+      (as-entry
+       (lambda ()
+         ;; if not suspended currently, sleep to encourage any
+         ;; existing flush requests to complete
+         (when (zero? flush-suspends) (sleep))
+         (set! flush-suspends (add1 flush-suspends)))))
+    (define/override (resume-flush)  
+      (as-entry
+       (lambda ()
+         (set! flush-suspends (sub1 flush-suspends))
+         (when (zero? flush-suspends)
+           (queue-backing-flush)))))))

 (define (get-backing-bitmap w h)
  (make-object bitmap% w h #f #t))

 (define (release-backing-bitmap bm)
-  (send bm release-bitma-storage))
+  (send bm release-bitmap-storage))
--- a/collects/mred/private/wxme/pasteboard.rkt
+++ b/collects/mred/private/wxme/pasteboard.rkt
@ -1340,18 +1340,25 @@
                        [bgmode (send dc get-text-mode)]
                        [rgn (send dc get-clipping-region)])

+                    (send dc suspend-flush)
+
                    (send dc set-clipping-rect (- left x) (- top y) width height)
-
-                    (draw dc (- x) (- y) left top width height show-caret bg-color)
-
-                    (send dc set-clipping-region rgn)
-
-                    (send dc set-brush brush)
-                    (send dc set-pen pen)
-                    (send dc set-font font)
-                    (send dc set-text-foreground fg)
-                    (send dc set-text-background bg)
-                    (send dc set-text-mode bgmode)))))
+                    
+                    (dynamic-wind
+                        void
+                        (lambda ()
+                          (draw dc (- x) (- y) left top width height show-caret bg-color))
+                        (lambda ()
+                          (send dc set-clipping-region rgn)
+                          
+                          (send dc set-brush brush)
+                          (send dc set-pen pen)
+                          (send dc set-font font)
+                          (send dc set-text-foreground fg)
+                          (send dc set-text-background bg)
+                          (send dc set-text-mode bgmode)
+                          
+                          (send dc resume-flush)))))))

          (end-sequence-lock)))]))
  ;; ----------------------------------------
--- a/collects/mred/private/wxme/text.rkt
+++ b/collects/mred/private/wxme/text.rkt
@ -5042,16 +5042,23 @@

                      (send dc set-clipping-rect (- left x) (- top y) width height)

-                      (do-redraw dc top bottom left right (- y) (- x) show-caret show-xsel? bg-color)
+                      (send dc suspend-flush)

-                      (send dc set-clipping-region rgn)
+                      (dynamic-wind
+                          void
+                          (lambda ()
+                            (do-redraw dc top bottom left right (- y) (- x) show-caret show-xsel? bg-color))
+                          (lambda ()
+                            (send dc set-clipping-region rgn)
+                            
+                            (send dc set-brush brush)
+                            (send dc set-pen pen)
+                            (send dc set-font font)
+                            (send dc set-text-foreground fg)
+                            (send dc set-text-background bg)
+                            (send dc set-text-mode bgmode)

-                      (send dc set-brush brush)
-                      (send dc set-pen pen)
-                      (send dc set-font font)
-                      (send dc set-text-foreground fg)
-                      (send dc set-text-background bg)
-                      (send dc set-text-mode bgmode))))))
+                            (send dc resume-flush))))))))

          (end-sequence-lock)))]))
  
--- a/collects/racket/draw/bitmap-dc.rkt
+++ b/collects/racket/draw/bitmap-dc.rkt
@ -32,11 +32,13 @@
        (set! c (cairo_create (send bm get-cairo-surface)))
        (set! b&w? (not (send bm is-color?)))))

-    (define/public (internal-set-bitmap v)
-      (call-with-cr-lock
-       (lambda ()
-         (do-set-bitmap v #t)
-         (when c (reset-cr c)))))
+    (define/public (internal-set-bitmap v [direct? #f])
+      (if direct?
+          (do-set-bitmap v #t)
+          (call-with-cr-lock
+           (lambda ()
+             (do-set-bitmap v #t)
+             (when c (reset-cr c))))))

    (define/public (internal-get-bitmap) bm)

--- a/collects/racket/draw/dc.rkt
+++ b/collects/racket/draw/dc.rkt
@ -458,6 +458,9 @@
    (def/public (get-text-background) text-bg)
    (def/public (get-background) bg)

+    (def/public (suspend-flush) (void))
+    (def/public (resume-flush) (void))
+
    (def/public (set-text-mode [(symbol-in solid transparent) mode])
      (set! text-mode mode))
    (def/public (get-text-mode) text-mode)