From 921d351bf6c05618b8c0577246c7a32b1cd1a3db Mon Sep 17 00:00:00 2001 From: Matthew Flatt Date: Sun, 12 Sep 2010 15:39:06 -0600 Subject: [PATCH] toward better refresh for gtk & other bug fixes original commit: e72cf8517584c9904a5279c2cd7d587d372f67f6 --- collects/mred/private/wx/cocoa/canvas.rkt | 3 ++ collects/mred/private/wx/cocoa/dc.rkt | 26 ++--------- collects/mred/private/wx/cocoa/window.rkt | 28 +++++------ .../mred/private/wx/common/backing-dc.rkt | 26 +++++++++-- collects/mred/private/wx/common/delay.rkt | 27 +++++++++++ collects/mred/private/wx/common/queue.rkt | 37 +++++++++++---- collects/mred/private/wx/gtk/canvas.rkt | 3 ++ collects/mred/private/wx/gtk/cursor.rkt | 1 - collects/mred/private/wx/gtk/dc.rkt | 40 +++++++++------- collects/mred/private/wx/gtk/message.rkt | 3 +- collects/mred/private/wx/gtk/procs.rkt | 6 +-- collects/mred/private/wx/gtk/queue.rkt | 16 ++++++- collects/mred/private/wx/gtk/types.rkt | 3 ++ collects/mred/private/wx/gtk/utils.rkt | 4 +- collects/mred/private/wx/gtk/window.rkt | 46 ++++++++++++++++++- collects/mred/private/wxme/text.rkt | 4 +- 16 files changed, 194 insertions(+), 79 deletions(-) create mode 100644 collects/mred/private/wx/common/delay.rkt diff --git a/collects/mred/private/wx/cocoa/canvas.rkt b/collects/mred/private/wx/cocoa/canvas.rkt index 3be04ed7..6a000998 100644 --- a/collects/mred/private/wx/cocoa/canvas.rkt +++ b/collects/mred/private/wx/cocoa/canvas.rkt @@ -263,6 +263,9 @@ (define/public (end-refresh-sequence) (send dc resume-flush)) + (define/public (get-flush-window) + (get-cocoa-window)) + (define/override (refresh) ;; can be called from any thread, including the event-pump thread (queue-paint)) diff --git a/collects/mred/private/wx/cocoa/dc.rkt b/collects/mred/private/wx/cocoa/dc.rkt index c8986fc4..00aa41d2 100644 --- a/collects/mred/private/wx/cocoa/dc.rkt +++ b/collects/mred/private/wx/cocoa/dc.rkt @@ -39,8 +39,6 @@ (cairo_surface_destroy s) (set! s #f))))) -(define-local-member-name end-delay) - (define dc% (class backing-dc% (init [(cnvs canvas)]) @@ -65,26 +63,10 @@ ;; called atomically (not expecting exceptions) (send canvas queue-backing-flush)) - (define suspend-count 0) - (define req #f) - - (define/override (suspend-flush) - (atomically - (when (zero? suspend-count) - (when req (cancel-flush-delay req)) - (set! req (request-flush-delay (send canvas get-cocoa-window)))) - (set! suspend-count (add1 suspend-count)) - (super suspend-flush))) - - (define/override (resume-flush) - (atomically - (set! suspend-count (sub1 suspend-count)) - (super resume-flush))) - - (define/public (end-delay) - (when (and (zero? suspend-count) req) - (cancel-flush-delay req) - (set! req #f))))) + (define/override (request-delay) + (request-flush-delay (send canvas get-flush-window))) + (define/override (cancel-delay req) + (cancel-flush-delay req)))) (define (do-backing-flush canvas dc ctx dx dy) (tellv ctx saveGraphicsState) diff --git a/collects/mred/private/wx/cocoa/window.rkt b/collects/mred/private/wx/cocoa/window.rkt index 28deb6d7..269c6545 100644 --- a/collects/mred/private/wx/cocoa/window.rkt +++ b/collects/mred/private/wx/cocoa/window.rkt @@ -13,6 +13,7 @@ "../../lock.rkt" "../common/event.rkt" "../common/queue.rkt" + "../common/delay.rkt" "../../syntax.rkt" "../common/freeze.rkt") (unsafe!) @@ -651,25 +652,18 @@ (queue-event (send wx get-eventspace) (lambda () (proc wx)))))) (define (request-flush-delay cocoa-win) - (atomically - (let ([req (box cocoa-win)]) - (tellv cocoa-win disableFlushWindow) - (add-event-boundary-sometimes-callback! - req - (lambda (v) - ;; in atomic mode - (when (unbox req) - (set-box! req #f) - (tellv cocoa-win enableFlushWindow)))) - req))) + (do-request-flush-delay + cocoa-win + (lambda (cocoa-win) + (tellv cocoa-win disableFlushWindow)) + (lambda (cocoa-win) + (tellv cocoa-win enableFlushWindow)))) (define (cancel-flush-delay req) - (atomically - (let ([cocoa-win (unbox req)]) - (when cocoa-win - (set-box! req #f) - (tellv cocoa-win enableFlushWindow) - (remove-event-boundary-callback! req))))) + (do-cancel-flush-delay + req + (lambda (cocoa-win) + (tellv cocoa-win enableFlushWindow)))) (define (make-init-point x y) (make-NSPoint (if (= x -11111) diff --git a/collects/mred/private/wx/common/backing-dc.rkt b/collects/mred/private/wx/common/backing-dc.rkt index 4c640897..4d5e71b2 100644 --- a/collects/mred/private/wx/common/backing-dc.rkt +++ b/collects/mred/private/wx/common/backing-dc.rkt @@ -16,7 +16,10 @@ start-backing-retained end-backing-retained reset-backing-retained - get-bitmap%) + get-bitmap% + request-delay + cancel-delay + end-delay) (define-local-member-name get-backing-size @@ -25,7 +28,10 @@ start-backing-retained end-backing-retained reset-backing-retained - get-bitmap%) + get-bitmap% + request-delay + cancel-delay + end-delay) (define backing-dc% (class (dc-mixin bitmap-dc-backend%) @@ -110,15 +116,29 @@ (queue-backing-flush))) (define flush-suspends 0) + (define req #f) + + (define/public (request-delay) (void)) + (define/public (cancel-delay req) (void)) (define/override (suspend-flush) (atomically + (when (zero? flush-suspends) + (when req (cancel-delay req)) + (set! req (request-delay))) (set! flush-suspends (add1 flush-suspends)))) + (define/override (resume-flush) (atomically (set! flush-suspends (sub1 flush-suspends)) (when (zero? flush-suspends) - (queue-backing-flush)))))) + (queue-backing-flush)))) + + (define/public (end-delay) + ;; call in atomic mode + (when (and (zero? flush-suspends) req) + (cancel-delay req) + (set! req #f))))) (define (get-backing-bitmap bitmap% w h) (make-object bitmap% w h #f #t)) diff --git a/collects/mred/private/wx/common/delay.rkt b/collects/mred/private/wx/common/delay.rkt new file mode 100644 index 00000000..ef2aba0a --- /dev/null +++ b/collects/mred/private/wx/common/delay.rkt @@ -0,0 +1,27 @@ +#lang racket/base +(require "../../lock.rkt" + "queue.rkt") + +(provide do-request-flush-delay + do-cancel-flush-delay) + +(define (do-request-flush-delay win disable enable) + (atomically + (let ([req (box win)]) + (disable win) + (add-event-boundary-sometimes-callback! + req + (lambda (v) + ;; in atomic mode + (when (unbox req) + (set-box! req #f) + (enable win)))) + req))) + +(define (do-cancel-flush-delay req enable) + (atomically + (let ([win (unbox req)]) + (when win + (set-box! req #f) + (enable win) + (remove-event-boundary-callback! req))))) diff --git a/collects/mred/private/wx/common/queue.rkt b/collects/mred/private/wx/common/queue.rkt index 0f0672e6..700b1c83 100644 --- a/collects/mred/private/wx/common/queue.rkt +++ b/collects/mred/private/wx/common/queue.rkt @@ -15,6 +15,7 @@ add-event-boundary-sometimes-callback! remove-event-boundary-callback! pre-event-sync + boundary-tasks-ready-evt eventspace? current-eventspace @@ -97,16 +98,35 @@ (define boundary-ht (make-hasheq)) (define sometimes-boundary-ht (make-hasheq)) -(define (add-event-boundary-callback! v proc) - (hash-set! boundary-ht v proc)) +(define tasks-ready? #f) +(define task-ready-sema (make-semaphore)) +(define boundary-tasks-ready-evt (semaphore-peek-evt task-ready-sema)) + +(define (alert-tasks-ready) + (let ([ready? (or (positive? (hash-count boundary-ht)) + (positive? (hash-count sometimes-boundary-ht)))]) + (unless (eq? ready? tasks-ready?) + (set! tasks-ready? ready?) + (if ready? + (semaphore-post task-ready-sema) + (semaphore-wait task-ready-sema))))) + +(define (add-event-boundary-callback! v proc) + (atomically + (alert-tasks-ready) + (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)) + (atomically + (alert-tasks-ready) + (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) - (hash-remove! boundary-ht v) - (hash-remove! sometimes-boundary-ht v)) + (atomically + (hash-remove! boundary-ht v) + (hash-remove! sometimes-boundary-ht v) + (alert-tasks-ready))) (define last-time -inf.0) @@ -118,7 +138,8 @@ (set! last-time now) (hash-for-each sometimes-boundary-ht (lambda (v p) (hash-remove! sometimes-boundary-ht v) (p v))))) - (hash-for-each boundary-ht (lambda (v p) (hash-remove! boundary-ht v) (p v)))) + (hash-for-each boundary-ht (lambda (v p) (hash-remove! boundary-ht v) (p v))) + (alert-tasks-ready)) ;; ------------------------------------------------------------ ;; Eventspaces diff --git a/collects/mred/private/wx/gtk/canvas.rkt b/collects/mred/private/wx/gtk/canvas.rkt index 748bd5e7..f0d39bb0 100644 --- a/collects/mred/private/wx/gtk/canvas.rkt +++ b/collects/mred/private/wx/gtk/canvas.rkt @@ -375,6 +375,8 @@ (define/public (on-paint) (void)) + (define/public (get-flush-window) client-gtk) + (define/public (begin-refresh-sequence) (void)) (define/public (end-refresh-sequence) (void)) @@ -393,6 +395,7 @@ (define/private (reset-dc) (send dc reset-backing-retained) + (refresh) (send dc set-auto-scroll (if virtual-width (gtk_adjustment_get_value hscroll-adj) diff --git a/collects/mred/private/wx/gtk/cursor.rkt b/collects/mred/private/wx/gtk/cursor.rkt index fb6d7420..564e6536 100644 --- a/collects/mred/private/wx/gtk/cursor.rkt +++ b/collects/mred/private/wx/gtk/cursor.rkt @@ -37,7 +37,6 @@ (define _GdkCursor (_cpointer 'GdkCursor)) (define-gdk gdk_cursor_new (_fun _int -> _GdkCursor)) -(define _GdkDisplay (_cpointer 'GdkDisplay)) (define-gdk gdk_display_get_default (_fun -> _GdkDisplay)) (define-gdk gdk_cursor_new_from_pixbuf (_fun _GdkDisplay _GdkPixbuf _int _int -> _GdkCursor)) diff --git a/collects/mred/private/wx/gtk/dc.rkt b/collects/mred/private/wx/gtk/dc.rkt index a4a812dc..6907353d 100644 --- a/collects/mred/private/wx/gtk/dc.rkt +++ b/collects/mred/private/wx/gtk/dc.rkt @@ -3,6 +3,7 @@ racket/class "utils.rkt" "types.rkt" + "window.rkt" "../../lock.rkt" "../common/backing-dc.rkt" racket/draw/cairo @@ -34,21 +35,28 @@ (define/override (queue-backing-flush) ;; called atomically (not expecting exceptions) - (send canvas queue-backing-flush)))) + (send canvas queue-backing-flush)) + + (define/override (request-delay) + (request-flush-delay (send canvas get-flush-window))) + (define/override (cancel-delay req) + (cancel-flush-delay req)))) (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)))))) + (begin0 + (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))))) + (send dc end-delay))) diff --git a/collects/mred/private/wx/gtk/message.rkt b/collects/mred/private/wx/gtk/message.rkt index 5f2552a5..aa3c26b9 100644 --- a/collects/mred/private/wx/gtk/message.rkt +++ b/collects/mred/private/wx/gtk/message.rkt @@ -64,7 +64,8 @@ (as-gtk-allocation (gtk_image_new_from_pixbuf pixbuf)) (release-pixbuf pixbuf))) - (gtk_label_new_with_mnemonic ""))))] + (as-gtk-allocation + (gtk_label_new_with_mnemonic "")))))] [no-show? (memq 'deleted style)]) (when (string? label) diff --git a/collects/mred/private/wx/gtk/procs.rkt b/collects/mred/private/wx/gtk/procs.rkt index c7e91cbd..67e44296 100644 --- a/collects/mred/private/wx/gtk/procs.rkt +++ b/collects/mred/private/wx/gtk/procs.rkt @@ -9,6 +9,7 @@ "utils.rkt" "style.rkt" "widget.rkt" + "window.rkt" "../common/handlers.rkt") (provide @@ -92,11 +93,6 @@ (define-unimplemented cancel-quit) (define-unimplemented fill-private-color) -(define _GdkDisplay (_cpointer 'GdkDisplay)) -(define-gdk gdk_display_flush (_fun _GdkDisplay -> _void)) -(define-gdk gdk_display_get_default (_fun -> _GdkDisplay)) -(define (flush-display) (gdk_display_flush (gdk_display_get_default))) - (define-unimplemented write-resource) (define-unimplemented get-resource) diff --git a/collects/mred/private/wx/gtk/queue.rkt b/collects/mred/private/wx/gtk/queue.rkt index 8abda62e..332c7c3d 100644 --- a/collects/mred/private/wx/gtk/queue.rkt +++ b/collects/mred/private/wx/gtk/queue.rkt @@ -11,6 +11,8 @@ (provide gtk-start-event-pump + try-to-sync-refresh + set-widget-hook! ;; from common/queue: @@ -68,7 +70,6 @@ #:fail #f) (define (install-wakeup fds) - (pre-event-sync #t) (let ([n (g_main_context_query (g_main_context_default) #x7FFFFFFF ; max-int, hopefully timeout @@ -135,9 +136,20 @@ (gtk_main_iteration_do #f) (dispatch-all-ready))) +(define-gdk gdk_window_process_all_updates (_fun -> _void)) + (define (gtk-start-event-pump) (thread (lambda () (let loop () - (sync queue-evt) + (unless (let ([any-tasks? (sync/timeout 0 boundary-tasks-ready-evt)]) + (sync queue-evt (if any-tasks? + (wrap-evt (system-idle-evt) + (lambda (v) #f)) + boundary-tasks-ready-evt))) + (pre-event-sync #t)) (atomically (dispatch-all-ready)) (loop))))) + +(define (try-to-sync-refresh) + (atomically + (pre-event-sync #t))) diff --git a/collects/mred/private/wx/gtk/types.rkt b/collects/mred/private/wx/gtk/types.rkt index 3e5b1afe..2f51e5e2 100644 --- a/collects/mred/private/wx/gtk/types.rkt +++ b/collects/mred/private/wx/gtk/types.rkt @@ -4,6 +4,7 @@ (provide _GdkWindow _GtkWidget _GtkWindow + _GdkDisplay _gpointer _GType @@ -34,6 +35,8 @@ (define _GtkWidget (_cpointer 'GtkWidget)) (define _GtkWindow _GtkWidget) +(define _GdkDisplay (_cpointer 'GdkDisplay)) + (define _gpointer _GtkWidget) (define _GdkDevice (_cpointer 'GdkDevice)) diff --git a/collects/mred/private/wx/gtk/utils.rkt b/collects/mred/private/wx/gtk/utils.rkt index f91f6a96..6a1007c8 100644 --- a/collects/mred/private/wx/gtk/utils.rkt +++ b/collects/mred/private/wx/gtk/utils.rkt @@ -125,7 +125,9 @@ (g_object_ref_sink v) v))))) (define-syntax-rule (as-gtk-window-allocation expr) - ((gtk-allocator (lambda () expr)))) + ((gtk-allocator (lambda () (let ([v expr]) + (g_object_ref v) + v))))) (define-glib g_free (_fun _pointer -> _void)) diff --git a/collects/mred/private/wx/gtk/window.rkt b/collects/mred/private/wx/gtk/window.rkt index e4414c6b..b6a00d61 100644 --- a/collects/mred/private/wx/gtk/window.rkt +++ b/collects/mred/private/wx/gtk/window.rkt @@ -8,6 +8,7 @@ "../common/freeze.rkt" "../common/queue.rkt" "../common/local.rkt" + "../common/delay.rkt" "keycode.rkt" "keymap.rkt" "queue.rkt" @@ -42,7 +43,13 @@ the-accelerator-group gtk_window_add_accel_group - gtk_menu_set_accel_group) + gtk_menu_set_accel_group + + flush-display + gdk_display_get_default + + request-flush-delay + cancel-flush-delay) ;; ---------------------------------------- @@ -517,14 +524,26 @@ (define/public (on-set-focus) (void)) (define/public (on-kill-focus) (void)) + (define/private (pre-event-refresh) + ;; Since we break the connection between the + ;; Gtk 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) + (gdk_window_process_all_updates) + (flush-display)) + (define/public (handles-events? gtk) #f) (define/public (dispatch-on-char e just-pre?) + (pre-event-refresh) (cond [(other-modal? this) #t] [(call-pre-on-char this e) #t] [just-pre? #f] [else (when enabled? (on-char e)) #t])) (define/public (dispatch-on-event e just-pre?) + (pre-event-refresh) (cond [(other-modal? this) #t] [(call-pre-on-event this e) #t] @@ -591,3 +610,28 @@ (queue-event (send win get-eventspace) thunk)) (define (queue-window-refresh-event win thunk) (queue-refresh-event (send win get-eventspace) thunk)) + +(define-gdk gdk_display_flush (_fun _GdkDisplay -> _void)) +(define-gdk gdk_display_sync (_fun _GdkDisplay -> _void)) +(define-gdk gdk_display_get_default (_fun -> _GdkDisplay)) +(define (flush-display) (gdk_display_flush (gdk_display_get_default))) +(define (sync-display) (gdk_display_sync (gdk_display_get_default))) + +(define-gdk gdk_window_freeze_updates (_fun _GdkWindow -> _void)) +(define-gdk gdk_window_thaw_updates (_fun _GdkWindow -> _void)) +(define-gdk gdk_window_invalidate_rect (_fun _GdkWindow _pointer _gboolean -> _void)) +(define-gdk gdk_window_process_all_updates (_fun -> _void)) + +(define (request-flush-delay gtk) + (do-request-flush-delay + gtk + (lambda (gtk) + (gdk_window_freeze_updates (widget-window gtk))) + (lambda (gtk) + (gdk_window_thaw_updates (widget-window gtk))))) + +(define (cancel-flush-delay req) + (do-cancel-flush-delay + req + (lambda (gtk) + (gdk_window_thaw_updates (widget-window gtk))))) diff --git a/collects/mred/private/wxme/text.rkt b/collects/mred/private/wxme/text.rkt index 3736bda0..86458dee 100644 --- a/collects/mred/private/wxme/text.rkt +++ b/collects/mred/private/wxme/text.rkt @@ -4980,8 +4980,8 @@ (dc . is-a? . printer-dc%))] [show-xsel? (and ALLOW-X-STYLE-SELECTION? - (or (not (eq? 'show-caret show-caret)) - (not (pair? show-caret)) + (or (and (not (eq? 'show-caret show-caret)) + (not (pair? show-caret))) s-caret-snip) (eq? this editor-x-selection-owner) (not flash?)