support for speculatively atomic calls in ffi/unsafe/try-atomic

collects/ffi/unsafe/atomic.rkt

@@ -5,6 +5,8 @@
 
 (provide (protect-out start-atomic
                       end-atomic
+                      start-breakable-atomic
+                      end-breakable-atomic
                       call-as-atomic
                       call-as-nonatomic))
 

collects/ffi/unsafe/try-atomic.rkt

@@ -23,18 +23,18 @@
 ;; computation in non-atomic mode.
 (define (call-as-nonatomic-retry-point thunk)
   (let ([b (box null)])
-    (parameterize ([freezer-box b])
+    (begin0
-      ;; In atomic mode:
+     (parameterize ([freezer-box b])
-      (call-as-atomic thunk))
+       ;; In atomic mode:
-    ;; Out of atomic mode:
+       (call-as-atomic thunk))
-    (let ([l (unbox b)])
+     ;; Retries out of atomic mode:
-      (for ([k (in-list (reverse l))])
+     (let ([l (unbox b)])
-        (call-with-continuation-prompt ; to catch aborts
+       (for ([k (in-list (reverse l))])
-         (lambda ()
+         (call-with-continuation-prompt ; to catch aborts
-           (call-with-continuation-prompt
+          (lambda ()
-            k
+            (call-with-continuation-prompt
-            freeze-tag)))))
+             k
-    (void)))
+             freeze-tag))))))))
 
 (define (can-try-atomic?) (and (freezer-box) #t))
 
@@ -56,14 +56,13 @@
       default]
      [else
       ;; try to do some work:
-      (let* ([prev #f]
+      (let* ([ready? #f]
-             [ready? #f]
              [handler (lambda ()
                         (when (and ready? (should-give-up?))
                           (scheme_call_with_composable_no_dws
                            (lambda (proc)
                              (set-box! b (cons proc (unbox b)))
-                             (scheme_restore_on_atomic_timeout prev)
+                             (scheme_restore_on_atomic_timeout #f)
                              (scheme_abort_continuation_no_dws
                               freeze-tag
                               (lambda () default)))
@@ -79,12 +78,12 @@
                (lambda ()
                  (call-with-continuation-prompt ; to catch aborts
                   (lambda ()
-                    (set! prev (scheme_set_on_atomic_timeout handler))
+                    (when (scheme_set_on_atomic_timeout handler)
-                    (when prev (log-error "uh oh"))
+                      (error 'try-atomic "internal error: nested handlers?!"))
                     (set! ready? #t)
                     (thunk))))
                freeze-tag))
             (lambda ()
-              (scheme_restore_on_atomic_timeout prev))))
+              (scheme_restore_on_atomic_timeout #f))))
          (hash-remove! saved-ptrs handler)))])))
 

collects/scribblings/foreign/derived.scrbl

@@ -11,4 +11,5 @@
 @include-section["define.scrbl"]
 @include-section["alloc.scrbl"]
 @include-section["atomic.scrbl"]
+@include-section["try-atomic.scrbl"]
 @include-section["objc.scrbl"]

collects/scribblings/foreign/try-atomic.scrbl

@@ -0,0 +1,49 @@
+#lang scribble/doc
+@(require "utils.ss"
+          (for-label ffi/unsafe/try-atomic
+                     ffi/unsafe/atomic))
+
+@title{Speculatively Atomic Execution}
+
+@defmodule[ffi/unsafe/try-atomic]{The
+@racketmodname[ffi/unsafe/try-atomic] supports atomic execution that
+can be suspended and resumed in non-atomic mode if it takes too long
+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
+@racket[call-as-nonatomic-retry-point].}
+
+
+@defproc[(try-atomic
+          [thunk (-> any)]
+          [default-val any/c]
+          [#:should-give-up? give-up-proc (-> any/c) _run-200-milliseconds]
+          [#:keep-in-order? keep-in-order? any/c #t])
+         any]{
+
+Within the dynamic extent of a @racket[call-as-nonatomic-retry-point]
+call, attempts to run @racket[thunk] in the existing atomic mode. The
+@racket[give-up-proc] procedure is called periodically to determine
+whether atomic mode should be abandoned; the default
+@racket[give-up-proc] returns true after 200 milliseconds. If atomic
+mode is abandoned, the computation is suspended, and
+@racket[default-val] is returned, instead. The computation is resumed
+later by the enclosing @racket[call-as-nonatomic-retry-point] call.
+
+If @racket[keep-in-order?] is true, then if @racket[try-atomic] is
+called after an earlier computation was suspended for the same
+@racket[call-as-nonatomic-retry-point] call, then
+@racket[thunk] is immediately enqueued for completion by
+@racket[call-as-nonatomic-retry-point] and @racket[default-val] is
+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].}