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 4a2181f689bcf8ee10cd3e90f0e85a599379f51a..88cd53bf8ac417e09546044373cf8eff53037aa6 100644 (file)
--- 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)))
 \f
@@ -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 '()))
 \f
-;;;; 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))))
+\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)))
 \f
 (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)))
 \f
-(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?)))))
 \f
 ;;;; 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)