From 64829783630e90c574fc94d24ef3298c8ceef27b Mon Sep 17 00:00:00 2001
From: Matthew Flatt <mflatt@racket-lang.org>
Date: Mon, 1 Nov 2010 08:09:42 -0600
Subject: [PATCH] win32: periodic canvas flushing

original commit: 4d316f78510aed0ff5a90dd038994c6da0eaabda
---
 collects/mred/private/wx/common/queue.rkt |  8 ++++----
 collects/mred/private/wx/win32/canvas.rkt |  7 +++++--
 collects/mred/private/wx/win32/queue.rkt  | 10 +++++++++-
 3 files changed, 18 insertions(+), 7 deletions(-)

diff --git a/collects/mred/private/wx/common/queue.rkt b/collects/mred/private/wx/common/queue.rkt
index 687d5122..61e6832c 100644
--- a/collects/mred/private/wx/common/queue.rkt
+++ b/collects/mred/private/wx/common/queue.rkt
@@ -112,14 +112,14 @@
 
 (define (add-event-boundary-callback! v proc)
   (atomically
-   (alert-tasks-ready)
-   (hash-set! boundary-ht v proc)))
+   (hash-set! boundary-ht v proc)
+   (alert-tasks-ready)))
 (define (add-event-boundary-sometimes-callback! v proc) 
   (atomically
-   (alert-tasks-ready)
    (when (zero? (hash-count sometimes-boundary-ht))
      (set! last-time (current-inexact-milliseconds)))
-   (hash-set! sometimes-boundary-ht v proc)))
+   (hash-set! sometimes-boundary-ht v proc)
+   (alert-tasks-ready)))
 
 (define (remove-event-boundary-callback! v) 
   (atomically
diff --git a/collects/mred/private/wx/win32/canvas.rkt b/collects/mred/private/wx/win32/canvas.rkt
index 46fa3308..2dc6d0a1 100644
--- a/collects/mred/private/wx/win32/canvas.rkt
+++ b/collects/mred/private/wx/win32/canvas.rkt
@@ -264,8 +264,11 @@
      (define/public (schedule-periodic-backing-flush)
        (void))
      (define/public (do-canvas-backing-flush hdc)
-       (when hdc
-         (do-backing-flush this dc hdc)))
+       (if hdc
+           (do-backing-flush this dc hdc)
+           (let ([hdc (GetDC canvas-hwnd)])
+             (do-backing-flush this dc hdc)
+             (ReleaseDC canvas-hwnd hdc))))
 
      (define/public (make-compatible-bitmap w h)
        (send dc make-backing-bitmap w h))
diff --git a/collects/mred/private/wx/win32/queue.rkt b/collects/mred/private/wx/win32/queue.rkt
index a7acecc3..e1c194c3 100644
--- a/collects/mred/private/wx/win32/queue.rkt
+++ b/collects/mred/private/wx/win32/queue.rkt
@@ -146,6 +146,14 @@
 (define (win32-start-event-pump)
   (thread (lambda ()
             (let loop ()
-              (sync queue-evt other-peek-evt)
+              (unless (let ([any-tasks? (sync/timeout 0 boundary-tasks-ready-evt)])
+                        (sync/timeout (and any-tasks? (* sometimes-delay-msec 0.001))
+                                      queue-evt 
+                                      other-peek-evt
+                                      (if any-tasks?
+                                          (wrap-evt (system-idle-evt)
+                                                    (lambda (v) #f))
+                                          boundary-tasks-ready-evt)))
+                (pre-event-sync #t))
               (as-entry dispatch-all-ready)
               (loop)))))