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

cs & thread: fix scheduler timer event in atomic mode

Browse Source 
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
Show Stats Download Patch File Download Diff File Expand all files Collapse all files

9
racket/src/cs/main.sps
View File

@ -869,6 +869,15 @@
(when (getenv "PLTDISABLEGC") (when (getenv "PLTDISABLEGC")
(collect-request-handler void)) (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? (when version?
(display (banner))) (display (banner)))
(call/cc ; Chez Scheme's `call/cc`, used here to escape from the Racket-thread engine loop (call/cc ; Chez Scheme's `call/cc`, used here to escape from the Racket-thread engine loop

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

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

3
racket/src/thread/Makefile
View File

@ -33,7 +33,8 @@ GLOBALS = --no-global \
++global-ok log-future-event \ ++global-ok log-future-event \
++global-ok "logging-place-events?" \ ++global-ok "logging-place-events?" \
++global-ok log-place-event \ ++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 \ GENERATE_ARGS = -t main.rkt \
--check-depends $(BUILDDIR)compiled/thread-dep.rktd \ --check-depends $(BUILDDIR)compiled/thread-dep.rktd \

3
racket/src/thread/config.rkt
View File

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

5
racket/src/thread/main.rkt
View File

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

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

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