concurrency repairs

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

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)

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?
+      (atomically
        (when close-sema
          (semaphore-post close-sema)
-        (set! close-sema #f)))
+         (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 (atomically
-          (let ([s (make-semaphore)])
+                  (let ([s (or close-sema (make-semaphore))])
-            (set! close-sema s)
+                    (unless close-sema (set! close-sema s))
+                    (semaphore-peek-evt s)))])
           (super show on?)
-            (yield s)))
+          (yield s)
+          (void))
         (super show on?))))

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
+      (as-entry thunk))
-       lock
-       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)
+                             (atomically
                               (hash-set! size-cache 
                                          (vector id sz ch)
-                                        (vector w h d a)))))])
+                                         (vector w h d a))))))])
                 (begin0
                  (for/fold ([w 0.0][h 0.0][d 0.0][a 0.0])
                      ([ch (in-string s)])

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 "<No subject>")