smp: Wake io-waiter when necessary. Add io-waiter-registry...

...a copy of io-registry for io-waiter to block on while other threads
modify io-registry.  Test io-registry in thread-timer-interrupt-
handler only when there is no io-waiter.

diff --git a/src/runtime/runtime.pkg b/src/runtime/runtime.pkg
index c02f25f610510d8d5e1a5d4b7ad10b81b720a9c4..a937dd7e857868ee1afa0a67284312d7d847fc49 100644 (file)
--- a/src/runtime/runtime.pkg
+++ b/src/runtime/runtime.pkg
@@ -3290,6 +3290,7 @@ USA.
          have-select?
          make-select-registry
          remove-from-select-registry!
+         select-registry-length
          test-select-registry)
   (import (runtime thread)
          %deregister-io-descriptor)

diff --git a/src/runtime/thread.scm b/src/runtime/thread.scm
index 3195a8abcb1a8114a9aa8e4eac336296d202a76b..ef8ea6e28aa9643b9957cae31eccbba98c0af420 100644 (file)
--- a/src/runtime/thread.scm
+++ b/src/runtime/thread.scm
@@ -418,6 +418,8 @@ USA.
     (%%trace ";"id" thread-timer: interrupt in "old"\n")
     (set! next-scheduled-timeout #f)
     (deliver-timer-events)
+    (if (eq? id io-waiter)
+       (set! io-waiter #f))
     (maybe-signal-io-thread-events)
     (maybe-signal-subprocess-status)
     (cond ((and (not first-runnable-thread) (not old))
@@ -492,6 +494,7 @@ USA.
        (%lock)
        (ring/discard-all (thread/pending-events thread))
        (%deregister-io-thread-events thread)
+       (%maybe-wake-io-waiter)
        (%discard-thread-timer-records thread)
        (%disassociate-joined-threads thread)
        (%disassociate-thread-mutexes thread)
@@ -616,9 +619,13 @@ USA.
   (set! io-registry (and ((ucode-primitive have-select? 0))
                         (make-select-registry)))
   (set! io-registrations #f)
+  (set! io-waiter-registry (and ((ucode-primitive have-select? 0))
+                               enable-smp?
+                               (make-select-registry)))
   (set! io-waiter #f))
 
 (define io-waiter)
+(define io-waiter-registry)
 
 (define (%maybe-wake-idle-processor id)
   (%%trace ";"id" %maybe-wake-idle-processor\n")
@@ -635,6 +642,14 @@ USA.
                ((ucode-primitive smp-wake 1) id*))
              (loop (fix:1+ id*)))))))
 
+(define (%maybe-wake-io-waiter)
+  ;; The io-registry's length is cached when io-waiter copies it.  The
+  ;; cache is cleared by any change (in membership OR mode).  Use it
+  ;; to decide whether io-waiter needs to be interrupted.
+  (if (and io-waiter
+          (not (select-registry-length io-registry)))
+      ((ucode-primitive smp-wake 1) io-waiter)))
+
 (define (wait-for-io id)
   ;; This procedure never returns.
   (%%trace ";"id" wait-for-io\n")
@@ -661,11 +676,16 @@ USA.
   (%maybe-toggle-thread-timer #f)
   (%%trace ";"id" io-waiter-wait: next timeout = "next-scheduled-timeout"\n")
   (let ((result
-        (begin
+        (let ((registry
+               (if enable-smp?
+                   (begin
+                     (copy-select-registry! io-registry io-waiter-registry)
+                     io-waiter-registry)
+                   io-registry)))
           (%%trace ";"id" io-waiter-wait: blocking for i/o\n")
           (%unlock)
           (set-interrupt-enables! interrupt-mask/all)
-          (test-select-registry io-registry #t))))
+          (test-select-registry registry #t))))
     (set-interrupt-enables! interrupt-mask/gc-ok)
     (%lock)
     (signal-select-result result)
@@ -697,12 +717,15 @@ USA.
   (signal-io-thread-events 1 '#(PROCESS-STATUS-CHANGE) '#(READ)))
 
 (define (maybe-signal-io-thread-events)
-  (%%trace ";"(%%id)" maybe-signal-io-thread-events: testing\n")
   (assert-locked 'maybe-signal-io-thread-events)
-  (let ((result (test-select-registry io-registry #f)))
-    (signal-select-result result)
-    (%%trace ";"(%%id)" maybe-signal-io-thread-events => "
-            (if (vector? result) (vector-ref result 0) result)"\n")))
+  (if (not io-waiter)
+      (begin
+       (%%trace ";"(%%id)" maybe-signal-io-thread-events: testing\n")
+       (let ((result (test-select-registry io-registry #f)))
+         (signal-select-result result)
+         (%%trace ";"(%%id)" maybe-signal-io-thread-events => "
+                  (if (vector? result) (vector-ref result 0) result)"\n")))
+      (%%trace ";"(%%id)" maybe-signal-io-thread-events: punting\n")))
 
 (define (maybe-signal-subprocess-status)
   (assert-locked 'maybe-signal-subprocess-status)
@@ -730,7 +753,8 @@ USA.
            (%register-io-thread-event descriptor mode registration-1 #t)
            (%register-io-thread-event 'PROCESS-STATUS-CHANGE 'READ
                                       registration-2 #t)
-           (%maybe-toggle-thread-timer))))
+           (%maybe-toggle-thread-timer)
+           (%maybe-wake-io-waiter))))
        (lambda ()
         (%suspend-current-thread)
         result)
@@ -739,7 +763,8 @@ USA.
          (lambda ()
            (%maybe-deregister-io-thread-event registration-2)
            (%maybe-deregister-io-thread-event registration-1)
-           (%maybe-toggle-thread-timer))))))))
+           (%maybe-toggle-thread-timer)
+           (%maybe-wake-io-waiter))))))))
 
 (define (%maybe-deregister-io-thread-event tentry)
   ;; Ensure that another thread does not unwind our registration.
@@ -760,11 +785,13 @@ USA.
                          (lambda ()
                            (%register-io-thread-event descriptor mode
                                                       registration #f)
-                           (%maybe-toggle-thread-timer))))))
+                           (%maybe-toggle-thread-timer)
+                           (%maybe-wake-io-waiter))))))
     (with-threads-locked
      (lambda ()
        (%register-io-thread-event descriptor mode registration #f)
-       (%maybe-toggle-thread-timer)))
+       (%maybe-toggle-thread-timer)
+       (%maybe-wake-io-waiter)))
     registration))
 
 (define (register-io-thread-event descriptor mode thread event)
@@ -774,7 +801,8 @@ USA.
     (with-threads-locked
      (lambda ()
        (%register-io-thread-event descriptor mode registration #f)
-       (%maybe-toggle-thread-timer)))
+       (%maybe-toggle-thread-timer)
+       (%maybe-wake-io-waiter)))
     registration))
 
 (define (deregister-io-thread-event tentry)
@@ -784,7 +812,8 @@ USA.
   (with-threads-locked
    (lambda ()
      (%deregister-io-thread-event tentry)
-     (%maybe-toggle-thread-timer))))
+     (%maybe-toggle-thread-timer)
+     (%maybe-wake-io-waiter))))
 
 (define (deregister-io-descriptor-events descriptor mode)
   (guarantee-select-mode mode 'DEREGISTER-IO-DESCRIPTOR-EVENTS)
@@ -806,7 +835,8 @@ USA.
                    (set-dentry/prev! next prev))))
             (else
              (loop (dentry/next dentry)))))
-     (%maybe-toggle-thread-timer))))
+     (%maybe-toggle-thread-timer)
+     (%maybe-wake-io-waiter))))
 
 (define (%deregister-io-descriptor descriptor)
   (%lock)
@@ -836,6 +866,7 @@ USA.
          (else
           (dloop (dentry/next dentry)))))
   (%maybe-toggle-thread-timer)
+  (%maybe-wake-io-waiter)
   (%unlock))
 \f
 (define (%register-io-thread-event descriptor mode tentry front?)
@@ -1194,7 +1225,8 @@ USA.
       (%deregister-io-thread-events thread)
       (%discard-thread-timer-records thread)
       (set-thread/block-events?! thread block-events?))
-     (%maybe-toggle-thread-timer))))
+     (%maybe-toggle-thread-timer)
+     (%maybe-wake-io-waiter))))
 
 (define (%discard-thread-timer-records thread)
   (assert-locked '%discard-thread-timer-records)