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

toward better refresh for gtk & other bug fixes

Browse Source
This commit is contained in:
Matthew Flatt 2010-09-12 15:39:06 -06:00
parent f41bd0ffc1
commit e72cf85175
16 changed files with 194 additions and 79 deletions
Show Stats Download Patch File Download Diff File Expand all files Collapse all files

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

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

26
collects/mred/private/wx/cocoa/dc.rkt
View File

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

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

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

26
collects/mred/private/wx/common/backing-dc.rkt
View File

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

27
collects/mred/private/wx/common/delay.rkt Normal file
View File

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

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

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

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

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

1
collects/mred/private/wx/gtk/cursor.rkt
View File

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

40
collects/mred/private/wx/gtk/dc.rkt
View File

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

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

@ -64,7 +64,8 @@
(as-gtk-allocation
(gtk_image_new_from_pixbuf pixbuf))
(release-pixbuf pixbuf)))
(gtk_label_new_with_mnemonic "<bad-image>"))))]
(as-gtk-allocation
(gtk_label_new_with_mnemonic "<bad-image>")))))]
[no-show? (memq 'deleted style)])
(when (string? label)

6
collects/mred/private/wx/gtk/procs.rkt
View File

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

16
collects/mred/private/wx/gtk/queue.rkt
View File

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

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

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

4
collects/mred/private/wx/gtk/utils.rkt
View File

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

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

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

4
collects/mred/private/wxme/text.rkt
View File

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