From ea789fc48107be6e0172c42160be8951c8dc8703 Mon Sep 17 00:00:00 2001 From: Matthew Flatt Date: Tue, 14 Dec 2010 11:48:17 -0700 Subject: [PATCH] further avoid nested try-atomics to avoid the possibility of deadlock when, for example, `yield' is called during a try-atomic callback --- collects/ffi/unsafe/try-atomic.rkt | 8 +++++++- 1 file changed, 7 insertions(+), 1 deletion(-) diff --git a/collects/ffi/unsafe/try-atomic.rkt b/collects/ffi/unsafe/try-atomic.rkt index a38427a6d3..254dbcf534 100644 --- a/collects/ffi/unsafe/try-atomic.rkt +++ b/collects/ffi/unsafe/try-atomic.rkt @@ -17,13 +17,18 @@ (define freezer-box (make-parameter #f)) (define freeze-tag (make-continuation-prompt-tag)) +(define force-timeout (make-parameter #f)) ;; Runs `thunk' atomically, but cooperates with ;; `try-atomic' to continue a frozen ;; computation in non-atomic mode. (define (call-as-nonatomic-retry-point thunk) + (when (freezer-box) + ;; Try to avoid a nested try-atomic: + (parameterize ([force-timeout #t]) + (sleep))) (let ([b (box (if (freezer-box) - ;; Already in try-atomic; we'll have to complete + ;; Still in try-atomic; we'll have to complete ;; everything atomically, and starting with ;; a non-empty list means that we won't bother ;; capturing continuations. @@ -69,6 +74,7 @@ [handler (lambda (must-give-up) (when (and ready? (or (positive? must-give-up) + (force-timeout) (should-give-up?))) (scheme_call_with_composable_no_dws (lambda (proc)