suzanne.soy/gui
1
0
Fork 0
Code Issues Pull Requests Actions Packages Projects Releases Wiki Activity

new queue level for refresh events

Browse Source 
original commit: f1e2db412f45217bbcdf362c2bdc5186089284e7
This commit is contained in:
Matthew Flatt 2010-09-07 19:10:55 -06:00
parent c31c8b9163
commit 6c367a0dcb
6 changed files with 76 additions and 21 deletions
Show Stats Download Patch File Download Diff File Expand all files Collapse all files

5
collects/mred/private/wx/cocoa/canvas.rkt
View File

@ -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

7
collects/mred/private/wx/cocoa/queue.rkt
View File

@ -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.

23
collects/mred/private/wx/cocoa/window.rkt
View File

@ -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

25
collects/mred/private/wx/common/queue.rkt
View File

@ -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))

34
collects/mred/private/wx/gtk/canvas.rkt
View File

@ -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?

3
collects/mred/private/wx/gtk/window.rkt
View File

@ -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))