From: Matt Birkholz Date: Sat, 18 Jul 2015 23:04:44 +0000 (-0700) Subject: Add io-waiter, the *one* processor that waits on the io-registry. X-Git-Url: https://birchwood-abbey.net/git?a=commitdiff_plain;h=b615caebb304fda488072d3a582cc7d2f008811f;p=mit-scheme.git Add io-waiter, the *one* processor that waits on the io-registry. The other processors use the new SMP-IDLE primitive to wait for runnable threads. Wake one of these whenever threads become runnable. Wake the io-waiter whenever the io-registry is changed. --- diff --git a/src/runtime/thread.scm b/src/runtime/thread.scm index 4a2181f68..88cd53bf8 100644 --- a/src/runtime/thread.scm +++ b/src/runtime/thread.scm @@ -210,7 +210,8 @@ USA. (define (reset-threads-high!) (set! io-registry (and have-select? (make-select-registry))) (set! io-registrations #f) - (set! subprocess-registrations '())) + (set! subprocess-registrations '()) + (set! io-waiter #f)) (define (without-preemption thunk) (let* ((thread (current-thread)) @@ -368,6 +369,7 @@ USA. (define (thread-running thread) (%thread-running thread) + (%maybe-wake-idle-processor (%id)) (%maybe-toggle-thread-timer)) (define (%thread-running thread) @@ -391,6 +393,8 @@ USA. (define (run-first-thread id) (%assert-locked 'run-first-thread) (%assert (not (%thread id)) "run-first-thread: still running a thread") + (if (eq? id io-waiter) + (set! io-waiter #f)) (if first-runnable-thread (let ((thread first-runnable-thread)) (%assert (thread/continuation thread) @@ -404,6 +408,7 @@ USA. "run-first-thread: lost last-runnable")) (set-thread/next! thread #f) (vector-set! current-threads id thread) + (%maybe-wake-idle-processor id) (run-thread thread)) (wait-for-io id))) @@ -424,7 +429,6 @@ USA. (if (not (thread/block-events? thread)) (begin (handle-thread-events thread) - (%maybe-toggle-thread-timer) (set-thread/block-events?! thread #f))) (unlock)) @@ -434,21 +438,22 @@ USA. (thread (%thread id)) (block-events? (thread/block-events? thread))) ;;(%assert block-events? "suspend-current-thread: not blocking events!") + (%signal-io-events) + (%maybe-wake-io-waiter id) + (%maybe-wake-idle-processor id) + (%maybe-toggle-thread-timer) (suspend-thread id thread) (%assert (eq? block-events? (thread/block-events? thread)) - "suspend-current-thread cleared block-events?!"))) + "suspend-current-thread toggled block-events?!"))) (define (suspend-thread id thread) (%assert-locked 'suspend-thread) (let ((block-events? (thread/block-events? thread))) (set-thread/block-events?! thread #f) - (maybe-signal-io-thread-events) (let ((any-events? (handle-thread-events thread))) (set-thread/block-events?! thread block-events?) (if any-events? - (begin - (%maybe-toggle-thread-timer) - (unlock)) + (unlock) (call-with-current-continuation (lambda (continuation) (set-thread/continuation! thread continuation) @@ -501,8 +506,11 @@ USA. (fp-env (and old (enter-default-float-environment old)))) (%lock) (set! next-scheduled-timeout #f) - (deliver-timer-events) - (maybe-signal-io-thread-events) + (%signal-timer-events) + (%signal-io-events) + (%maybe-wake-io-waiter id) + (%maybe-wake-idle-processor id) + (%maybe-toggle-thread-timer) (cond ((not old) (run-first-thread id)) ;; Else we interrupt a running thread (OLD). @@ -522,7 +530,10 @@ USA. ;; Allow preemption now, since the current thread has ;; volunteered to yield control. (set-thread/execution-state! thread 'RUNNING) - (maybe-signal-io-thread-events) + (%signal-io-events) + (%maybe-wake-io-waiter id) + (%maybe-wake-idle-processor id) + (%maybe-toggle-thread-timer) (yield-thread id thread))) (define (yield-thread id thread #!optional fp-env) @@ -560,7 +571,11 @@ USA. (%disassociate-thread-mutexes thread) (if (eq? no-exit-value-marker (thread/exit-value thread)) (release-joined-threads thread value)) - (thread-not-running (%id) thread 'DEAD))) + (let ((id (%id))) + (%maybe-wake-io-waiter id) + (%maybe-wake-idle-processor id) + (%maybe-toggle-thread-timer) + (thread-not-running id thread 'DEAD)))) (define (join-thread thread event-constructor) (guarantee-thread thread 'JOIN-THREAD) @@ -613,6 +628,7 @@ USA. (event ((cdar joined) thread value))) (set-thread/joined-to! joined (delq! thread (thread/joined-to joined))) (%signal-thread-event joined event))) + (%maybe-wake-idle-processor (%id)) (%maybe-toggle-thread-timer)) (define (%disassociate-joined-threads thread) @@ -624,35 +640,50 @@ USA. (del-assq! thread (thread/joined-threads (car threads))))) (set-thread/joined-to! thread '())) -;;;; IO Thread Events +;;;; IO Waiter -(define io-registry) -(define io-registrations) +(define io-waiter) -(define-structure (dentry (conc-name dentry/)) - (descriptor #f read-only #t) - (mode #f read-only #t) - first-tentry - last-tentry - prev - next) - -(define-structure (tentry (conc-name tentry/) - (constructor make-tentry (thread event))) - dentry - thread - event - prev - next) +(define (%maybe-wake-idle-processor id) + (%assert-locked '%maybe-wake-idle-processor) + (%assert (interrupt-mask-ok?) + "%maybe-wake-idle-processor: wrong interrupt mask") + (if first-runnable-thread + (let loop ((id* 0)) + (if (fix:< id* processor-count) + (if (and (not (%thread id*)) + (not (fix:= id* id))) + ((ucode-primitive smp-wake 1) id*) + (loop (fix:1+ id*))))))) + +(define (%maybe-wake-io-waiter id) + (%assert-locked '%maybe-wake-io-waiter) + (if (and io-waiter + (not (eq? id io-waiter))) + ((ucode-primitive smp-wake 1) io-waiter))) (define (wait-for-io id) (%assert-locked 'wait-for-io) (%assert (interrupt-mask-ok?) "wait-for-io: wrong interrupt mask") (%assert (not (%thread id)) "wait-for-io: not idle") - (%maybe-toggle-thread-timer #f) + (if io-waiter + (begin + (%assert (not (eq? id io-waiter)) + "wait-for-io: idling though io-waiter") + (%unlock) + ;; This primitive never returns, but it unmasks all interrupts. + ((ucode-primitive smp-idle 0))) + (begin + (set! io-waiter id) + (io-waiter-wait id)))) + +(define (io-waiter-wait id) + (%assert-locked 'io-waiter-wait) + (%assert (not (%thread id)) "io-waiter-wait: still running a thread") (let ((result (begin (%unlock) (test-select-registry io-registry #t)))) + (%assert (interrupt-mask-ok?) "io-waiter-wait: interrupt enables clobbered") (%lock) (signal-select-result result) (run-first-thread id))) @@ -660,9 +691,9 @@ USA. (define (signal-select-result result) (%assert-locked 'signal-select-result) (cond ((vector? result) - (signal-io-thread-events (vector-ref result 0) - (vector-ref result 1) - (vector-ref result 2))) + (%signal-io-results (vector-ref result 0) + (vector-ref result 1) + (vector-ref result 2))) ((eq? 'PROCESS-STATUS-CHANGE result) (%handle-subprocess-status-change)) ((eq? 'INTERRUPT result) @@ -675,11 +706,33 @@ USA. ;; A simple body (just #t) allows the function call to be optimized away. ((ucode-primitive get-primitive-address 2) 'SMP-COUNT #f)) -(define (maybe-signal-io-thread-events) - (%assert-locked 'maybe-signal-io-thread-events) - (if (or io-registrations - (not (null? subprocess-registrations))) +(define (%signal-io-events) + (%assert-locked '%signal-io-events) + (if (and (not io-waiter) + (or io-registrations + (not (null? subprocess-registrations)))) (signal-select-result (test-select-registry io-registry #f)))) + +;;;; IO Events + +(define io-registry) +(define io-registrations) + +(define-structure (dentry (conc-name dentry/)) + (descriptor #f read-only #t) + (mode #f read-only #t) + first-tentry + last-tentry + prev + next) + +(define-structure (tentry (conc-name tentry/) + (constructor make-tentry (thread event))) + dentry + thread + event + prev + next) (define (block-on-io-descriptor descriptor mode) (let ((result 'INTERRUPT) @@ -740,6 +793,7 @@ USA. (lambda () (let ((registration (%register-io-thread-event descriptor mode thread event))) + (%maybe-wake-io-waiter (%id)) (%maybe-toggle-thread-timer) registration)))) @@ -756,6 +810,7 @@ USA. (with-thread-lock (lambda () (%deregister-io-thread-event tentry) + (%maybe-wake-io-waiter (%id)) (%maybe-toggle-thread-timer)))) (define (deregister-io-descriptor-events descriptor mode) @@ -777,6 +832,7 @@ USA. (set-dentry/prev! next prev)))) (else (loop (dentry/next dentry))))) + (%maybe-wake-io-waiter (%id)) (%maybe-toggle-thread-timer)))) (define (deregister-io-descriptor descriptor close-descriptor!) @@ -817,7 +873,10 @@ USA. (dloop (dentry/next dentry))) (else (dloop (dentry/next dentry))))) - (%maybe-toggle-thread-timer)) + (let ((id (%id))) + (%maybe-wake-io-waiter id) + (%maybe-wake-idle-processor id) + (%maybe-toggle-thread-timer))) (define (%register-io-thread-event descriptor mode thread event) (%assert-locked '%register-io-thread-event) @@ -876,8 +935,8 @@ USA. (if (not (memq mode '(READ WRITE READ-WRITE))) (error:wrong-type-argument mode "select mode" procedure))) -(define (signal-io-thread-events n vfd vmode) - (%assert-locked 'signal-io-thread-events) +(define (%signal-io-results n vfd vmode) + (%assert-locked '%signal-io-results) (let ((search (lambda (descriptor predicate) (let scan-dentries ((dentry io-registrations)) @@ -1000,6 +1059,7 @@ USA. signal-thread-event thread event))) (begin (%signal-thread-event thread event) + (%maybe-wake-idle-processor (%id)) (%maybe-toggle-thread-timer) (unlock))))))) @@ -1044,14 +1104,17 @@ USA. (define (allow-thread-event-delivery) (with-thread-lock (lambda () - (let* ((thread (%thread (%id))) + (let* ((id (%id)) + (thread (%thread id)) (block-events? (thread/block-events? thread))) (set-thread/block-events?! thread #f) - (deliver-timer-events) - (maybe-signal-io-thread-events) + (%signal-timer-events) + (%signal-io-events) + (%maybe-wake-io-waiter id) + (%maybe-wake-idle-processor id) + (%maybe-toggle-thread-timer) (handle-thread-events thread) - (set-thread/block-events?! thread block-events?)) - (%maybe-toggle-thread-timer)))) + (set-thread/block-events?! thread block-events?))))) ;;;; Subprocess Events @@ -1101,8 +1164,8 @@ USA. (if (not block-events?) (unblock-thread-events))))) -(define (deliver-timer-events) - (%assert-locked 'deliver-timer-events) +(define (%signal-timer-events) + (%assert-locked '%signal-timer-events) (let ((time (real-time-clock))) (do ((record timer-records (timer-record/next record))) ((or (not record) (< time (timer-record/time record))) @@ -1133,15 +1196,17 @@ USA. (define (deregister-all-events) (with-thread-lock (lambda () - (let* ((thread (%thread (%id))) + (let* ((id (%id)) + (thread (%thread id)) (block-events? (thread/block-events? thread))) (set-thread/block-events?! thread #t) (ring/discard-all (thread/pending-events thread)) (%deregister-io-thread-events thread) (%discard-thread-timer-records thread) (%deregister-subprocess-events thread) - (set-thread/block-events?! thread block-events?)) - (%maybe-toggle-thread-timer)))) + (set-thread/block-events?! thread block-events?) + (%maybe-wake-io-waiter id) + (%maybe-toggle-thread-timer))))) (define (%discard-thread-timer-records thread) (%assert-locked '%discard-thread-timer-records) @@ -1176,7 +1241,7 @@ USA. (define (with-thread-timer-stopped thunk) (dynamic-wind stop-thread-timer thunk start-thread-timer)) -(define (%maybe-toggle-thread-timer #!optional consider-non-timers?) +(define (%maybe-toggle-thread-timer) (%assert-locked '%maybe-toggle-thread-timer) (let ((now (real-time-clock))) (let ((start @@ -1193,14 +1258,14 @@ USA. ((ucode-primitive request-interrupts! 1) interrupt-bit/timer) (start - (if (and consider-non-timers? timer-interval) + (if timer-interval (min next-event-time (+ now timer-interval)) next-event-time))))) - ((and consider-non-timers? - timer-interval - (or io-registrations - (not (null? subprocess-registrations)) - first-runnable-thread)) + ((and timer-interval + (or first-runnable-thread + (and (not io-waiter) + (or io-registrations + (not (null? subprocess-registrations)))))) (start (+ now timer-interval))) (else (%stop-thread-timer)))))) @@ -1268,7 +1333,7 @@ USA. (begin (ring/enqueue (thread-mutex/waiting-threads mutex) thread) (do () ((eq? thread (thread-mutex/owner mutex))) - (suspend-thread thread) + (suspend-thread (%id) thread) (lock))) (set-thread-mutex/owner! mutex thread))) @@ -1289,7 +1354,9 @@ USA. (%assert-locked '%unlock-thread-mutex) (remove-thread-mutex! owner mutex) (if (%%unlock-thread-mutex mutex) - (%maybe-toggle-thread-timer))) + (begin + (%maybe-wake-idle-processor (%id)) + (%maybe-toggle-thread-timer)))) (define (%%unlock-thread-mutex mutex) (%assert-locked '%%unlock-thread-mutex)