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

ffi/unsafe/try-atomic: don't use callback during nested atomic

Browse Source 
When a `try-atomic` thunk starts a more nested atomic region, don't
trigger the callback until the more nested atomic region ends.
This commit is contained in:
Matthew Flatt 2021-04-15 08:53:13 -06:00
parent 237d627583
commit 6d30ff78c1
4 changed files with 59 additions and 8 deletions
Show Stats Download Patch File Download Diff File Expand all files Collapse all files

47
pkgs/racket-test-core/tests/racket/try-atomic.rkt
View File

@ -1,5 +1,6 @@
#lang racket/base
(require ffi/unsafe/try-atomic)
(require ffi/unsafe/try-atomic
ffi/unsafe/atomic)
(define ch (make-channel))
(define done? #f)
@ -35,3 +36,47 @@
'barrier)
(check done? #t)
(let ()
(define finished? #f)
(define oops? #f)
(call-as-nonatomic-retry-point
(lambda ()
(try-atomic
(lambda ()
(start-atomic)
(define done (+ (current-milliseconds) 300))
(let loop ()
(unless ((current-milliseconds) . >= . done)
(loop)))
(set! finished? #t)
(end-atomic))
(void))
(unless finished?
(set! oops? #t))))
(when oops?
(error "nested atomic mode interrupted within try-atomic")))
(let ()
(define finished? #f)
(define stop? #f)
(define oops? #f)
(call-as-nonatomic-retry-point
(lambda ()
(try-atomic
(lambda ()
(define done (+ (current-milliseconds) 10000))
(let loop ()
(unless (or stop? ((current-milliseconds) . >= . done))
(loop)))
(set! finished? #t))
(void))
(set! stop? #t)
(when finished?
(set! oops? #t))))
(when oops?
(error "try-atomic never interrupted")))

2
racket/collects/ffi/unsafe/try-atomic.rkt
View File

@ -103,7 +103,7 @@
(lambda ()
(call-with-continuation-prompt ; to catch aborts
(lambda ()
(when (unsafe-set-on-atomic-timeout! handler)
(when (unsafe-set-on-atomic-timeout! handler) ; also records current atomicity level
(error 'try-atomic "nested atomic timeout"))
(set! ready? #t)
(begin0

12
racket/src/cs/schemified/thread.scm
View File

@ -12498,7 +12498,7 @@
(define check-for-atomic-timeout
(lambda ()
(if (unsafe-place-local-ref cell.4)
(if (positive? (current-atomic))
(if (eq? (unsafe-place-local-ref cell.5) (current-atomic))
(|#%app| (unsafe-place-local-ref cell.4) #f)
(void))
(void))))
@ -12640,18 +12640,22 @@
(let ((app_0 (thread-cpu-time t_0)))
(+ app_0 (- now_0 start_0))))))))))
(define cell.4 (unsafe-make-place-local #f))
(define cell.5 (unsafe-make-place-local #f))
(define set-atomic-timeout-callback!
(lambda (cb_0)
(begin0
(unsafe-place-local-ref cell.4)
(unsafe-place-local-set! cell.5 (current-atomic))
(unsafe-place-local-set! cell.4 cb_0))))
(define effect_2769
(define effect_2825
(begin
(void
(let ((proc_0
(lambda ()
(if (unsafe-place-local-ref cell.4)
(begin (|#%app| (unsafe-place-local-ref cell.4) #t) #t)
(if (eq? (unsafe-place-local-ref cell.5) (current-atomic))
(begin (|#%app| (unsafe-place-local-ref cell.4) #t) #t)
#f)
#f))))
(begin-unsafe (set! force-atomic-timeout-callback proc_0))))
(void)))
@ -12827,7 +12831,7 @@
(thread-dead!
(check-not-unsafe-undefined
t_0
't_80)))
't_78)))
(end-atomic)))
(engine-block))))))))))))
(do-make-thread.1

6
racket/src/thread/schedule.rkt
View File

@ -185,7 +185,7 @@
(define (check-for-atomic-timeout)
(when atomic-timeout-callback
(when (positive? (current-atomic))
(when (eq? atomic-timeout-level (current-atomic))
(atomic-timeout-callback #f))))
(define (maybe-done callbacks)
@ -316,16 +316,18 @@
;; ----------------------------------------
(define-place-local atomic-timeout-callback #f)
(define-place-local atomic-timeout-level #f)
(define (set-atomic-timeout-callback! cb)
(begin0
atomic-timeout-callback
(set! atomic-timeout-level (current-atomic))
(set! atomic-timeout-callback cb)))
(void (set-force-atomic-timeout-callback!
(lambda ()
(and atomic-timeout-callback
(eq? atomic-timeout-level (current-atomic))
(begin
(atomic-timeout-callback #t)
#t)))))