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

fix problem with nested try-atomic regions

Browse Source
This commit is contained in:
Matthew Flatt 2010-12-14 11:31:57 -07:00
parent 8368dcaca1
commit 1d0adfd8f2
1 changed files with 13 additions and 5 deletions
Show Stats Download Patch File Download Diff File Expand all files Collapse all files

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

@ -22,7 +22,14 @@
;; `try-atomic' to continue a frozen ;; `try-atomic' to continue a frozen
;; computation in non-atomic mode. ;; computation in non-atomic mode.
(define (call-as-nonatomic-retry-point thunk) (define (call-as-nonatomic-retry-point thunk)
(let ([b (box null)]) (let ([b (box (if (freezer-box)
;; Already 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.
(list void)
;; Start with an empty list of things to finish:
null))])
(begin0 (begin0
(parameterize ([freezer-box b]) (parameterize ([freezer-box b])
;; In atomic mode (but not using call-as-atomic, because we ;; In atomic mode (but not using call-as-atomic, because we
@ -72,10 +79,9 @@
(lambda () default))) (lambda () default)))
freeze-tag) freeze-tag)
(void)))] (void)))]
[prev #f]
[done? #f]) [done? #f])
(hash-set! saved-ptrs handler #t) (hash-set! saved-ptrs handler #t)
(parameterize ([freezer-box #f]) (begin
(let/ec esc ;; esc + dynamic-wind prevents escape via alternate prompt tags (let/ec esc ;; esc + dynamic-wind prevents escape via alternate prompt tags
(dynamic-wind (dynamic-wind
void void
@ -84,7 +90,9 @@
(lambda () (lambda ()
(call-with-continuation-prompt ; to catch aborts (call-with-continuation-prompt ; to catch aborts
(lambda () (lambda ()
(set! prev (scheme_set_on_atomic_timeout handler)) (when (scheme_set_on_atomic_timeout handler)
(log-error "no")
(error 'try-atomic "nested atomic timeout"))
(set! ready? #t) (set! ready? #t)
(begin0 (begin0
(thunk) (thunk)
@ -104,6 +112,6 @@
(thunk)))) (thunk))))
(lambda () (lambda ()
(hash-remove! saved-ptrs handler) (hash-remove! saved-ptrs handler)
(scheme_restore_on_atomic_timeout prev) (scheme_restore_on_atomic_timeout #f)
(unless done? (esc (void))))))))]))) (unless done? (esc (void))))))))])))