diff --git a/collects/ffi/unsafe/atomic.rkt b/collects/ffi/unsafe/atomic.rkt index 7dc011dbcc..0fa3b7f7c9 100644 --- a/collects/ffi/unsafe/atomic.rkt +++ b/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)) diff --git a/collects/ffi/unsafe/try-atomic.rkt b/collects/ffi/unsafe/try-atomic.rkt index 2cae07b82a..3b6f1984be 100644 --- a/collects/ffi/unsafe/try-atomic.rkt +++ b/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]) - ;; In atomic mode: - (call-as-atomic thunk)) - ;; 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))))) - (void))) + (begin0 + (parameterize ([freezer-box b]) + ;; In atomic mode: + (call-as-atomic thunk)) + ;; 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)))))))) (define (can-try-atomic?) (and (freezer-box) #t)) @@ -56,14 +56,13 @@ default] [else ;; try to do some work: - (let* ([prev #f] - [ready? #f] + (let* ([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 prev (log-error "uh oh")) + (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 prev)))) + (scheme_restore_on_atomic_timeout #f)))) (hash-remove! saved-ptrs handler)))]))) diff --git a/collects/scribblings/foreign/derived.scrbl b/collects/scribblings/foreign/derived.scrbl index 83b5d2539f..6525cec778 100644 --- a/collects/scribblings/foreign/derived.scrbl +++ b/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"] diff --git a/collects/scribblings/foreign/try-atomic.scrbl b/collects/scribblings/foreign/try-atomic.scrbl new file mode 100644 index 0000000000..b8ef8404b5 --- /dev/null +++ b/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].}