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

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]{
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].}