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? (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

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

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