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

win32: periodic canvas flushing

Browse Source 
original commit: 4d316f78510aed0ff5a90dd038994c6da0eaabda
This commit is contained in:
Matthew Flatt 2010-11-01 08:09:42 -06:00
parent 303034be6f
commit 6482978363
3 changed files with 18 additions and 7 deletions
Show Stats Download Patch File Download Diff File Expand all files Collapse all files

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

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

7
collects/mred/private/wx/win32/canvas.rkt
View File

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

10
collects/mred/private/wx/win32/queue.rkt
View File

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