cs & thread: fix scheduler timer event in atomic mode

When the thread-scheduler timer fires while a thread is in atomic
mode, the thread could check for breaks even when it shouldn't. Worse,
if the atomic region was to implement terminating a thread, the path
to check for a break could end up ressurecting the thread from the
persspective of `thread-dead?`.
This commit is contained in:
Matthew Flatt 2020-11-18 04:01:43 -07:00
parent b28d682ec4
commit 9a3eb15d8b
6 changed files with 61 additions and 36 deletions

View File

@ -869,6 +869,15 @@
(when (getenv "PLTDISABLEGC")
(collect-request-handler void))
(let ([s (getenv "PLT_THREAD_QUANTUM")])
;; Setting the thread quantum is useful in probing for race conditions. The default quantum
;; is 100000. If it's made too small (on the order of 100), then a thread will use up its
;; quantum just checking for breaks as it is swapped in, and then it won't make any progress.
(when s
(let ([n (string->number s)])
(when (and n (exact-nonnegative-integer? n))
(set-schedule-quantum! n)))))
(when version?
(display (banner)))
(call/cc ; Chez Scheme's `call/cc`, used here to escape from the Racket-thread engine loop

View File

@ -107,6 +107,7 @@
(1/semaphore? semaphore?)
(set-make-place-ports+fds! set-make-place-ports+fds!)
(set-processor-count! set-processor-count!)
(set-schedule-quantum! set-schedule-quantum!)
(1/sleep sleep)
(1/sync sync)
(1/sync/enable-break sync/enable-break)
@ -11470,6 +11471,7 @@
cell.2$3
(wrap-evt7.1 (unsafe-place-local-ref cell.1$5) void)))))
(define TICKS 100000)
(define set-schedule-quantum! (lambda (n_0) (set! TICKS n_0)))
(define struct:future*
(make-record-type-descriptor* 'future #f #f #f #f 10 1023))
(define effect_2884
@ -12689,7 +12691,7 @@
(begin
(|#%app|
e_0
100000
TICKS
(lambda ()
(begin
(if (if (zero? (current-atomic)) (worker-pinged? w_0) #f)
@ -12988,16 +12990,16 @@
#f
'callbacks
temp4_0))
(poll-and-select-thread! 100000 callbacks_0))
(poll-and-select-thread! TICKS callbacks_0))
(if (if (not poll-now?_0) (check-external-events) #f)
(poll-and-select-thread! 100000 callbacks_0)
(poll-and-select-thread! TICKS callbacks_0)
(if (try-post-idle)
(select-thread! leftover-ticks2_0 callbacks_0)
(begin
(process-sleep)
(poll-and-select-thread! 0 callbacks_0)))))
(select-thread!
(if poll-now?_0 100000 leftover-ticks2_0)
(if poll-now?_0 TICKS leftover-ticks2_0)
callbacks_0)))))))))))
(case-lambda
((leftover-ticks_0) (poll-and-select-thread!_0 leftover-ticks_0 null))
@ -13049,12 +13051,12 @@
(letrec ((loop_0
(|#%name|
loop
(lambda (leftover-ticks_0 t_0 e_0)
(lambda (leftover-ticks_0 t_0 e_0 prefix_0)
(begin
(|#%app|
e_0
100000
check-break-prefix
TICKS
prefix_0
(lambda (e_1 results_0 remaining-ticks_0)
(if (not e_1)
(begin
@ -13074,7 +13076,7 @@
(void))
(thread-did-work!)
(poll-and-select-thread!
(- leftover-ticks_0 (- 100000 remaining-ticks_0))))
(- leftover-ticks_0 (- TICKS remaining-ticks_0))))
(if (zero? (current-atomic))
(begin
(if (1/thread-dead?
@ -13084,7 +13086,7 @@
(let ((new-leftover-ticks_0
(-
leftover-ticks_0
(- 100000 remaining-ticks_0))))
(- TICKS remaining-ticks_0))))
(begin
(accum-cpu-time! t_0 (<= new-leftover-ticks_0 0))
(set-thread-future! t_0 (current-future$1))
@ -13099,8 +13101,9 @@
(poll-and-select-thread! new-leftover-ticks_0))))
(begin
(add-end-atomic-callback! engine-timeout)
(loop_0 leftover-ticks_0 t_0 e_1)))))))))))
(lambda (e_0 t_0 leftover-ticks_0) (loop_0 leftover-ticks_0 t_0 e_0))))
(loop_0 leftover-ticks_0 t_0 e_1 void)))))))))))
(lambda (e_0 t_0 leftover-ticks_0)
(loop_0 leftover-ticks_0 t_0 e_0 check-break-prefix))))
(define check-break-prefix
(lambda ()
(begin
@ -13141,26 +13144,32 @@
loop
(lambda (done?_0 leftover-ticks_0 t_0 e_0 callbacks_0)
(begin
(|#%app|
e_0
100000
(if (pair? callbacks_0)
(lambda ()
(let ((app_0 TICKS))
(|#%app|
e_0
app_0
(if (pair? callbacks_0)
(lambda ()
(begin
(current-thread-now-running!)
(run-callbacks callbacks_0)
(unsafe-set-box*! done?_0 #t)
(engine-block)))
void)
(lambda (e_1 result_0 remaining_0)
(begin
(current-thread-now-running!)
(run-callbacks callbacks_0)
(unsafe-set-box*! done?_0 #t)
(engine-block)))
void)
(lambda (e_1 result_0 remaining_0)
(begin
(if e_1
(void)
(internal-error
"thread ended while it should run callbacks atomically"))
(if (unsafe-unbox* done?_0)
(swap-in-engine e_1 t_0 leftover-ticks_0)
(loop_0 done?_0 leftover-ticks_0 t_0 e_1 null))))))))))
(if e_1
(void)
(internal-error
"thread ended while it should run callbacks atomically"))
(if (unsafe-unbox* done?_0)
(swap-in-engine e_1 t_0 leftover-ticks_0)
(loop_0
done?_0
leftover-ticks_0
t_0
e_1
null)))))))))))
(lambda (e_0 callbacks_0 t_0 leftover-ticks_0)
(if (null? callbacks_0)
(swap-in-engine e_0 t_0 leftover-ticks_0)
@ -13440,7 +13449,7 @@
(thread-dead!
(check-not-unsafe-undefined
t_0
't_78)))
't_79)))
(end-atomic)))
(engine-block))))))))))))))
(do-make-thread.1

View File

@ -33,7 +33,8 @@ GLOBALS = --no-global \
++global-ok log-future-event \
++global-ok "logging-place-events?" \
++global-ok log-place-event \
++global-ok thread-engine-for-roots
++global-ok thread-engine-for-roots \
++global-ok TICKS
GENERATE_ARGS = -t main.rkt \
--check-depends $(BUILDDIR)compiled/thread-dep.rktd \

View File

@ -3,3 +3,6 @@
(provide (all-defined-out))
(define TICKS 100000)
(define (set-schedule-quantum! n)
(set! TICKS n))

View File

@ -31,7 +31,8 @@
"future.rkt"
"future-logging.rkt"
"fsemaphore.rkt"
"os-thread.rkt")
"os-thread.rkt"
"config.rkt")
(provide call-in-main-thread
@ -212,4 +213,6 @@
unsafe-os-semaphore-post
unsafe-os-semaphore-wait
set-schedule-quantum!
#%thread-instance)

View File

@ -132,11 +132,11 @@
(set-thread-engine! (current-thread/in-atomic) 'running))
(define (swap-in-engine e t leftover-ticks)
(let loop ([e e])
(let loop ([e e] [prefix check-break-prefix])
(end-implicit-atomic-mode)
(e
TICKS
check-break-prefix
prefix
(lambda (e results remaining-ticks)
(start-implicit-atomic-mode)
(cond
@ -174,7 +174,7 @@
;; where host-system interrupts are not disabled (i.e.,
;; don't use `engine-block` instead of `engine-timeout`):
(add-end-atomic-callback! engine-timeout)
(loop e)])])))))
(loop e void)])])))))
(define (check-break-prefix)
(current-thread-now-running!)