From 48f7ddafe4d3363635f775a0da0980065718d5a4 Mon Sep 17 00:00:00 2001 From: Matthew Flatt Date: Sat, 5 May 2012 07:58:38 -0600 Subject: [PATCH] racket/gui: fix some concurrency problems `text%' Changed `open-output-text-editor' to put its additions into an edit sequence to better work with threads. Fixed problems in editor-canvas refresh and resize events, where the editor's refresh synchronization wasn't used properly. Fixed race conditions in the the protocol that is used to separate refreshes and edit sequences. Related to PR 12749 --- collects/mred/private/snipfile.rkt | 2 + collects/mred/private/wxme/editor-canvas.rkt | 90 ++++--- collects/mred/private/wxme/editor.rkt | 7 +- collects/mred/private/wxme/pasteboard.rkt | 5 +- collects/mred/private/wxme/text.rkt | 244 ++++++++++-------- .../scribblings/gui/editor-overview.scrbl | 4 +- 6 files changed, 196 insertions(+), 156 deletions(-) diff --git a/collects/mred/private/snipfile.rkt b/collects/mred/private/snipfile.rkt index d2c96928a1..9a9973d289 100644 --- a/collects/mred/private/snipfile.rkt +++ b/collects/mred/private/snipfile.rkt @@ -322,7 +322,9 @@ (define raw-buffer (make-bytes 128)) (define utf8-buffer (make-bytes 128)) (define (show s) + (send text begin-edit-sequence) (send text insert s pos) + (send text end-edit-sequence) (set! pos (+ (string-length s) pos))) (define (flush-text) (let ([cnt (peek-bytes-avail!* raw-buffer 0 #f in)]) diff --git a/collects/mred/private/wxme/editor-canvas.rkt b/collects/mred/private/wxme/editor-canvas.rkt index e281bb47a9..bad0f0d233 100644 --- a/collects/mred/private/wxme/editor-canvas.rkt +++ b/collects/mred/private/wxme/editor-canvas.rkt @@ -294,12 +294,14 @@ (unless noloop? (unless (and media (send media get-printing)) + (begin-refresh-sequence) (let-boxes ([w 0] [h 0]) (get-size w h) (unless (and (= w lastwidth) (= h lastheight)) - (reset-size)))))) + (reset-size))) + (end-refresh-sequence)))) (define/private (reset-size) (reset-visual #f) @@ -514,9 +516,7 @@ (set! need-refresh? #f) (if media (when (not (send media get-printing)) - (let-boxes ([x 0][y 0][w 0][h 0]) - (get-view x y w h) - (redraw x y w h #f))) + (redraw 'view 'view 'view 'view #f)) (let ([bg (get-canvas-background)]) (when bg (let ([adc (get-dc)]) @@ -607,44 +607,50 @@ (when (and media (not (send media get-printing))) (begin-refresh-sequence) - (when clear? - (let ([bg (get-canvas-background)]) - (when bg - (let ([adc (get-dc)]) - (let ([b (send adc get-brush)] - [p (send adc get-pen)]) - (send adc set-brush bg 'solid) - (send adc set-pen bg 1 'transparent) - (send adc draw-rectangle localx localy fw fh) - (send adc set-brush b) - (send adc set-pen p)))))) - (let ([x (box 0)] - [y (box 0)] - [w (box 0)] - [h (box 0)]) - (get-view x y w h) - (let ([x (unbox x)] - [y (unbox y)] - [w (unbox w)] - [h (unbox h)]) - (let ([right (+ x w)] - [bottom (+ y h)]) - (let ([x (max x localx)] - [y (max y localy)] - [right (min right (+ localx fw))] - [bottom (min bottom (+ localy fh))]) - (let ([w (max 0 (- right x))] - [h (max 0 (- bottom y))]) - (when (or (positive? w) - (positive? h)) - (using-admin - (when media - (send media refresh - x y w h - (if (or focuson? focusforcedon?) - 'show-caret - 'show-inactive-caret) - (get-canvas-background)))))))))) + (let-values ([(localx localy fw fh) + (if (eq? localx 'view) + (let-boxes ([x 0][y 0][w 0][h 0]) + (get-view x y w h) + (values x y w h)) + (values localx localy fw fh))]) + (when clear? + (let ([bg (get-canvas-background)]) + (when bg + (let ([adc (get-dc)]) + (let ([b (send adc get-brush)] + [p (send adc get-pen)]) + (send adc set-brush bg 'solid) + (send adc set-pen bg 1 'transparent) + (send adc draw-rectangle localx localy fw fh) + (send adc set-brush b) + (send adc set-pen p)))))) + (let ([x (box 0)] + [y (box 0)] + [w (box 0)] + [h (box 0)]) + (get-view x y w h) + (let ([x (unbox x)] + [y (unbox y)] + [w (unbox w)] + [h (unbox h)]) + (let ([right (+ x w)] + [bottom (+ y h)]) + (let ([x (max x localx)] + [y (max y localy)] + [right (min right (+ localx fw))] + [bottom (min bottom (+ localy fh))]) + (let ([w (max 0 (- right x))] + [h (max 0 (- bottom y))]) + (when (or (positive? w) + (positive? h)) + (using-admin + (when media + (send media refresh + x y w h + (if (or focuson? focusforcedon?) + 'show-caret + 'show-inactive-caret) + (get-canvas-background))))))))))) (end-refresh-sequence))) diff --git a/collects/mred/private/wxme/editor.rkt b/collects/mred/private/wxme/editor.rkt index a6c485ed22..74045ba70e 100644 --- a/collects/mred/private/wxme/editor.rkt +++ b/collects/mred/private/wxme/editor.rkt @@ -1380,9 +1380,12 @@ (semaphore-post seq-lock)) (def/public (wait-sequence-lock) - (when seq-lock + (cond + [seq-lock (sync seq-lock) - (semaphore-post seq-lock))) + (lambda () + (semaphore-post seq-lock))] + [else void])) (def/public (get-file [(make-or-false path-string?) path]) (editor-get-file "choose a file" (extract-parent) #f path)) diff --git a/collects/mred/private/wxme/pasteboard.rkt b/collects/mred/private/wxme/pasteboard.rkt index 69e6eae498..f9e74bf96a 100644 --- a/collects/mred/private/wxme/pasteboard.rkt +++ b/collects/mred/private/wxme/pasteboard.rkt @@ -1986,14 +1986,15 @@ ;; ---------------------------------------- (def/override (begin-edit-sequence [any? [undoable? #t]] [any? [interrupt-seqs? #t]]) - (wait-sequence-lock) + (define ready! (wait-sequence-lock)) (when (or (positive? s-noundomode) (not undoable?)) (set! s-noundomode (add1 s-noundomode))) (when (and (zero? sequence) (zero? write-locked)) (on-edit-sequence)) - (set! sequence (add1 sequence))) + (set! sequence (add1 sequence)) + (ready!)) (def/override (end-edit-sequence) (set! sequence (sub1 sequence)) diff --git a/collects/mred/private/wxme/text.rkt b/collects/mred/private/wxme/text.rkt index 73cbfdd414..6f40a1dff2 100644 --- a/collects/mred/private/wxme/text.rkt +++ b/collects/mred/private/wxme/text.rkt @@ -66,6 +66,8 @@ (define-struct clickback (start end f call-on-down? delta hilited? unhilite) #:mutable) +(define in-delayed-refresh (make-parameter #f)) + (defclass text% editor% (inherit-field s-admin s-offscreen @@ -291,6 +293,8 @@ (define refresh-r 0.0) ; can be 'display-end (define refresh-b 0.0) ; can be 'display-end + (define refresh-box-lock (make-semaphore 1)) ; protects refresh-{l,t,r,b} and refresh-box-unset? + (define last-draw-l 0.0) (define last-draw-t 0.0) (define last-draw-r 0.0) @@ -729,7 +733,7 @@ ;; ---------------------------------------- (def/override (begin-edit-sequence [any? [undoable? #t]] [any? [interrupt-seqs? #t]]) - (wait-sequence-lock) + (define ready! (wait-sequence-lock)) (when (and (zero? delay-refresh) (not interrupt-seqs?)) @@ -747,34 +751,38 @@ (set! need-x-copy? #t)) (set! delay-refresh 1) (on-edit-sequence)) - (set! delay-refresh (add1 delay-refresh)))) + (set! delay-refresh (add1 delay-refresh))) + + (ready!)) (def/override (end-edit-sequence) (if (zero? delay-refresh) (log-error "end-edit-sequence without begin-edit-sequence") - (begin - (set! delay-refresh (sub1 delay-refresh)) - (when (zero? delay-refresh) + (let ([new-delay-refresh (sub1 delay-refresh)]) + (when (zero? new-delay-refresh) (end-streaks null) (pop-streaks) - (redraw) + (parameterize ([in-delayed-refresh #t]) + (redraw)) (when ALLOW-X-STYLE-SELECTION? (set! need-x-copy? #f)) - (after-edit-sequence)) - (when (positive? s-noundomode) - (set! s-noundomode (sub1 s-noundomode))) - (when (and (zero? delay-refresh) - s-need-on-display-size?) - (set! s-need-on-display-size? #f) - (on-display-size))))) + (after-edit-sequence) + (when (positive? s-noundomode) + (set! s-noundomode (sub1 s-noundomode))) + (when s-need-on-display-size? + (set! s-need-on-display-size? #f) + (on-display-size))) + (set! delay-refresh new-delay-refresh)))) (def/override (refresh-delayed?) - (or (delay-refresh . > . 0) + (or (and (delay-refresh . > . 0) + (not (in-delayed-refresh))) (not s-admin) (send s-admin refresh-delayed?))) (def/override-final (in-edit-sequence?) - (delay-refresh . > . 0)) + (and (delay-refresh . > . 0) + (not (in-delayed-refresh)))) (def/override (locations-computed?) (not graphic-maybe-invalid?)) @@ -850,7 +858,8 @@ (when (or (= end start) (not (eq? editor-x-selection-allowed this)) (eq? 'local seltype)) - (when (or (zero? delay-refresh) need-x-copy?) + (when (or (not (in-edit-sequence?)) + need-x-copy?) (set! need-x-copy? #f) (copy-out-x-selection)))) @@ -931,7 +940,7 @@ (not flow-locked?) (let ([end (if (eq? end 'same) start (max start end))]) (cond - [(positive? delay-refresh) + [(in-edit-sequence?) (when s-admin (set! delayedscrollbox? #f) (set! delayedscroll start) @@ -1282,13 +1291,13 @@ (start . < . end) (begin (when ALLOW-X-STYLE-SELECTION? - (when (zero? delay-refresh) + (when (not (in-edit-sequence?)) (set! need-x-copy? #t))) (when (or isnip str snipsl) (begin-edit-sequence)) (delete start end scroll-ok?) (when ALLOW-X-STYLE-SELECTION? - (when (zero? delay-refresh) + (when (not (in-edit-sequence?)) (set! need-x-copy? #f))) #t))]) (when (or isnip str snipsl) @@ -1310,7 +1319,7 @@ insert-force-streak? (not s-modified?)) startpos endpos))) - (when (positive? delay-refresh) + (when (in-edit-sequence?) (set! delayed-streak? #t)) (let ([scroll? (= start startpos)]) @@ -1335,7 +1344,8 @@ (when (and scroll? scroll-ok?) (set! delay-refresh (add1 delay-refresh)) - (scroll-to-position/refresh startpos) + (parameterize ([in-delayed-refresh #f]) + (scroll-to-position/refresh startpos)) (set! delay-refresh (sub1 delay-refresh))) (set! changed? #t) @@ -1808,7 +1818,8 @@ (let ([end (min end len)]) (when ALLOW-X-STYLE-SELECTION? (when (and (start . <= . startpos) (end . >= . endpos)) - (when (or (zero? delay-refresh) need-x-copy?) + (when (or (not (in-edit-sequence?)) + need-x-copy?) (set! need-x-copy? #f) (copy-out-x-selection)))) @@ -1949,7 +1960,7 @@ (when with-undo? (add-undo-rec rec) - (when (positive? delay-refresh) + (when (in-edit-sequence?) (set! delayed-streak? #t))) (let ([dellen (- end start)]) @@ -1990,7 +2001,8 @@ (when (and scroll-ok? (= start startpos)) (set! delay-refresh (add1 delay-refresh)) - (scroll-to-position/refresh startpos) + (parameterize ([in-delayed-refresh #f]) + (scroll-to-position/refresh startpos)) (set! delay-refresh (sub1 delay-refresh))) (set! changed? #t) @@ -3780,7 +3792,7 @@ (add-undo-rec (make-object unmodify-record% delayed-streak?))) (when rec (add-undo-rec rec)) - (when (positive? delay-refresh) + (when (in-edit-sequence?) (set! delayed-streak? #t)) (check-merge-snips start) @@ -3902,7 +3914,7 @@ (define/private (do-scroll-to snip localx localy w h refresh? [bias 'none]) (cond [flow-locked? #f] - [(positive? delay-refresh) + [(in-edit-sequence?) (when s-admin (set! delayedscroll -1) (set! delayedscrollbox? #t) @@ -3962,7 +3974,8 @@ (set! changed? #t) (unless redraw-now? (set! delay-refresh (add1 delay-refresh))) - (refresh-by-line-demand) + (parameterize ([in-delayed-refresh #f]) + (refresh-by-line-demand)) (unless redraw-now? (set! delay-refresh (sub1 delay-refresh)))))) (def/override (recounted [snip% snip] [any? redraw-now?]) @@ -3990,30 +4003,35 @@ #t)))) (define/public (refresh-box L T w h) - (let ([B (if (eq? h 'display-end) h (+ T h))] - [R (if (eq? w 'display-end) w (+ L w))]) - (if refresh-box-unset? - (begin - (set! refresh-l L) - (set! refresh-r R) - (set! refresh-t T) - (set! refresh-b B) - (set! refresh-box-unset? #f)) - (begin - (when (L . < . refresh-l) - (set! refresh-l L)) - (unless (eq? refresh-r 'display-end) - (when (or (eq? R 'display-end) - (R . > . refresh-r)) - (set! refresh-r R))) - (when (T . < . refresh-t) - (set! refresh-t T)) - (unless (eq? refresh-b 'display-end) - (when (or (eq? B 'display-end) - (B . > . refresh-b)) - (set! refresh-b B))))) - - (set! draw-cached-in-bitmap? #f))) + ;; This method can be called while updating is locked out, + ;; possibly because another thread is in an edit sequence. + (call-with-semaphore + refresh-box-lock + (lambda () + (let ([B (if (eq? h 'display-end) h (+ T h))] + [R (if (eq? w 'display-end) w (+ L w))]) + (if refresh-box-unset? + (begin + (set! refresh-l L) + (set! refresh-r R) + (set! refresh-t T) + (set! refresh-b B) + (set! refresh-box-unset? #f)) + (begin + (when (L . < . refresh-l) + (set! refresh-l L)) + (unless (eq? refresh-r 'display-end) + (when (or (eq? R 'display-end) + (R . > . refresh-r)) + (set! refresh-r R))) + (when (T . < . refresh-t) + (set! refresh-t T)) + (unless (eq? refresh-b 'display-end) + (when (or (eq? B 'display-end) + (B . > . refresh-b)) + (set! refresh-b B))))) + + (set! draw-cached-in-bitmap? #f))))) (def/override (needs-update [snip% snip] [real? localx] [real? localy] @@ -4024,7 +4042,7 @@ (set-box! ok? (get-snip-location snip x y)) (when ok? (refresh-box (+ x localx) (+ y localy) w h) - (when (zero? delay-refresh) + (unless (in-edit-sequence?) (redraw))))) (def/override (invalidate-bitmap-cache [real? [x 0.0]] @@ -4035,7 +4053,7 @@ [h (if (eq? h 'end) (- (+ total-height padding-t padding-b) y) h)]) (refresh-box x y w h) - (when (zero? delay-refresh) + (unless (in-edit-sequence?) (redraw)))) (def/public (hide-caret [any? hide?]) @@ -4522,7 +4540,7 @@ (define/override (setting-admin admin) (void)) (define/override (init-new-admin) - (when (and (zero? delay-refresh) + (when (and (not (in-edit-sequence?)) (or (not s-admin) (not (send s-admin refresh-delayed?)))) (redraw))) @@ -4897,20 +4915,24 @@ [left x] [right (+ x w)]) (let-values ([(left right top bottom) - (if refresh-all? - (values left right top bottom) - (values - (max refresh-l left) - (if (eq? refresh-r 'display-end) - right - (min refresh-r right)) - (max refresh-t top) - (if (eq? refresh-b 'display-end) - bottom - (min refresh-b bottom))))]) - (set! refresh-unset? #t) - (set! refresh-box-unset? #t) - (set! refresh-all? #f) + (call-with-semaphore + refresh-box-lock + (lambda () + (begin0 + (if refresh-all? + (values left right top bottom) + (values + (max refresh-l left) + (if (eq? refresh-r 'display-end) + right + (min refresh-r right)) + (max refresh-t top) + (if (eq? refresh-b 'display-end) + bottom + (min refresh-b bottom)))) + (set! refresh-unset? #t) + (set! refresh-box-unset? #t) + (set! refresh-all? #f))))]) (let ([height (- bottom top)] [width (- right left)]) (when (and (width . > . 0) (height . > . 0)) @@ -4958,42 +4980,45 @@ ;; both; if neither is specified, we have to assume that everything ;; needs to be refreshed (let-values ([(left top right bottom needs-update?) - (if (and (not refresh-all?) - (or (not refresh-unset?) (not refresh-box-unset?))) - (if (not refresh-unset?) - (let ([top (if (refresh-start . > . -1) - (let-boxes ([fy 0.0]) - (position-location refresh-start #f fy #t #t #t) - (max top fy)) - top)] - [bottom (if (refresh-end . > . -1) - (let-boxes ([fy 0.0]) - (position-location refresh-end #f fy #f #f #t) - (min bottom fy)) - bottom)]) - (values left (if (not refresh-box-unset?) - (min refresh-t top) - top) - right (if (not refresh-box-unset?) - (if (eq? refresh-b 'display-end) - bottom - (max bottom refresh-b)) - bottom) - #t)) - (values (max refresh-l left) - (max top refresh-t) - (if (eq? refresh-r 'display-end) - right - (min right refresh-r)) - (if (eq? refresh-b 'display-end) - bottom - (min bottom refresh-b)) - #t)) - (values left top right bottom refresh-all?))]) - - (set! refresh-unset? #t) - (set! refresh-box-unset? #t) - (set! refresh-all? #f) + (call-with-semaphore + refresh-box-lock + (lambda () + (begin0 + (if (and (not refresh-all?) + (or (not refresh-unset?) (not refresh-box-unset?))) + (if (not refresh-unset?) + (let ([top (if (refresh-start . > . -1) + (let-boxes ([fy 0.0]) + (position-location refresh-start #f fy #t #t #t) + (max top fy)) + top)] + [bottom (if (refresh-end . > . -1) + (let-boxes ([fy 0.0]) + (position-location refresh-end #f fy #f #f #t) + (min bottom fy)) + bottom)]) + (values left (if (not refresh-box-unset?) + (min refresh-t top) + top) + right (if (not refresh-box-unset?) + (if (eq? refresh-b 'display-end) + bottom + (max bottom refresh-b)) + bottom) + #t)) + (values (max refresh-l left) + (max top refresh-t) + (if (eq? refresh-r 'display-end) + right + (min right refresh-r)) + (if (eq? refresh-b 'display-end) + bottom + (min bottom refresh-b)) + #t)) + (values left top right bottom refresh-all?)) + (set! refresh-unset? #t) + (set! refresh-box-unset? #t) + (set! refresh-all? #f))))]) (let ([height (- bottom top)] [width (- right left)]) @@ -5017,7 +5042,7 @@ (define/private (too-busy-to-refresh?) (or graphic-maybe-invalid? flow-locked? - (positive? delay-refresh))) + (in-edit-sequence?))) ;; called by the administrator to trigger a redraw (def/override (refresh [real? left] [real? top] [nonnegative-real? width] [nonnegative-real? height] @@ -5030,7 +5055,10 @@ ;; (probably in the middle of a begin-/end-edit-sequnce); ;; add the given region to our own invalid-region tracking, and ;; we'll get back to it when we're done with whatever - (refresh-box left top width height)] + (refresh-box left top width height) + ;; Double-check that we didn't finish being busy while + ;; setting the box: + (unless (too-busy-to-refresh?) (redraw))] [(not s-admin) (void)] [else @@ -5483,12 +5511,12 @@ (continue-refresh)) (define/private (continue-refresh) - (if (and (zero? delay-refresh) + (if (and (not (in-edit-sequence?)) (not (super is-printing?)) (or (not s-admin) (not (send s-admin refresh-delayed?)))) (redraw) (begin - (when (and (zero? delay-refresh) + (when (and (not (in-edit-sequence?)) (or (= delayedscroll -1) delayedscrollbox?)) (if (and (not (super is-printing?)) s-admin) diff --git a/collects/scribblings/gui/editor-overview.scrbl b/collects/scribblings/gui/editor-overview.scrbl index 644645480d..50516d8dee 100644 --- a/collects/scribblings/gui/editor-overview.scrbl +++ b/collects/scribblings/gui/editor-overview.scrbl @@ -719,8 +719,8 @@ Methods that report @techlink{location}-independent information about an An editor is not tied to any particular thread or eventspace, except to the degree that it is displayed in a canvas (which has an - eventspace). Concurrent access of an editor is always safe, in the - sense that the editor will not become corrupted. However, because + eventspace). Concurrent access of an editor is always safe in the + weak sense that the editor will not become corrupted. However, because editor access can trigger locks, concurrent access can produce contract failures or unexpected results.