suzanne.soy/racket
1
0
Fork 0
Code Issues Pull Requests Actions Packages Projects Releases Wiki Activity

fix ffi/unsafe/try-atomic interaction with exns and prompt tags

Browse Source
This commit is contained in:
Matthew Flatt 2010-08-14 21:15:56 -06:00
parent 8ece97219a
commit 9c0c42f24a
2 changed files with 57 additions and 31 deletions
Show Stats Download Patch File Download Diff File Expand all files Collapse all files

68
collects/ffi/unsafe/try-atomic.rkt
View File

@ -25,16 +25,18 @@
(let ([b (box null)]) (let ([b (box null)])
(begin0 (begin0
(parameterize ([freezer-box b]) (parameterize ([freezer-box b])
;; In atomic mode: ;; In atomic mode (but not using call-as-atomic, because we
(call-as-atomic thunk)) ;; don't want to change the exception handler, etc.)
(start-atomic)
(begin0
(thunk)
(end-atomic)))
;; Retries out of atomic mode: ;; Retries out of atomic mode:
(let ([l (unbox b)]) (let ([l (unbox b)])
(for ([k (in-list (reverse l))]) (for ([k (in-list (reverse l))])
(call-with-continuation-prompt ; to catch aborts (call-with-continuation-prompt
(lambda () k
(call-with-continuation-prompt freeze-tag))))))
k
freeze-tag))))))))
(define (can-try-atomic?) (and (freezer-box) #t)) (define (can-try-atomic?) (and (freezer-box) #t))
@ -67,23 +69,39 @@
freeze-tag freeze-tag
(lambda () default))) (lambda () default)))
freeze-tag) freeze-tag)
(void)))]) (void)))]
[done? #f])
(hash-set! saved-ptrs handler #t) (hash-set! saved-ptrs handler #t)
(begin0 (parameterize ([freezer-box #f])
(parameterize ([freezer-box #f]) (let/ec esc ;; esc + dynamic-wind prevents escape via alternate prompt tags
(dynamic-wind (dynamic-wind
void void
(lambda () (lambda ()
(call-with-continuation-prompt ; for composable continuation (call-with-continuation-prompt ; for composable continuation
(lambda () (lambda ()
(call-with-continuation-prompt ; to catch aborts (call-with-continuation-prompt ; to catch aborts
(lambda () (lambda ()
(when (scheme_set_on_atomic_timeout handler) (when (scheme_set_on_atomic_timeout handler)
(error 'try-atomic "internal error: nested handlers?!")) (error 'try-atomic "internal error: nested handlers?!"))
(set! ready? #t) (set! ready? #t)
(thunk)))) (begin0
freeze-tag)) (thunk)
(lambda () (set! done? #t)))
(scheme_restore_on_atomic_timeout #f)))) (default-continuation-prompt-tag)
(hash-remove! saved-ptrs handler)))]))) (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))))))))])))

20
collects/scribblings/foreign/try-atomic.scrbl
View File

@ -12,11 +12,11 @@ or if some external event causes the attempt to be abandoned.}
@defproc[(call-as-nonatomic-retry-point [thunk (-> any)]) any]{ @defproc[(call-as-nonatomic-retry-point [thunk (-> any)]) any]{
Calls @racket[thunk] in atomic mode (see @racket[call-as-atomic]) Calls @racket[thunk] in atomic mode (see @racket[start-atomic] and
while allowing @racket[thunk] to use @racket[try-atomic]. Any @racket[end-atomic]) while allowing @racket[thunk] to use
incomplete computations started with @racket[try-atomic] are run @racket[try-atomic]. Any incomplete computations started with
non-atomically after @racket[thunk] returns. The result of @racket[try-atomic] are run non-atomically after @racket[thunk]
@racket[thunk] is used as the result of returns. The result of @racket[thunk] is used as the result of
@racket[call-as-nonatomic-retry-point].} @racket[call-as-nonatomic-retry-point].}
@ -46,4 +46,12 @@ returned.
The @racket[give-up-proc] callback is polled only at points where the The @racket[give-up-proc] callback is polled only at points where the
level of atomic-mode nesting (see @racket[start-atomic], level of atomic-mode nesting (see @racket[start-atomic],
@racket[start-breakable-atomic], and @racket[call-as-atomic]) is the @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].}