From 6c367a0dcbc6653dde65ab074b8f5de9fb87ed54 Mon Sep 17 00:00:00 2001 From: Matthew Flatt Date: Tue, 7 Sep 2010 19:10:55 -0600 Subject: [PATCH] new queue level for refresh events original commit: f1e2db412f45217bbcdf362c2bdc5186089284e7 --- collects/mred/private/wx/cocoa/canvas.rkt | 5 ++-- collects/mred/private/wx/cocoa/queue.rkt | 7 +++++ collects/mred/private/wx/cocoa/window.rkt | 23 +++++++++++++-- collects/mred/private/wx/common/queue.rkt | 25 ++++++++++++++++- collects/mred/private/wx/gtk/canvas.rkt | 34 ++++++++++++----------- collects/mred/private/wx/gtk/window.rkt | 3 ++ 6 files changed, 76 insertions(+), 21 deletions(-) diff --git a/collects/mred/private/wx/cocoa/canvas.rkt b/collects/mred/private/wx/cocoa/canvas.rkt index cedc2c82..5ba1e691 100644 --- a/collects/mred/private/wx/cocoa/canvas.rkt +++ b/collects/mred/private/wx/cocoa/canvas.rkt @@ -212,8 +212,9 @@ (let ([b (box #t)]) (set! paint-queued b) (let ([req (request-flush-delay (get-cocoa-window))]) - (queue-window-event this (lambda () - (do-on-paint req b))))))) + (queue-window-refresh-event + this + (lambda () (do-on-paint req b))))))) (define/private (do-on-paint req b) ;; only called in the handler thread diff --git a/collects/mred/private/wx/cocoa/queue.rkt b/collects/mred/private/wx/cocoa/queue.rkt index 9210d293..9b2c2fea 100644 --- a/collects/mred/private/wx/cocoa/queue.rkt +++ b/collects/mred/private/wx/cocoa/queue.rkt @@ -21,6 +21,8 @@ set-menu-bar-hooks! post-dummy-event + try-to-sync-refresh + ;; from common/queue: current-eventspace queue-event @@ -255,6 +257,11 @@ ;; Called through an atomic callback: (lambda () (check-one-event #f #f))) +(define (try-to-sync-refresh) + (atomically + (pre-event-sync #t) + (check-one-event #f #f))) + ;; ------------------------------------------------------------ ;; Install an alternate "sleep" function (in the PLT Scheme core) ;; that wakes up if any Cocoa event is ready. diff --git a/collects/mred/private/wx/cocoa/window.rkt b/collects/mred/private/wx/cocoa/window.rkt index 36715256..bd29c17a 100644 --- a/collects/mred/private/wx/cocoa/window.rkt +++ b/collects/mred/private/wx/cocoa/window.rkt @@ -26,6 +26,7 @@ CursorDisplayer queue-window-event + queue-window-refresh-event queue-window*-event request-flush-delay cancel-flush-delay @@ -227,7 +228,7 @@ (if (send wx definitely-wants-event? k) (begin (queue-window-event wx (lambda () - (send wx dispatch-on-char k #f))) + (send wx dispatch-on-char/sync k))) #t) (constrained-reply (send wx get-eventspace) (lambda () (send wx dispatch-on-char k #t)) @@ -257,7 +258,7 @@ (if (send wx definitely-wants-event? m) (begin (queue-window-event wx (lambda () - (send wx dispatch-on-event m #f))) + (send wx dispatch-on-event/sync m))) #t) (constrained-reply (send wx get-eventspace) (lambda () (send wx dispatch-on-event m #t)) @@ -441,12 +442,27 @@ ;; Called in Cocoa event-handling mode #f) + (define/private (pre-event-refresh) + ;; Since we break the connection between the + ;; Cocoa queue and event handling, we'd like to + ;; re-sync the display in case a stream of + ;; events (e.g., key repeat) have a corersponding + ;; stream of screen updates. + (void)) + + (define/public (dispatch-on-char/sync e) + (pre-event-refresh) + (dispatch-on-char e #f)) (define/public (dispatch-on-char e just-pre?) (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/sync e) + (pre-event-refresh) + (dispatch-on-event e #f)) (define/public (dispatch-on-event e just-pre?) (cond [(other-modal? this) #t] @@ -547,6 +563,9 @@ (define (queue-window-event wx thunk) (queue-event (send wx get-eventspace) thunk)) +(define (queue-window-refresh-event wx thunk) + (queue-refresh-event (send wx get-eventspace) thunk)) + (define (queue-window*-event wxb proc) (let ([wx (->wx wxb)]) (when wx diff --git a/collects/mred/private/wx/common/queue.rkt b/collects/mred/private/wx/common/queue.rkt index f76205bf..6f524ac0 100644 --- a/collects/mred/private/wx/common/queue.rkt +++ b/collects/mred/private/wx/common/queue.rkt @@ -19,7 +19,9 @@ eventspace? current-eventspace queue-event + queue-refresh-event yield + yield-refresh (rename-out [make-new-eventspace make-eventspace]) event-dispatch-handler @@ -176,6 +178,7 @@ (let ([count 0]) (let ([lo (mcons #f #f)] [med (mcons #f #f)] + [refresh (mcons #f #f)] [hi (mcons #f #f)] [timer (box '())] [timer-counter 0] @@ -224,6 +227,7 @@ (case (car v) [(lo) (enqueue val lo)] [(med) (enqueue val med)] + [(refresh) (enqueue val refresh)] [(hi) (enqueue val hi)] [(timer-add) (set! timer-counter (add1 timer-counter)) @@ -272,12 +276,19 @@ (or (first hi) (timer-first-ready timer) (first med) + (first refresh) (first lo) (timer-first-wait timer) ;; nothing else ready... never-evt))]) (end-atomic) - e))])))) + e))] + [(_1 _2) + ;; Dequeue only refresh event + (start-atomic) + (begin0 + (or (first refresh) never-evt) + (end-atomic))])))) frames (semaphore-peek-evt done-sema) #f @@ -313,6 +324,9 @@ (define (queue-event eventspace thunk [level 'med]) ((eventspace-queue-proc eventspace) (cons level thunk))) +(define (queue-refresh-event eventspace thunk) + ((eventspace-queue-proc eventspace) (cons 'refresh thunk))) + (define (handle-event thunk) (let/ec esc (let ([done? #f]) @@ -357,6 +371,15 @@ [else (sync evt)]))])) +(define yield-refresh + (lambda () + (let ([e (current-eventspace)]) + (when (eq? (current-thread) (eventspace-handler-thread e)) + (let ([v (sync/timeout 0 ((eventspace-queue-proc e) #f #f))]) + (when v + (handle-event v) + (yield-refresh))))))) + (define event-dispatch-handler (make-parameter void)) (define (main-eventspace? e) (eq? e main-eventspace)) diff --git a/collects/mred/private/wx/gtk/canvas.rkt b/collects/mred/private/wx/gtk/canvas.rkt index 1e40e7c0..a046cde1 100644 --- a/collects/mred/private/wx/gtk/canvas.rkt +++ b/collects/mred/private/wx/gtk/canvas.rkt @@ -343,22 +343,24 @@ ;; 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) - (set! now-drawing? #t) - (send dc reset-backing-retained) ; clean slate - (send dc ensure-ready) - (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) - (set! now-drawing? #f) - (when refresh-after-drawing? - (set! refresh-after-drawing? #f) - (refresh)))))) + (queue-window-refresh-event + this + (lambda () + (set! paint-queued? #f) + (set! now-drawing? #t) + (send dc reset-backing-retained) ; clean slate + (send dc ensure-ready) + (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) + (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? diff --git a/collects/mred/private/wx/gtk/window.rkt b/collects/mred/private/wx/gtk/window.rkt index 321eb1bb..6b7d6335 100644 --- a/collects/mred/private/wx/gtk/window.rkt +++ b/collects/mred/private/wx/gtk/window.rkt @@ -19,6 +19,7 @@ (provide window% gtk->wx queue-window-event + queue-window-refresh-event gtk_widget_show gtk_widget_hide @@ -544,3 +545,5 @@ (define (queue-window-event win thunk) (queue-event (send win get-eventspace) thunk)) +(define (queue-window-refresh-event win thunk) + (queue-refresh-event (send win get-eventspace) thunk))