diff --git a/racket/src/io/sandman/main.rkt b/racket/src/io/sandman/main.rkt index 495b92edbf..1570b9d9d0 100644 --- a/racket/src/io/sandman/main.rkt +++ b/racket/src/io/sandman/main.rkt @@ -88,7 +88,7 @@ (rktio_poll_set_forget rktio ps)) ;; poll - (lambda (mode wakeup) + (lambda (wakeup) (let check-signals () (define v (rktio_poll_os_signal rktio)) (unless (eqv? v RKTIO_OS_SIGNAL_NONE) @@ -100,7 +100,7 @@ (check-signals))) (when (fd-semaphore-poll-ready?) (wakeup #f)) - ((sandman-do-poll timeout-sandman) mode wakeup)) + ((sandman-do-poll timeout-sandman) wakeup)) ;; get-wakeup (lambda () diff --git a/racket/src/thread/sandman.rkt b/racket/src/thread/sandman.rkt index 1755036e7d..d6494ea2a2 100644 --- a/racket/src/thread/sandman.rkt +++ b/racket/src/thread/sandman.rkt @@ -64,8 +64,8 @@ ;; The `thread-wakeup` callback can be called with #f ;; to indicate that a thread was potentially woken up ;; some other way, such as by a semaphore post -(define (sandman-poll mode thread-wakeup) - ((sandman-do-poll the-sandman) mode thread-wakeup)) +(define (sandman-poll thread-wakeup) + ((sandman-do-poll the-sandman) thread-wakeup)) ;; in atomic mode (define (sandman-sleep exts) @@ -111,8 +111,7 @@ (host:sleep (max 0.0 (/ (- (or timeout-at (distant-future)) (current-inexact-milliseconds)) 1000.0)))) ;; poll - (lambda (mode wakeup) - ;; This check is fast, so do it in all modes + (lambda (wakeup) (unless (tree-empty? sleeping-threads) (define-values (timeout-at threads) (tree-min sleeping-threads)) (when (timeout-at . <= . (current-inexact-milliseconds)) diff --git a/racket/src/thread/schedule.rkt b/racket/src/thread/schedule.rkt index 46a4e06971..3c11b6d509 100644 --- a/racket/src/thread/schedule.rkt +++ b/racket/src/thread/schedule.rkt @@ -33,7 +33,7 @@ (make-initial-thread (lambda () (set-place-host-roots! initial-place (host:current-place-roots)) (thunk))) - (select-thread! 0)) + (poll-and-select-thread! 0)) ;; Initializes the thread system in a new place: (define (call-in-another-main-thread c thunk) @@ -54,31 +54,50 @@ (set! skipped-time-accums 0) (set! thread-swap-count 0)) -(define (select-thread! in-leftover-ticks [pending-callbacks null]) +(define (poll-and-select-thread! leftover-ticks [pending-callbacks null]) (define callbacks (if (null? pending-callbacks) (host:poll-async-callbacks) pending-callbacks)) + ;; Perform any expensive polls (such as ones that consult the OS) + ;; only after ticks have been used up: + (define poll-now? (leftover-ticks . <= . 0)) (host:poll-will-executors) (poll-custodian-will-executor) - (define leftover-ticks (maybe-check-external-events in-leftover-ticks)) + (when poll-now? + (check-external-events)) (call-pre-poll-external-callbacks) (check-place-activity) (check-queued-custodian-shutdown) (flush-future-log) - (when (and (null? callbacks) - (all-threads-poll-done?) - (waiting-on-external-or-idle?)) - (or (check-external-events 'slow) - (try-post-idle) - (process-sleep))) - (let loop ([g root-thread-group] [pending-callbacks pending-callbacks] [none-k maybe-done]) + (cond + [(and (null? callbacks) + (all-threads-poll-done?)) + ;; May need to sleep + (cond + [(and (not poll-now?) + (check-external-events)) + ;; Retry and reset counter for checking external events + (poll-and-select-thread! TICKS callbacks)] + [(try-post-idle) + ;; Enabled a thread that was waiting for idle + (select-thread! leftover-ticks callbacks)] + [else + (process-sleep) + ;; Retry, checking right away for external events + (poll-and-select-thread! 0 callbacks)])] + [else + ;; Looks like some thread can work now + (select-thread! (if poll-now? TICKS leftover-ticks) callbacks)])) + +(define (select-thread! leftover-ticks callbacks) + (let loop ([g root-thread-group] [callbacks callbacks] [none-k maybe-done]) (define child (thread-group-next! g)) (cond [(not child) (none-k callbacks)] [(thread? child) (swap-in-thread child leftover-ticks callbacks)] [else - (loop child callbacks (lambda (pending-callbacks) (loop g none-k pending-callbacks)))]))) + (loop child callbacks (lambda (callbacks) (loop g none-k callbacks)))]))) (define (swap-in-thread t leftover-ticks callbacks) (define e (thread-engine t)) @@ -113,7 +132,7 @@ (when (eq? root-thread t) (force-exit 0)) (thread-did-work!) - (select-thread! (- leftover-ticks (- TICKS remaining-ticks)))) + (poll-and-select-thread! (- leftover-ticks (- TICKS remaining-ticks)))) (lambda (e remaining-ticks) (start-implicit-atomic-mode) (cond @@ -126,7 +145,7 @@ (set-place-current-thread! current-place #f) (unless (eq? (thread-engine t) 'done) (set-thread-engine! t e)) - (select-thread! new-leftover-ticks)] + (poll-and-select-thread! new-leftover-ticks)] [else ;; Swap out when the atomic region ends and at a point ;; where host-system interrupts are not disabled (i.e., @@ -142,7 +161,7 @@ (do-make-thread 'scheduler-make-thread void #:custodian #f) - (select-thread! 0 callbacks)] + (poll-and-select-thread! 0 callbacks)] [(and (not (sandman-any-sleepers?)) (not (any-idle-waiters?))) ;; all threads done or blocked @@ -152,28 +171,18 @@ ;; blocked, but it's not going to become unblocked; ;; sleep forever or until a signal changes things (process-sleep) - (select-thread! 0)] + (poll-and-select-thread! 0)] [else (void)])] [else ;; try again, which should lead to `process-sleep` - (select-thread! 0)])) - -;; Limit frequency of polling for external events, even -;; in 'fast mode (because it's not that fast) -(define (maybe-check-external-events leftover-ticks) - (cond - [(leftover-ticks . > . 0) leftover-ticks] - [else - (check-external-events 'fast) - TICKS])) + (poll-and-select-thread! 0)])) ;; Check for threads that have been suspended until a particular time, ;; etc., as registered with the sandman -(define (check-external-events mode) +(define (check-external-events) (define did? #f) - (sandman-poll mode - (lambda (t) + (sandman-poll (lambda (t) (when t (thread-reschedule! t)) (set! did? #t))) @@ -219,11 +228,6 @@ (= (hash-count poll-done-threads) num-threads-in-groups)) -(define (waiting-on-external-or-idle?) - (or (positive? num-threads-in-groups) - (sandman-any-sleepers?) - (any-idle-waiters?))) - ;; Stop using the CPU for a while (define (process-sleep) (define ts (thread-group-all-threads root-thread-group null))