From 9c0c42f24a5e3760a758551f3eb7838da425bc9d Mon Sep 17 00:00:00 2001
From: Matthew Flatt <mflatt@racket-lang.org>
Date: Sat, 14 Aug 2010 21:15:56 -0600
Subject: [PATCH] fix ffi/unsafe/try-atomic interaction with exns and prompt
 tags

---
 collects/ffi/unsafe/try-atomic.rkt            | 68 ++++++++++++-------
 collects/scribblings/foreign/try-atomic.scrbl | 20 ++++--
 2 files changed, 57 insertions(+), 31 deletions(-)

diff --git a/collects/ffi/unsafe/try-atomic.rkt b/collects/ffi/unsafe/try-atomic.rkt
index 3b6f1984be..b9e9a7dd88 100644
--- a/collects/ffi/unsafe/try-atomic.rkt
+++ b/collects/ffi/unsafe/try-atomic.rkt
@@ -25,16 +25,18 @@
   (let ([b (box null)])
     (begin0
      (parameterize ([freezer-box b])
-       ;; In atomic mode:
-       (call-as-atomic thunk))
+       ;; In atomic mode (but not using call-as-atomic, because we
+       ;; don't want to change the exception handler, etc.)
+       (start-atomic)
+       (begin0 
+        (thunk)
+        (end-atomic)))
      ;; Retries out of atomic mode:
      (let ([l (unbox b)])
        (for ([k (in-list (reverse l))])
-         (call-with-continuation-prompt ; to catch aborts
-          (lambda ()
-            (call-with-continuation-prompt
-             k
-             freeze-tag))))))))
+         (call-with-continuation-prompt
+          k
+          freeze-tag))))))
 
 (define (can-try-atomic?) (and (freezer-box) #t))
 
@@ -67,23 +69,39 @@
                               freeze-tag
                               (lambda () default)))
                            freeze-tag)
-                          (void)))])
+                          (void)))]
+             [done? #f])
         (hash-set! saved-ptrs handler #t)
-        (begin0
-         (parameterize ([freezer-box #f])
-           (dynamic-wind
-            void
-            (lambda ()
-              (call-with-continuation-prompt ; for composable continuation
-               (lambda ()
-                 (call-with-continuation-prompt ; to catch aborts
-                  (lambda ()
-                    (when (scheme_set_on_atomic_timeout handler)
-                      (error 'try-atomic "internal error: nested handlers?!"))
-                    (set! ready? #t)
-                    (thunk))))
-               freeze-tag))
-            (lambda ()
-              (scheme_restore_on_atomic_timeout #f))))
-         (hash-remove! saved-ptrs handler)))])))
+        (parameterize ([freezer-box #f])
+          (let/ec esc ;; esc + dynamic-wind prevents escape via alternate prompt tags
+            (dynamic-wind
+             void
+             (lambda ()
+               (call-with-continuation-prompt ; for composable continuation
+                (lambda ()
+                  (call-with-continuation-prompt ; to catch aborts
+                   (lambda ()
+                     (when (scheme_set_on_atomic_timeout handler)
+                       (error 'try-atomic "internal error: nested handlers?!"))
+                     (set! ready? #t)
+                     (begin0
+                      (thunk)
+                      (set! done? #t)))
+                   (default-continuation-prompt-tag)
+                   (lambda args
+                     (set! done? #t)
+                     ;; re-abort later...
+                     (set-box! b (cons (lambda ()
+                                         (apply abort-current-continuation 
+                                                (default-continuation-prompt-tag)
+                                                args))
+                                       (unbox b))))))
+                freeze-tag
+                (lambda (thunk)
+                  (set! done? #t)
+                  (thunk))))
+             (lambda ()
+               (hash-remove! saved-ptrs handler)
+               (scheme_restore_on_atomic_timeout #f)
+               (unless done? (esc (void))))))))])))
 
diff --git a/collects/scribblings/foreign/try-atomic.scrbl b/collects/scribblings/foreign/try-atomic.scrbl
index b8ef8404b5..e5273ecb85 100644
--- a/collects/scribblings/foreign/try-atomic.scrbl
+++ b/collects/scribblings/foreign/try-atomic.scrbl
@@ -12,11 +12,11 @@ or if some external event causes the attempt to be abandoned.}
 
 @defproc[(call-as-nonatomic-retry-point [thunk (-> any)]) any]{
 
-Calls @racket[thunk] in atomic mode (see @racket[call-as-atomic])
-while allowing @racket[thunk] to use @racket[try-atomic]. Any
-incomplete computations started with @racket[try-atomic] are run
-non-atomically after @racket[thunk] returns. The result of
-@racket[thunk] is used as the result of
+Calls @racket[thunk] in atomic mode (see @racket[start-atomic] and
+@racket[end-atomic]) while allowing @racket[thunk] to use
+@racket[try-atomic]. Any incomplete computations started with
+@racket[try-atomic] are run non-atomically after @racket[thunk]
+returns. The result of @racket[thunk] is used as the result of
 @racket[call-as-nonatomic-retry-point].}
 
 
@@ -46,4 +46,12 @@ returned.
 The @racket[give-up-proc] callback is polled only at points where the
 level of atomic-mode nesting (see @racket[start-atomic],
 @racket[start-breakable-atomic], and @racket[call-as-atomic]) is the
-same as at the point of calling @racket[try-atomic].}
+same as at the point of calling @racket[try-atomic].
+
+If @racket[thunk] aborts the current continuation using
+@racket[(default-continuation-prompt-tag)], the abort is suspended the
+resumed by the enclosing
+@racket[call-as-nonatomic-retry-point]. Escapes to the context of the
+call to @racket[thunk] using any other prompt tag or continuation are
+blocked (using @racket[dynamic-wind]) and simply return
+@racket[(void)] from @racket[thunk].}