From 4d0aa443b135d1d6fa3111ce934f63fe352aa60e Mon Sep 17 00:00:00 2001 From: Matthew Flatt Date: Sat, 19 Dec 2020 16:06:16 -0700 Subject: [PATCH] cs & thread: fix problems with sync and breaks This commit fixes two bugs: * `sync/enable-break` didn't implement the guarantee that an event is selected or a break exception raised, but not both; the problem was in the handling of making the break-enable state ignored after committing to an event * `sync` didn't cancel asynchronous pending commits when a break is received at certain points; the bug in `sync/enable-break` masked this bug for existing test cases Closes #3574 --- pkgs/racket-test-core/tests/racket/sync.rktl | 92 ++++++++++++++------ racket/src/cs/schemified/thread.scm | 45 +++------- racket/src/thread/sync.rkt | 5 +- racket/src/thread/thread.rkt | 8 +- 4 files changed, 89 insertions(+), 61 deletions(-) diff --git a/pkgs/racket-test-core/tests/racket/sync.rktl b/pkgs/racket-test-core/tests/racket/sync.rktl index 1561a289ec..4ac318aaae 100644 --- a/pkgs/racket-test-core/tests/racket/sync.rktl +++ b/pkgs/racket-test-core/tests/racket/sync.rktl @@ -1226,6 +1226,9 @@ [did-post2 #f] [did-done #f] [break-on (lambda () (break-enabled #t))] + [sync-idle/break-thread (lambda (t) + (sync (system-idle-evt)) + (break-thread t))] [sw semaphore-wait]) (let ([mk-t (lambda (init ;; how to start @@ -1273,8 +1276,8 @@ reset (lambda () (set! did-pre1 #t) - (semaphore-post p) (pre-thunk) + (semaphore-post p) (pre-semaphore-wait s) (set! did-pre2 #t)))) (lambda () @@ -1282,8 +1285,8 @@ reset (lambda () (set! did-act1 #t) - (semaphore-post p) (act-thunk) + (semaphore-post p) (act-semaphore-wait s) (set! did-act2 #t)))) (lambda () @@ -1291,8 +1294,8 @@ reset (lambda () (set! did-post1 #t) - (semaphore-post p) (post-thunk) + (semaphore-post p) (post-semaphore-wait s) (set! did-post2 #t))))) (set! did-done #t))))))]) @@ -1337,7 +1340,8 @@ (semaphore-post s) (if should-pre-break? (begin - (thread-wait t) + (thread-wait t) + (test #t semaphore-try-wait? s) (test #f 'pre2 did-pre2)) (if should-preact-break? (begin @@ -1365,6 +1369,7 @@ (if should-post-break? (begin (thread-wait t) + (test #t semaphore-try-wait? s) (test #f 'post2 did-post2)) (begin (thread-wait t) @@ -1374,29 +1379,32 @@ (lambda (mk-t) (for-each (lambda (nada) - ;; Basic checks --- dynamic-wind thunks don't explicitly enable breaks - (go mk-t #f nada nada nada sw sw sw void #f #f void #f void #f #f) - (go mk-t #f nada nada nada sw sw sw break-thread #f 'pre-act void #f void #f #f) - (go mk-t #f nada nada nada sw sw sw void #f #f break-thread 'act void #f #f) - (go mk-t #f nada nada nada sw sw sw void #f #f void #f break-thread #f 'done) + (for-each + (lambda (break-thread) + ;; Basic checks --- dynamic-wind thunks don't explicitly enable breaks + (go mk-t #f nada nada nada sw sw sw void #f #f void #f void #f #f) + (go mk-t #f nada nada nada sw sw sw break-thread #f 'pre-act void #f void #f #f) + (go mk-t #f nada nada nada sw sw sw void #f #f break-thread 'act void #f #f) + (go mk-t #f nada nada nada sw sw sw void #f #f void #f break-thread #f 'done) - ;; All dynamic-wind thunks enable breaks - (map (lambda (break-on sw) - (go mk-t #f break-on break-on break-on sw sw sw void #f #f void #f void #f #f) - (go mk-t #f break-on break-on break-on sw sw sw break-thread 'pre #f void #f void #f #f) - (go mk-t #f break-on break-on break-on sw sw sw void #f #f break-thread 'act void #f #f) - (go mk-t #f break-on break-on break-on sw sw sw void #f #f void #f break-thread 'post #f)) - (list break-on void) - (list sw semaphore-wait/enable-break)) + ;; All dynamic-wind thunks enable breaks + (map (lambda (break-on sw) + (go mk-t #f break-on break-on break-on sw sw sw void #f #f void #f void #f #f) + (go mk-t #f break-on break-on break-on sw sw sw break-thread 'pre #f void #f void #f #f) + (go mk-t #f break-on break-on break-on sw sw sw void #f #f break-thread 'act void #f #f) + (go mk-t #f break-on break-on break-on sw sw sw void #f #f void #f break-thread 'post #f)) + (list break-on void) + (list sw semaphore-wait/enable-break)) - ;; Enable break in pre or act shouldn't affect post - (go mk-t #f break-on nada nada sw sw sw void #f #f void #f break-thread #f 'done) - (go mk-t #f nada break-on nada sw sw sw void #f #f void #f break-thread #f 'done) - - ;; Enable break in pre shouldn't affect act/done - (go mk-t #t break-on nada nada sw sw sw void #f #f break-thread #f void #f #f) - (go mk-t #t break-on nada nada sw sw sw void #f #f void #f break-thread #f #f)) - (list void sleep))) + ;; Enable break in pre or act shouldn't affect post + (go mk-t #f break-on nada nada sw sw sw void #f #f void #f break-thread #f 'done) + (go mk-t #f nada break-on nada sw sw sw void #f #f void #f break-thread #f 'done) + + ;; Enable break in pre shouldn't affect act/done + (go mk-t #t break-on nada nada sw sw sw void #f #f break-thread #f void #f #f) + (go mk-t #t break-on nada nada sw sw sw void #f #f void #f break-thread #f #f)) + (list break-thread sync-idle/break-thread))) + (list void sleep))) ;; We'll make threads in three modes: normal, restore a continuation into pre, ;; and restore a continuation into act (let* ([no-capture (lambda (reset body) (body))] @@ -1576,6 +1584,40 @@ (try (lambda (c) (choice-evt c (alarm-evt (+ 10000 (current-inexact-milliseconds))))) 'ok-channel+alarm)) +;; ---------------------------------------- +;; Extra check that a sync/enable-break either succeeds or breaks, +;; where we avoid explicit thread synchronization and spin to +;; try to get different schedules. +;; Based on an example from Bogdan. + +(for ([i 50]) + (let ([succeeded? #f] + [broke? #f]) + (define (spin-then thunk) + (let loop ([n (random 1000000)]) + (cond + [(zero? n) (thunk)] + [else (loop (sub1 n))]))) + (struct p () + #:property prop:evt (unsafe-poller + (lambda (self wakeups) + ;; loop to try to be slow + (spin-then + (lambda () + (set! succeeded? #t) + (values (list 'success) #f)))))) + (define ready-sema (make-semaphore)) + (define t (thread (lambda () + (parameterize-break #f + (semaphore-post ready-sema) + (with-handlers ([exn:break? (lambda (exn) + (set! broke? #t))]) + (sync/enable-break (p))))))) + (semaphore-wait ready-sema) + (spin-then (lambda () (break-thread t))) + (sync t) + (test #t 'xor-on-success-and-break (if succeeded? (not broke?) broke?)))) + ;; ---------------------------------------- ;; Make sure that suspending a thread that's blocked on a ;; semaphore works right when the semaphore becomes available diff --git a/racket/src/cs/schemified/thread.scm b/racket/src/cs/schemified/thread.scm index 43a182d5d5..759e643da4 100644 --- a/racket/src/cs/schemified/thread.scm +++ b/racket/src/cs/schemified/thread.scm @@ -7010,8 +7010,7 @@ "attempt to deschedule the current thread in atomic mode")) (void))))))) (loop_0)) - (engine-block) - (|#%app| 1/check-for-break)) + (engine-block)) (void)))))) (define thread-deschedule! (lambda (t_0 timeout-at_0 interrupt-callback_0) @@ -7703,6 +7702,8 @@ (begin (set-thread-pending-break! t_0 kind_0) (thread-did-work!) + (run-suspend/resume-callbacks t_0 car) + (run-suspend/resume-callbacks t_0 cdr) (if (thread-descheduled? t_0) (if (thread-suspended? t_0) (void) @@ -9197,11 +9198,7 @@ (go_0 (|#%name| go - (lambda (enable-break?7_0 - local-break-cell_0 - s_0 - timeout10_0 - thunk-result?38_0) + (lambda (enable-break?7_0 s_0 timeout10_0 thunk-result?38_0) (begin (dynamic-wind (lambda () @@ -9239,11 +9236,6 @@ (start-atomic) (thread-pop-suspend+resume-callbacks!) (thread-pop-kill-callback!) - (if local-break-cell_0 - (thread-remove-ignored-break-cell! - (current-thread/in-atomic) - local-break-cell_0) - (void)) (|#%app| syncing-abandon! s_0) (end-atomic)))))))) (loop_0 @@ -9406,13 +9398,13 @@ push-authentic break-enabled-key local-break-cell_0 - (go_0 - enable-break?7_0 - local-break-cell_0 - s_0 - timeout10_0 - #t)))) - (begin (1/check-for-break) (|#%app| thunk_0))) + (go_0 enable-break?7_0 s_0 timeout10_0 #t)))) + (begin + (thread-remove-ignored-break-cell! + (current-thread/in-atomic) + local-break-cell_0) + (1/check-for-break) + (|#%app| thunk_0))) (let ((temp52_0 (lambda (sched-info_0 polled-all?_0 no-wrappers?_0) (if polled-all?_0 @@ -9423,26 +9415,15 @@ (if (procedure? timeout10_0) (|#%app| timeout10_0) (if no-wrappers?_0 - (go_0 - enable-break?7_0 - local-break-cell_0 - s_0 - timeout10_0 - #f) + (go_0 enable-break?7_0 s_0 timeout10_0 #f) (|#%app| (go_0 enable-break?7_0 - local-break-cell_0 s_0 timeout10_0 #t))))) (|#%app| - (go_0 - enable-break?7_0 - local-break-cell_0 - s_0 - timeout10_0 - #t)))))) + (go_0 enable-break?7_0 s_0 timeout10_0 #t)))))) (|#%app| sync-poll.1 #f diff --git a/racket/src/thread/sync.rkt b/racket/src/thread/sync.rkt index 71cb51cfd9..029eeed4ea 100644 --- a/racket/src/thread/sync.rkt +++ b/racket/src/thread/sync.rkt @@ -167,8 +167,6 @@ (atomically (thread-pop-suspend+resume-callbacks!) (thread-pop-kill-callback!) - (when local-break-cell - (thread-remove-ignored-break-cell! (current-thread/in-atomic) local-break-cell)) ;; On escape, post nacks, etc.: (syncing-abandon! s) (void))))) @@ -181,6 +179,9 @@ break-enabled-key local-break-cell (go))) + ;; If we get here, the break wasn't triggered, and it must be currently ignored. + ;; (If the break was triggered so that we don't get here, it's not ignored.) + (thread-remove-ignored-break-cell! (current-thread/in-atomic) local-break-cell) ;; In case old break cell was meanwhile enabled: (check-for-break) ;; In tail position: diff --git a/racket/src/thread/thread.rkt b/racket/src/thread/thread.rkt index 22697b0e65..433cd95996 100644 --- a/racket/src/thread/thread.rkt +++ b/racket/src/thread/thread.rkt @@ -440,8 +440,8 @@ (if (force-atomic-timeout-callback) (loop) (internal-error "attempt to deschedule the current thread in atomic mode")))) - (engine-block) - (check-for-break)))) + ;; implies `(check-for-break)`: + (engine-block)))) ;; Extends `do-thread-deschdule!` where `t` is always `(current-thread)`. ;; The `interrupt-callback` is called if the thread receives a break @@ -836,6 +836,10 @@ (unless (thread-pending-break t) (set-thread-pending-break! t kind) (thread-did-work!) + (begin + ;; interrupt synchronization, if any + (run-suspend/resume-callbacks t car) + (run-suspend/resume-callbacks t cdr)) (when (thread-descheduled? t) (unless (thread-suspended? t) (run-interrupt-callback t)