switch gtk to new canvas-refresh strategy

collects/mred/private/wx/common/queue.rkt

@@ -93,6 +93,8 @@
 (define (add-event-boundary-callback! v proc) 
   (hash-set! boundary-ht v proc))
 (define (add-event-boundary-sometimes-callback! v proc) 
+  (when (zero? (hash-count sometimes-boundary-ht))
+    (set! last-time (current-inexact-milliseconds)))
   (hash-set! sometimes-boundary-ht v proc))
 
 (define (remove-event-boundary-callback! v) 

collects/mred/private/wx/gtk/canvas.rkt

@@ -4,6 +4,8 @@
          racket/draw
          ffi/unsafe/alloc
          racket/draw/color
+         racket/draw/local
+         "../common/backing-dc.rkt"
          "../../syntax.rkt"
          "../common/event.rkt"
          "utils.rkt"
@@ -86,11 +88,11 @@
   (_fun _GtkWidget _GdkEventExpose-pointer -> _gboolean)
   (lambda (gtk event)
     (let ([wx (gtk->wx gtk)])
-      (let ([gc (send wx get-canvas-background-for-clearing)])      
+      (unless (send wx paint-or-queue-paint)
-        (when gc
+        (let ([gc (send wx get-canvas-background-for-clearing)])      
-          (gdk_draw_rectangle (g_object_get_window gtk) gc #t
+          (when gc
-                              0 0 32000 32000)))
+            (gdk_draw_rectangle (g_object_get_window gtk) gc #t
-      (send wx queue-paint))
+                                0 0 32000 32000)))))
     #t))
 
 (define-signal-handler connect-expose-border "expose-event"
@@ -220,18 +222,7 @@
     
     (set-size x y w h)
 
-    (define dc (new dc% 
+    (define dc (new dc% [canvas this]))
-                    [gtk client-gtk]
-                    [get-client-size (lambda ()
-                                       (let ([w (box 0)]
-                                             [h (box 0)])
-                                         (get-virtual-size w h)
-                                         (values (unbox w) (unbox h))))]
-		    [window-lock (send (get-top-win) get-dc-lock)]
-                    [get-window (lambda (client-gtk)
-                                  (if is-combo?
-                                      (get-subwindow client-gtk)
-                                      (g_object_get_window client-gtk)))]))
 
     (gtk_widget_realize gtk)
     (gtk_widget_realize client-gtk)
@@ -287,15 +278,27 @@
         (queue-window-event this (lambda () 
                                    (set! paint-queued? #f)
                                    (set! now-drawing? #t)
+                                   (send dc reset-backing-retained) ; clean slate
                                    (on-paint)
                                    (set! now-drawing? #f)
                                    (when refresh-after-drawing?
                                      (set! refresh-after-drawing? #f)
                                      (refresh))))))
 
+    (define/public (paint-or-queue-paint)
+      (or (do-backing-flush this dc (if is-combo?
+                                        (get-subwindow client-gtk)
+                                        (g_object_get_window client-gtk)))
+          (begin
+            (queue-paint)
+            #f)))
+
     (define/public (on-paint) (void))
 
     (define/override (refresh)
+      (queue-paint))
+
+    (define/public (queue-backing-flush)
       (gtk_widget_queue_draw client-gtk))
     
     (define/public (reset-child-dcs)
@@ -305,7 +308,10 @@
       (register-as-child parent on?)
       (when on? (reset-child-dcs)))
 
+    (send dc start-backing-retained)
+
     (define/private (reset-dc)
+      (send dc reset-backing-retained)
       (if auto-scroll?
           (send dc reset-dc 
                 (if virtual-width
@@ -314,7 +320,7 @@
                 (if virtual-height
                     (gtk_adjustment_get_value vscroll-adj)
                     0))
-          (send dc reset-dc 0 0)))
+          (void)))
 
     (define/override (internal-on-client-size w h)
       (reset-dc))

collects/mred/private/wx/gtk/dc.rkt

@@ -4,64 +4,72 @@
          "utils.rkt"
          "types.rkt"
 	 "../../lock.rkt"
+         "../common/backing-dc.rkt"
          racket/draw/cairo
          racket/draw/dc
          racket/draw/local
          ffi/unsafe/alloc)
 
-(provide dc% reset-dc)
+(provide dc%
+         do-backing-flush)
 
 (define-gdk gdk_cairo_create (_fun _pointer -> _cairo_t)
   #:wrap (allocator cairo_destroy))
 
-(define-local-member-name
+(define dc%
-  reset-dc)
+  (class backing-dc%
+    (init [(cnvs canvas)])
+    (define canvas cnvs)
 
-(define dc-backend%
+    (super-new)
-  (class default-dc-backend%
-    (init-field gtk
-                get-client-size
-		window-lock
-                [get-window g_object_get_window])
-    (inherit reset-cr set-auto-scroll)
 
-    (define c #f)
+    (define/override (get-backing-size xb yb)
-
+      (send canvas get-client-size xb yb))
-    (define/override (get-cr)
-      (or c
-          (let ([w (get-window gtk)])
-            (and w
-		 (begin
-		   ;; Under Windows, creating a Cairo context within
-		   ;; a frame inteferes with any other Cairo context 
-		   ;; within the same frame. So we use a lock to 
-		   ;; serialize drawing to different contexts.
-		   (when window-lock (semaphore-wait window-lock))
-                   (set! c (gdk_cairo_create w))
-		   (reset-cr c)
-		   c)))))
-
-    (define/override (release-cr cr)
-      (when window-lock
-	(cairo_destroy c)
-	(set! c #f)
-	(semaphore-post window-lock)))
-
-    (define/public (reset-dc scroll-dx scroll-dy)
-      ;; FIXME: ensure that the dc is not in use
-      (as-entry
-       (lambda ()
-         (when c
-           (cairo_destroy c)
-           (set! c #f))
-         (set-auto-scroll scroll-dx scroll-dy))))
 
     (define/override (get-size)
-      (let-values ([(w h) (get-client-size)])
+      (let ([xb (box 0)]
-      (values (exact->inexact w)
+            [yb (box 0)])
-              (exact->inexact h))))
+        (send canvas get-virtual-size xb yb)
-    
+        (values (unbox xb) (unbox yb))))
-    (super-new)))
 
-(define dc%
+    (define/override (queue-backing-flush)
-  (dc-mixin dc-backend%))
+      (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 win)
+  (send dc on-backing-flush
+        (lambda (bm)
+          (let ([w (box 0)]
+                [h (box 0)])
+            (send canvas get-client-size w h)
+            (let ([cr (gdk_cairo_create win)])
+              (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))))))

collects/mred/private/wxme/editor.rkt

@@ -63,7 +63,8 @@
   (define/public (set-last-used v) (set! last-used v))
 
   (define/public (ready-offscreen width height)
-    (if (or (width . > . RIDICULOUS-SIZE)
+    (if (or #t ; disable on all  platforms
+            (width . > . RIDICULOUS-SIZE)
             (height . > . RIDICULOUS-SIZE)
             (eq? (system-type) 'macosx))
         #f