From f37b3304f2653d5aea51fb260c60a9d33c222663 Mon Sep 17 00:00:00 2001
From: Matthew Flatt <mflatt@racket-lang.org>
Date: Thu, 9 Sep 2010 07:26:53 -0600
Subject: [PATCH] fix text-drawing performance

original commit: 0e64be35b7610d3e622f20dd121482b897581b91
---
 collects/mred/private/wx/cocoa/canvas.rkt      |  4 +++-
 collects/mred/private/wx/cocoa/window.rkt      | 10 ++++++++++
 collects/mred/private/wx/common/backing-dc.rkt |  5 +++--
 collects/mred/private/wx/gtk/canvas.rkt        |  4 +++-
 4 files changed, 19 insertions(+), 4 deletions(-)

diff --git a/collects/mred/private/wx/cocoa/canvas.rkt b/collects/mred/private/wx/cocoa/canvas.rkt
index 58a7b311..93bf8d54 100644
--- a/collects/mred/private/wx/cocoa/canvas.rkt
+++ b/collects/mred/private/wx/cocoa/canvas.rkt
@@ -223,15 +223,17 @@
           (when pq (set-box! pq #f)))
         (set! paint-queued #f)
         (when (or (not b) (is-shown-to-root?))
-          (send dc reset-backing-retained) ; start with a clean slate
           (send dc ensure-ready)
+          (send dc erase) ; 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))))
+          (send dc suspend-flush)
           (on-paint)
+          (send dc resume-flush)
           (queue-backing-flush)))
       (when req
         (cancel-flush-delay req)))
diff --git a/collects/mred/private/wx/cocoa/window.rkt b/collects/mred/private/wx/cocoa/window.rkt
index 5709b1dc..39492e5b 100644
--- a/collects/mred/private/wx/cocoa/window.rkt
+++ b/collects/mred/private/wx/cocoa/window.rkt
@@ -449,7 +449,16 @@
       ;; Called in Cocoa event-handling mode
       #f)
 
+    (define/private (pre-event-refresh key?)
+      ;; Since we break the connection between the
+      ;; Cocoa queue and event handling, we
+      ;; re-sync the display in case a stream of
+      ;; events (e.g., key repeat) have a corresponding
+      ;; stream of screen updates.
+      (try-to-sync-refresh))
+
     (define/public (dispatch-on-char/sync e)
+      (pre-event-refresh #t)
       (dispatch-on-char e #f))
     (define/public (dispatch-on-char e just-pre?) 
       (cond
@@ -459,6 +468,7 @@
        [else (when enabled? (on-char e)) #t]))
 
     (define/public (dispatch-on-event/sync e)
+      (pre-event-refresh #f)
       (dispatch-on-event e #f))
     (define/public (dispatch-on-event e just-pre?) 
       (cond
diff --git a/collects/mred/private/wx/common/backing-dc.rkt b/collects/mred/private/wx/common/backing-dc.rkt
index b711207e..4c640897 100644
--- a/collects/mred/private/wx/common/backing-dc.rkt
+++ b/collects/mred/private/wx/common/backing-dc.rkt
@@ -32,7 +32,8 @@
     (inherit call-with-cr-lock
              internal-get-bitmap
              internal-set-bitmap
-             reset-cr)
+             reset-cr
+             erase)
 
     (super-new)
 
@@ -68,7 +69,7 @@
 
     (define/public (reset-backing-retained [proc void])
       (let ([cr retained-cr])
-        (when cr
+        (when cr 
           (let ([bm (internal-get-bitmap)])
             (set! retained-cr #f)
             (internal-set-bitmap #f #t)
diff --git a/collects/mred/private/wx/gtk/canvas.rkt b/collects/mred/private/wx/gtk/canvas.rkt
index 2c209f1c..b8069171 100644
--- a/collects/mred/private/wx/gtk/canvas.rkt
+++ b/collects/mred/private/wx/gtk/canvas.rkt
@@ -349,15 +349,17 @@
          (lambda () 
            (set! paint-queued? #f)
            (set! now-drawing? #t)
-           (send dc reset-backing-retained) ; clean slate
            (send dc ensure-ready)
+           (send dc erase) ; 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))))
+           (send dc suspend-flush)
            (on-paint)
+           (send dc resume-flush)
            (set! now-drawing? #f)
            (when refresh-after-drawing?
              (set! refresh-after-drawing? #f)