From 3a99e9e82c30ef0a2693b444441c1fd3d87c0e34 Mon Sep 17 00:00:00 2001 From: Matthew Flatt Date: Mon, 6 Sep 2010 09:17:50 -0600 Subject: [PATCH] concurrency repairs --- collects/mred/private/moredialogs.rkt | 2 +- collects/mred/private/wx/cocoa/dialog.rkt | 2 +- collects/mred/private/wx/common/queue.rkt | 2 +- collects/mred/private/wx/gtk/dialog.rkt | 20 ++++++++++++-------- collects/mred/private/wxme/text.rkt | 2 +- collects/mred/private/wxtextfield.rkt | 2 +- collects/racket/draw/dc.rkt | 22 ++++++++++++++-------- collects/sirmail/readr.rkt | 2 ++ 8 files changed, 33 insertions(+), 21 deletions(-) diff --git a/collects/mred/private/moredialogs.rkt b/collects/mred/private/moredialogs.rkt index 3f9b1fc570..8f275043c0 100644 --- a/collects/mred/private/moredialogs.rkt +++ b/collects/mred/private/moredialogs.rkt @@ -208,7 +208,7 @@ ((done #t) #f #f))) init-val (list* 'single 'vertical-label style))] [p (make-object horizontal-pane% f)]) - (send p set-alignment 'right 'center) + (send p set-alignment 'right 'center) (send f stretchable-height #f) (ok-cancel (lambda () (make-object button% "OK" p (done #t) '(border))) diff --git a/collects/mred/private/wx/cocoa/dialog.rkt b/collects/mred/private/wx/cocoa/dialog.rkt index 2e69662900..a07fc38350 100644 --- a/collects/mred/private/wx/cocoa/dialog.rkt +++ b/collects/mred/private/wx/cocoa/dialog.rkt @@ -28,7 +28,7 @@ (let ([s (atomically (let ([s (or close-sema (make-semaphore))]) (unless close-sema (set! close-sema s)) - s))]) + (semaphore-peek-evt s)))]) (super show on?) (yield s) (void)) diff --git a/collects/mred/private/wx/common/queue.rkt b/collects/mred/private/wx/common/queue.rkt index 2f52f60ac9..f76205bf66 100644 --- a/collects/mred/private/wx/common/queue.rkt +++ b/collects/mred/private/wx/common/queue.rkt @@ -355,7 +355,7 @@ (when v (handle-event v)) (yield evt))))] [else - (sync e)]))])) + (sync evt)]))])) (define event-dispatch-handler (make-parameter void)) (define (main-eventspace? e) diff --git a/collects/mred/private/wx/gtk/dialog.rkt b/collects/mred/private/wx/gtk/dialog.rkt index 3de209a787..6c063d65c1 100644 --- a/collects/mred/private/wx/gtk/dialog.rkt +++ b/collects/mred/private/wx/gtk/dialog.rkt @@ -3,6 +3,7 @@ ffi/unsafe "../../syntax.rkt" "../common/queue.rkt" + "../../lock.rkt" "types.rkt" "utils.rkt" "frame.rkt") @@ -51,9 +52,10 @@ (unless on? (set! dialog-level 0)) (unless on? - (when close-sema - (semaphore-post close-sema) - (set! close-sema #f))) + (atomically + (when close-sema + (semaphore-post close-sema) + (set! close-sema #f)))) (super direct-show on?)) (define/override (center dir wrt) @@ -66,9 +68,11 @@ (define/override (show on?) (if on? - (unless close-sema - (let ([s (make-semaphore)]) - (set! close-sema s) - (super show on?) - (yield s))) + (let ([s (atomically + (let ([s (or close-sema (make-semaphore))]) + (unless close-sema (set! close-sema s)) + (semaphore-peek-evt s)))]) + (super show on?) + (yield s) + (void)) (super show on?)))) diff --git a/collects/mred/private/wxme/text.rkt b/collects/mred/private/wxme/text.rkt index e01fa2b435..42f2a30008 100644 --- a/collects/mred/private/wxme/text.rkt +++ b/collects/mred/private/wxme/text.rkt @@ -4759,7 +4759,7 @@ (when (and resized? s-admin) (send s-admin resized #f)) - + (on-reflow))))))))))) (def/public (on-reflow) (void)) diff --git a/collects/mred/private/wxtextfield.rkt b/collects/mred/private/wxtextfield.rkt index b12ee9a82b..f958b5a741 100644 --- a/collects/mred/private/wxtextfield.rkt +++ b/collects/mred/private/wxtextfield.rkt @@ -241,7 +241,7 @@ ;; Exact (set! dy (inexact->exact dy)))) - + (when value (set-value value) (unless (string=? value "") diff --git a/collects/racket/draw/dc.rkt b/collects/racket/draw/dc.rkt index 3584f23af4..b6dd6431a4 100644 --- a/collects/racket/draw/dc.rkt +++ b/collects/racket/draw/dc.rkt @@ -1,6 +1,7 @@ #lang scheme/base (require mred/private/syntax + mred/private/lock scheme/math scheme/class "hold.ss" @@ -143,11 +144,15 @@ (define default-dc-backend% (class* object% (dc-backend<%>) - (define lock (make-semaphore 1)) + ;; Using the global lock here is troublesome, becase + ;; operations involving paths, regions, and text can + ;; take arbitrarily long. Parts of the editor infrastructure, + ;; meanwhile, assume that the global lock can be taken + ;; around actions that use the editor-canvas dc. If we + ;; have a separate per-dc lock, we can hit deadlock due to + ;; lock order. (define/public (call-with-cr-lock thunk) - (call-with-semaphore - lock - thunk)) + (as-entry thunk)) (define/public (get-cr) #f) (define/public (release-cr cr) (void)) @@ -964,7 +969,7 @@ (if (= i (string-length s)) (values w h d a) (let ([ch (string-ref s i)]) - (let ([v (hash-ref size-cache (vector id sz ch) #f)]) + (let ([v (atomically (hash-ref size-cache (vector id sz ch) #f))]) (if v (loop (add1 i) (+ w (vector-ref v 0)) @@ -1073,9 +1078,10 @@ (let ([id (send font get-font-id)] [sz (send font get-point-size)]) (lambda (ch w h d a) - (hash-set! size-cache - (vector id sz ch) - (vector w h d a)))))]) + (atomically + (hash-set! size-cache + (vector id sz ch) + (vector w h d a))))))]) (begin0 (for/fold ([w 0.0][h 0.0][d 0.0][a 0.0]) ([ch (in-string s)]) diff --git a/collects/sirmail/readr.rkt b/collects/sirmail/readr.rkt index 9686a8e63a..ecabc7f9ec 100644 --- a/collects/sirmail/readr.rkt +++ b/collects/sirmail/readr.rkt @@ -41,6 +41,8 @@ (require openssl/mzssl) + (require (only racket/base log-error)) + ;; Constant for messages without a title: (define no-subject-string "")