diff --git a/collects/mred/private/wx/cocoa/canvas.rkt b/collects/mred/private/wx/cocoa/canvas.rkt index e791fc55d8..7488e4905d 100644 --- a/collects/mred/private/wx/cocoa/canvas.rkt +++ b/collects/mred/private/wx/cocoa/canvas.rkt @@ -272,9 +272,11 @@ ;; are defined by `canvas-mixin' from ../common/canvas-mixin (define/public (queue-paint) (void)) (define/public (request-canvas-flush-delay) - (request-flush-delay (get-cocoa-window))) + (unless is-gl? + (request-flush-delay (get-cocoa-window)))) (define/public (cancel-canvas-flush-delay req) - (cancel-flush-delay req)) + (unless is-gl? + (cancel-flush-delay req))) (define/public (queue-canvas-refresh-event thunk) (queue-window-refresh-event this thunk)) diff --git a/collects/mred/private/wx/cocoa/dc.rkt b/collects/mred/private/wx/cocoa/dc.rkt index b6c04bf087..b739fa88bd 100644 --- a/collects/mred/private/wx/cocoa/dc.rkt +++ b/collects/mred/private/wx/cocoa/dc.rkt @@ -26,6 +26,7 @@ (init [(cnvs canvas)]) (define canvas cnvs) + (inherit end-delay) (super-new) (define gl #f) @@ -59,21 +60,18 @@ (values (unbox xb) (unbox yb)))) (define/override (queue-backing-flush) - ;; With Cocoa window-level delay doesn't stop - ;; displays; it blocks flushes to the screen. - ;; So leave the delay in place, and `end-delay' - ;; after displaying to the window (after which - ;; we'll be ready to flush the window), which - ;; is at then end of `do-backing-flush'. + ;; Re-enable expose events so that the queued + ;; backing flush will be handled: + (end-delay) (send canvas queue-backing-flush)) (define/override (flush) (send canvas flush)) (define/override (request-delay) - (request-flush-delay (send canvas get-flush-window))) + (send canvas request-canvas-flush-delay)) (define/override (cancel-delay req) - (cancel-flush-delay req)))) + (send canvas cancel-canvas-flush-delay req)))) (define (do-backing-flush canvas dc ctx dx dy) (tellv ctx saveGraphicsState) @@ -99,6 +97,5 @@ (cairo_fill cr) (cairo_set_source cr s) (cairo_pattern_destroy s)) - (cairo_destroy cr)))) - (send dc end-delay))) + (cairo_destroy cr)))))) (tellv ctx restoreGraphicsState))) diff --git a/collects/mred/private/wx/common/delay.rkt b/collects/mred/private/wx/common/delay.rkt index 7898a2d31f..ef8d704432 100644 --- a/collects/mred/private/wx/common/delay.rkt +++ b/collects/mred/private/wx/common/delay.rkt @@ -6,19 +6,28 @@ (protect-out do-request-flush-delay do-cancel-flush-delay)) +;; Auto-cancel schedules a cancel of a request flush +;; on event boundaries. It makes sense if you don't +;; trust a program to un-delay important refreshes, +;; but auto-cancel is currently disabled because +;; bad refresh-delay effects are confined to the enclosing +;; window on all platforms. +(define AUTO-CANCEL-DELAY? #f) + (define (do-request-flush-delay win disable enable) (atomically (let ([req (box win)]) (and (disable win) (begin - (add-event-boundary-sometimes-callback! - req - (lambda (v) - ;; in atomic mode - (when (unbox req) - (set-box! req #f) - (enable win)))) + (when AUTO-CANCEL-DELAY? + (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) @@ -27,4 +36,5 @@ (when win (set-box! req #f) (enable win) - (remove-event-boundary-callback! req))))) + (when AUTO-CANCEL-DELAY? + (remove-event-boundary-callback! req))))))