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

cs & thread: fix sync shortcut and handle-evt

Browse Source 
A shortcut meant to speed up `sync` on values such as semaphores
caused `handle-evt` handlers to sometimes not run in tail position.
This commit is contained in:
Matthew Flatt 2019-10-28 19:03:30 -06:00
parent 6510ebb565
commit c34538c58f
2 changed files with 39 additions and 23 deletions
Show Stats Download Patch File Download Diff File Expand all files Collapse all files

14
pkgs/racket-test-core/tests/racket/sync.rktl
View File

@ -347,6 +347,20 @@
(test #f handle-evt? (wrap-evt always-evt void)) (test #f handle-evt? (wrap-evt always-evt void))
(test #f handle-evt? (choice-evt (wrap-evt always-evt void) (wrap-evt always-evt void))) (test #f handle-evt? (choice-evt (wrap-evt always-evt void) (wrap-evt always-evt void)))
(let ()
(define (check-handle evt)
(test 'yes 'handle-evt-tail
(with-continuation-mark
'here 'yes
(sync (handle-evt evt
(lambda (v)
(call-with-immediate-continuation-mark
'here
(lambda (v) v))))))))
(check-handle always-evt)
(let ([t (thread (lambda () (void)))])
(check-handle (thread-dead-evt t))))
;; ---------------------------------------- ;; ----------------------------------------
;; Nack waitables ;; Nack waitables

48
racket/src/thread/sync.rkt
View File

@ -91,7 +91,7 @@
(atomically (call-pre-poll-external-callbacks))) (atomically (call-pre-poll-external-callbacks)))
;; General polling loop ;; General polling loop
(define (go #:thunk-result? [thunk-result? #f]) (define (go #:thunk-result? [thunk-result? #t])
(dynamic-wind (dynamic-wind
(lambda () (lambda ()
(atomically (atomically
@ -108,7 +108,7 @@
(let poll-loop () (let poll-loop ()
(sync-poll s (sync-poll s
#:success-k (and thunk-result? (lambda (thunk) thunk)) #:success-k (and thunk-result? (lambda (thunk) thunk))
#:fail-k (lambda (sched-info polled-all?) #:fail-k (lambda (sched-info polled-all? no-wrappers?)
(cond (cond
[(not polled-all?) [(not polled-all?)
(poll-loop)] (poll-loop)]
@ -155,7 +155,7 @@
(sync-poll s (sync-poll s
#:success-k (and thunk-result? (lambda (thunk) thunk)) #:success-k (and thunk-result? (lambda (thunk) thunk))
#:did-work? did-work? #:did-work? did-work?
#:fail-k (lambda (sched-info now-polled-all?) #:fail-k (lambda (sched-info now-polled-all? no-wrappers?)
(when timeout-at (when timeout-at
(schedule-info-add-timeout-at! sched-info timeout-at)) (schedule-info-add-timeout-at! sched-info timeout-at))
(thread-yield sched-info) (thread-yield sched-info)
@ -176,7 +176,7 @@
(define thunk (with-continuation-mark (define thunk (with-continuation-mark
break-enabled-key break-enabled-key
local-break-cell local-break-cell
(go #:thunk-result? #t))) (go)))
;; In case old break cell was meanwhile enabled: ;; In case old break cell was meanwhile enabled:
(check-for-break) (check-for-break)
;; In tail position: ;; In tail position:
@ -185,14 +185,15 @@
;; Try a fast poll (avoiding `dynamic-wind`, etc.) ;; Try a fast poll (avoiding `dynamic-wind`, etc.)
;; before chaining to `go`: ;; before chaining to `go`:
(sync-poll s (sync-poll s
#:fail-k (lambda (sched-info polled-all?) #:fail-k (lambda (sched-info polled-all? no-wrappers?)
(cond (cond
[polled-all? [polled-all?
(cond (cond
[(and (real? timeout) (zero? timeout)) #f] [(and (real? timeout) (zero? timeout)) #f]
[(procedure? timeout) (timeout)] [(procedure? timeout) (timeout)]
[else (go)])] [no-wrappers? (go #:thunk-result? #f)]
[else (go)])) [else ((go))])]
[else ((go))]))
#:just-poll? #t #:just-poll? #t
#:fast-only? #t)])) #:fast-only? #t)]))
@ -373,7 +374,8 @@
#:schedule-info [sched-info (make-schedule-info #:did-work? did-work?)]) #:schedule-info [sched-info (make-schedule-info #:did-work? did-work?)])
(let loop ([sr (syncing-syncers s)] (let loop ([sr (syncing-syncers s)]
[retries 0] ; count retries on `sr`, and advance if it's too many [retries 0] ; count retries on `sr`, and advance if it's too many
[polled-all-so-far? #t]) [polled-all-so-far? #t]
[no-wrappers? #t])
(start-atomic) (start-atomic)
(when (syncing-need-retry? s) (when (syncing-need-retry? s)
(syncing-retry! s)) (syncing-retry! s))
@ -388,11 +390,11 @@
(when (and just-poll? done-after-poll? polled-all-so-far? (not fast-only?)) (when (and just-poll? done-after-poll? polled-all-so-far? (not fast-only?))
(syncing-done! s none-syncer)) (syncing-done! s none-syncer))
(end-atomic) (end-atomic)
(none-k sched-info polled-all-so-far?)] (none-k sched-info polled-all-so-far? no-wrappers?)]
[(= retries MAX-SYNC-TRIES-ON-ONE-EVT) [(= retries MAX-SYNC-TRIES-ON-ONE-EVT)
(schedule-info-did-work! sched-info) (schedule-info-did-work! sched-info)
(end-atomic) (end-atomic)
(loop (syncer-next sr) 0 #f)] (loop (syncer-next sr) 0 #f #f)]
[else [else
(define ctx (poll-ctx just-poll? (define ctx (poll-ctx just-poll?
;; Call back for asynchronous selection, ;; Call back for asynchronous selection,
@ -420,7 +422,7 @@
;; Have to go out of atomic mode to continue: ;; Have to go out of atomic mode to continue:
(end-atomic) (end-atomic)
(cond (cond
[fast-only? (none-k sched-info #f)] [fast-only? (none-k sched-info #f #f)]
[else [else
(let ([new-evt ((delayed-poll-resume new-evt))]) (let ([new-evt ((delayed-poll-resume new-evt))])
;; Since we left atomic mode, double-check that we're ;; Since we left atomic mode, double-check that we're
@ -428,7 +430,7 @@
(atomically (atomically
(unless (syncing-selected s) (unless (syncing-selected s)
(set-syncer-evt! sr new-evt))) (set-syncer-evt! sr new-evt)))
(loop sr (add1 retries) polled-all-so-far?))])] (loop sr (add1 retries) polled-all-so-far? #f))])]
[(choice-evt? new-evt) [(choice-evt? new-evt)
(when (or (pair? (syncer-interrupts sr)) (when (or (pair? (syncer-interrupts sr))
(pair? (syncer-retries sr))) (pair? (syncer-retries sr)))
@ -445,12 +447,12 @@
;; Empty choice, so drop it: ;; Empty choice, so drop it:
(syncer-remove! sr s) (syncer-remove! sr s)
(end-atomic) (end-atomic)
(loop (syncer-next sr) 0 polled-all-so-far?)] (loop (syncer-next sr) 0 polled-all-so-far? no-wrappers?)]
[else [else
;; Splice in new syncers, and start there ;; Splice in new syncers, and start there
(syncer-replace! sr new-syncers s) (syncer-replace! sr new-syncers s)
(end-atomic) (end-atomic)
(loop new-syncers (add1 retries) polled-all-so-far?)])] (loop new-syncers (add1 retries) polled-all-so-far? no-wrappers?)])]
[(wrap-evt? new-evt) [(wrap-evt? new-evt)
(set-syncer-wraps! sr (cons (wrap-evt-wrap new-evt) (set-syncer-wraps! sr (cons (wrap-evt-wrap new-evt)
(let ([l (syncer-wraps sr)]) (let ([l (syncer-wraps sr)])
@ -471,7 +473,7 @@
(make-result sr (list always-evt) success-k)] (make-result sr (list always-evt) success-k)]
[else [else
(end-atomic) (end-atomic)
(loop sr (add1 retries) polled-all-so-far?)])] (loop sr (add1 retries) polled-all-so-far? #f)])]
[(control-state-evt? new-evt) [(control-state-evt? new-evt)
(define wrap-proc (control-state-evt-wrap-proc new-evt)) (define wrap-proc (control-state-evt-wrap-proc new-evt))
(define interrupt-proc (control-state-evt-interrupt-proc new-evt)) (define interrupt-proc (control-state-evt-interrupt-proc new-evt))
@ -492,14 +494,14 @@
(not (and (eq? interrupt-proc void) (not (and (eq? interrupt-proc void)
(eq? abandon-proc void) (eq? abandon-proc void)
(eq? retry-proc void)))) (eq? retry-proc void))))
(none-k sched-info #f)] (none-k sched-info #f #f)]
[else [else
(loop sr (add1 retries) polled-all-so-far?)])] (loop sr (add1 retries) polled-all-so-far? no-wrappers?)])]
[(poll-guard-evt? new-evt) [(poll-guard-evt? new-evt)
;; Must leave atomic mode: ;; Must leave atomic mode:
(end-atomic) (end-atomic)
(cond (cond
[fast-only? (none-k sched-info #f)] [fast-only? (none-k sched-info #f #f)]
[else [else
(define generated (call-with-continuation-barrier (define generated (call-with-continuation-barrier
(lambda () (lambda ()
@ -507,7 +509,7 @@
(set-syncer-evt! sr (if (evt? generated) (set-syncer-evt! sr (if (evt? generated)
generated generated
(wrap-evt always-evt (lambda (a) generated)))) (wrap-evt always-evt (lambda (a) generated))))
(loop sr (add1 retries) polled-all-so-far?)])] (loop sr (add1 retries) polled-all-so-far? #f)])]
[(and (never-evt? new-evt) [(and (never-evt? new-evt)
(not (evt-impersonator? new-evt)) (not (evt-impersonator? new-evt))
(null? (syncer-interrupts sr)) (null? (syncer-interrupts sr))
@ -516,16 +518,16 @@
;; Drop this event, since it will never get selected ;; Drop this event, since it will never get selected
(syncer-remove! sr s) (syncer-remove! sr s)
(end-atomic) (end-atomic)
(loop (syncer-next sr) 0 polled-all-so-far?)] (loop (syncer-next sr) 0 polled-all-so-far? no-wrappers?)]
[(and (eq? new-evt (syncer-evt sr)) [(and (eq? new-evt (syncer-evt sr))
(not (poll-ctx-incomplete? ctx))) (not (poll-ctx-incomplete? ctx)))
;; No progress on this evt ;; No progress on this evt
(end-atomic) (end-atomic)
(loop (syncer-next sr) 0 polled-all-so-far?)] (loop (syncer-next sr) 0 polled-all-so-far? no-wrappers?)]
[else [else
(set-syncer-evt! sr new-evt) (set-syncer-evt! sr new-evt)
(end-atomic) (end-atomic)
(loop sr (add1 retries) polled-all-so-far?)])]))) (loop sr (add1 retries) polled-all-so-far? no-wrappers?)])])))
;; Called in atomic mode, but leaves atomic mode ;; Called in atomic mode, but leaves atomic mode
;; Applies wraps immediately, while breaks are ;; Applies wraps immediately, while breaks are
@ -737,7 +739,7 @@
(define (poll-nested-sync ns poll-ctx) (define (poll-nested-sync ns poll-ctx)
(sync-poll (nested-sync-evt-s ns) (sync-poll (nested-sync-evt-s ns)
#:fail-k (lambda (sched-info polled-all?) #:fail-k (lambda (sched-info polled-all? no-wrappers?)
(unless polled-all? (unless polled-all?
(set-poll-ctx-incomplete?! poll-ctx #f)) (set-poll-ctx-incomplete?! poll-ctx #f))
(values #f ns)) (values #f ns))