From 1ba4d76fe0663062d7a2bbb770efa907b44045c9 Mon Sep 17 00:00:00 2001 From: Matthew Flatt Date: Wed, 19 Jun 2019 17:27:24 -0600 Subject: [PATCH] cs & thread: avoid excessive polling for external events Reduce polling in the case that threads that block and swap rapidly, in which case polling on every thread swap can be useless and expensive. --- racket/src/cs/demo/control.ss | 12 +++++------ racket/src/cs/rumble/engine.ss | 7 +++++-- racket/src/thread/schedule.rkt | 38 +++++++++++++++++++++------------- 3 files changed, 35 insertions(+), 22 deletions(-) diff --git a/racket/src/cs/demo/control.ss b/racket/src/cs/demo/control.ss index 7ce4be408d..65499ddb98 100644 --- a/racket/src/cs/demo/control.ss +++ b/racket/src/cs/demo/control.ss @@ -457,7 +457,7 @@ (e 100 (lambda () (set! started (add1 started))) (lambda (remain a b c) (list a b c n started)) - (lambda (e timeout?) + (lambda (e remain) (loop e (add1 n)))))) '(1 2 3 10 11)) @@ -481,7 +481,7 @@ (e 200 void (lambda (remain a b c pre t-post) (list a b c pre t-post post n)) - (lambda (e timeout?) + (lambda (e remain) (loop e (add1 n))))) '(1 2 3 10 0 10 10)))) @@ -504,12 +504,12 @@ 100 void (lambda (remain l) l) - (lambda (e timeout?) (error 'engine "oops")))) + (lambda (e remain) (error 'engine "oops")))) (define l2 ((list-ref l1 2) 100 void (lambda (remain l) l) - (lambda (e timeout?) (error 'engine "oops")))) + (lambda (e remain) (error 'engine "oops")))) (check (list-ref l1 0) 1) (check (list-ref l1 1) 100) (check (list-ref l1 3) 2) @@ -528,7 +528,7 @@ (extend-parameterization (continuation-mark-set-first #f parameterization-key) my-param 'set) (make-engine (lambda () (|#%app| my-param)) engine-tag #f #f #f))]) (check (|#%app| my-param) 'init) - (check (e 1000 void (lambda (remain v) v) (lambda (e timeout?) (error 'engine "oops"))) 'set)) + (check (e 1000 void (lambda (remain v) v) (lambda (e remain) (error 'engine "oops"))) 'set)) (let ([also-my-param (make-derived-parameter my-param (lambda (v) (list v)) @@ -633,7 +633,7 @@ (= prefixes (add1 i)) (- (car v) i) (- (cadr v) i))) - (lambda (e timeout?) (loop e (add1 i)))))) + (lambda (e remain) (loop e (add1 i)))))) '(#t #t 1 0)) ;; ---------------------------------------- diff --git a/racket/src/cs/rumble/engine.ss b/racket/src/cs/rumble/engine.ss index 98cc9a5aa3..34ad06248f 100644 --- a/racket/src/cs/rumble/engine.ss +++ b/racket/src/cs/rumble/engine.ss @@ -86,7 +86,10 @@ [(timeout?) (assert-not-in-uninterrupted) (timer-interrupt-handler void) - (let ([es (current-engine-state)]) + (let ([es (current-engine-state)] + [remain-ticks (if timeout? + 0 + (set-timer 0))]) (unless es (error 'engine-block "not currently running an engine")) (reset-handler (engine-state-reset-handler es)) @@ -105,7 +108,7 @@ (lambda (prefix) prefix) ; returns `prefix` to the above "((" (engine-state-thread-cell-values es) (engine-state-init-break-enabled-cell es)) - timeout?))))))] + remain-ticks))))))] [() (engine-block #f)])) (define (engine-block/timeout) diff --git a/racket/src/thread/schedule.rkt b/racket/src/thread/schedule.rkt index d001a8c8b1..b749918807 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!)) + (select-thread! 0)) ;; Initializes the thread system in a new place: (define (call-in-another-main-thread c thunk) @@ -54,13 +54,13 @@ (set! skipped-time-accums 0) (set! thread-swap-count 0)) -(define (select-thread! [pending-callbacks null]) +(define (select-thread! in-leftover-ticks [pending-callbacks null]) (define callbacks (if (null? pending-callbacks) (host:poll-async-callbacks) pending-callbacks)) (host:poll-will-executors) (poll-custodian-will-executor) - (check-external-events 'fast) + (define leftover-ticks (maybe-check-external-events in-leftover-ticks)) (call-pre-poll-external-callbacks) (check-place-activity) (check-queued-custodian-shutdown) @@ -76,11 +76,11 @@ (cond [(not child) (none-k callbacks)] [(thread? child) - (swap-in-thread child callbacks)] + (swap-in-thread child leftover-ticks callbacks)] [else (loop child callbacks (lambda (pending-callbacks) (loop g none-k pending-callbacks)))]))) -(define (swap-in-thread t callbacks) +(define (swap-in-thread t leftover-ticks callbacks) (define e (thread-engine t)) (set-thread-engine! t 'running) (set-thread-sched-info! t #f) @@ -100,7 +100,7 @@ (when atomic-timeout-callback (when (positive? (current-atomic)) (atomic-timeout-callback #f)))) - (lambda args + (lambda (remaining-ticks . args) (start-implicit-atomic-mode) (accum-cpu-time! t #t) (set-thread-future! t #f) @@ -113,19 +113,20 @@ (when (eq? root-thread t) (force-exit 0)) (thread-did-work!) - (select-thread!)) - (lambda (e timeout?) + (select-thread! (- leftover-ticks (- TICKS remaining-ticks)))) + (lambda (e remaining-ticks) (start-implicit-atomic-mode) (cond [(zero? (current-atomic)) - (accum-cpu-time! t timeout?) + (define new-leftover-ticks (- leftover-ticks (- TICKS remaining-ticks))) + (accum-cpu-time! t (new-leftover-ticks . <= . 0)) (set-thread-future! t (current-future)) (current-thread/in-atomic #f) (current-future #f) (set-place-current-thread! current-place #f) (unless (eq? (thread-engine t) 'done) (set-thread-engine! t e)) - (select-thread!)] + (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., @@ -141,7 +142,7 @@ (do-make-thread 'scheduler-make-thread void #:custodian #f) - (select-thread! callbacks)] + (select-thread! 0 callbacks)] [(and (not (sandman-any-sleepers?)) (not (any-idle-waiters?))) ;; all threads done or blocked @@ -151,12 +152,21 @@ ;; blocked, but it's not going to become unblocked; ;; sleep forever or until a signal changes things (process-sleep) - (select-thread!)] + (select-thread! 0)] [else (void)])] [else ;; try again, which should lead to `process-sleep` - (select-thread!)])) + (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])) ;; Check for threads that have been suspended until a particular time, ;; etc., as registered with the sandman @@ -187,7 +197,7 @@ (engine-block)) (lambda args (internal-error "thread ended while it should run callbacks atomically")) - (lambda (e timeout?) + (lambda (e remaining) (start-implicit-atomic-mode) (if done? (k e)