smp: Punt "permanent" i/o thread events.

A "permanent" input channel in the system select registry will cause
the io-waiter to spin until a thread reads the available input.
Always removing an entry after its event is delivered allows the
io-waiter to block until the thread processes the event, reads the
available input, and blocks again.

diff --git a/src/runtime/thread.scm b/src/runtime/thread.scm
index 89e0ee9b74f866c784c2f401ac1cf54bf09026db..aec8de6a0dede516037cb93e1338a5c82b04fd19 100644 (file)
--- a/src/runtime/thread.scm
+++ b/src/runtime/thread.scm
@@ -489,7 +489,7 @@ USA.
        (dynamic-unwind thread)
        (%lock)
        (ring/discard-all (thread/pending-events thread))
-       (%deregister-io-thread-events thread #t)
+       (%deregister-io-thread-events thread)
        (%discard-thread-timer-records thread)
        (%disassociate-joined-threads thread)
        (%disassociate-thread-mutexes thread)
@@ -582,13 +582,12 @@ USA.
   next)
 
 (define-structure (tentry (conc-name tentry/)
-                         (constructor make-tentry (thread event permanent?)))
-  dentry
-  thread
-  event
-  (permanent? #f read-only #t)
-  prev
-  next)
+                         (constructor make-tentry (thread event)))
+  (dentry #f)
+  (thread () read-only #t)
+  (event () read-only #t)
+  (prev #f)
+  (next #f))
 
 (define (reset-threads!)
   (reset-threads-low!)
@@ -669,68 +668,71 @@ USA.
 
 (define (block-on-io-descriptor descriptor mode)
   (let ((result 'INTERRUPT)
-       (registration-1)
-       (registration-2))
-    (dynamic-wind
-     (lambda ()
-       (with-threads-locked
-       (lambda ()
-         (let ((thread (%current-thread (%id))))
-           (set! registration-1
-                 (%register-io-thread-event
-                  descriptor
-                  mode
-                  thread
-                  (lambda (mode)
-                    (set! result mode)
-                    unspecific)
-                  #f #t))
-           (set! registration-2
-                 (%register-io-thread-event
-                  'PROCESS-STATUS-CHANGE
-                  'READ
-                  thread
-                  (lambda (mode)
-                    mode
-                    (set! result 'PROCESS-STATUS-CHANGE)
-                    unspecific)
-                  #f #t)))
-       (%maybe-toggle-thread-timer))))
-     (lambda ()
-       (%suspend-current-thread)
-       result)
-     (lambda ()
-       (with-threads-locked
-       (lambda ()
-         (%maybe-deregister-io-thread-event registration-2)
-         (%maybe-deregister-io-thread-event registration-1)
-         (%maybe-toggle-thread-timer)))))))
+       (thread (current-thread)))
+    (let ((registration-1 (make-tentry
+                          thread
+                          (lambda (mode)
+                            (set! result mode)
+                            unspecific)))
+         (registration-2 (make-tentry
+                          thread
+                          (lambda (mode)
+                            (declare (ignore mode))
+                            (set! result 'PROCESS-STATUS-CHANGE)
+                            unspecific))))
+      (dynamic-wind
+       (lambda ()
+        (with-threads-locked
+         (lambda ()
+           (%register-io-thread-event descriptor mode registration-1 #t)
+           (%register-io-thread-event 'PROCESS-STATUS-CHANGE 'READ
+                                      registration-2 #t)
+           (%maybe-toggle-thread-timer))))
+       (lambda ()
+        (%suspend-current-thread)
+        result)
+       (lambda ()
+        (with-threads-locked
+         (lambda ()
+           (%maybe-deregister-io-thread-event registration-2)
+           (%maybe-deregister-io-thread-event registration-1)
+           (%maybe-toggle-thread-timer))))))))
 
 (define (%maybe-deregister-io-thread-event tentry)
   ;; Ensure that another thread does not unwind our registration.
   (assert-locked '%maybe-deregister-io-thread-event)
-  (if (eq? (%current-thread (%id)) (tentry/thread tentry))
+  (if (and (tentry/dentry tentry)
+          (eq? (%current-thread (%id)) (tentry/thread tentry)))
       (delete-tentry! tentry)))
 \f
 (define (permanently-register-io-thread-event descriptor mode thread event)
-  (register-io-thread-event-1 descriptor mode thread event
-                             #t 'PERMANENTLY-REGISTER-IO-THREAD-EVENT))
+  (guarantee-select-mode mode 'permanently-register-io-thread-event)
+  (guarantee-thread thread 'permanently-register-io-thread-event)
+  (let ((registration))
+    (set! registration
+         (make-tentry thread
+                      (lambda (mode*)
+                        (event mode*)
+                        (with-threads-locked
+                         (lambda ()
+                           (%register-io-thread-event descriptor mode
+                                                      registration #f)
+                           (%maybe-toggle-thread-timer))))))
+    (with-threads-locked
+     (lambda ()
+       (%register-io-thread-event descriptor mode registration #f)
+       (%maybe-toggle-thread-timer)))
+    registration))
 
 (define (register-io-thread-event descriptor mode thread event)
-  (register-io-thread-event-1 descriptor mode thread event
-                             #f 'REGISTER-IO-THREAD-EVENT))
-
-(define (register-io-thread-event-1 descriptor mode thread event
-                                   permanent? caller)
-  (guarantee-select-mode mode caller)
-  (guarantee-thread thread caller)
-  (with-threads-locked
-   (lambda ()
-     (let ((registration
-           (%register-io-thread-event descriptor mode thread event
-                                      permanent? #f)))
-       (%maybe-toggle-thread-timer)
-       registration))))
+  (guarantee-select-mode mode 'register-io-thread-event)
+  (guarantee-thread thread 'register-io-thread-event)
+  (let ((registration (make-tentry thread event)))
+    (with-threads-locked
+     (lambda ()
+       (%register-io-thread-event descriptor mode registration #f)
+       (%maybe-toggle-thread-timer)))
+    registration))
 
 (define (deregister-io-thread-event tentry)
   (if (not (tentry? tentry))
@@ -793,51 +795,48 @@ USA.
   (%maybe-toggle-thread-timer)
   (%unlock))
 \f
-(define (%register-io-thread-event descriptor mode thread event permanent?
-                                  front?)
+(define (%register-io-thread-event descriptor mode tentry front?)
   (assert-locked '%register-io-thread-event)
-  (let ((tentry (make-tentry thread event permanent?)))
-    (let loop ((dentry io-registrations))
-      (cond ((not dentry)
-            (let ((dentry
-                   (make-dentry descriptor
-                                mode
-                                tentry
-                                tentry
-                                #f
-                                io-registrations)))
-              (set-tentry/dentry! tentry dentry)
-              (set-tentry/prev! tentry #f)
-              (set-tentry/next! tentry #f)
-              (if io-registrations
-                  (set-dentry/prev! io-registrations dentry))
-              (set! io-registrations dentry)
-              (if (not (eq? 'PROCESS-STATUS-CHANGE descriptor))
-                  (add-to-select-registry! io-registry descriptor mode))))
-           ((and (eqv? descriptor (dentry/descriptor dentry))
-                 (eq? mode (dentry/mode dentry)))
+  (let loop ((dentry io-registrations))
+    (cond ((not dentry)
+          (let ((dentry
+                 (make-dentry descriptor
+                              mode
+                              tentry
+                              tentry
+                              #f
+                              io-registrations)))
             (set-tentry/dentry! tentry dentry)
-            (if front?
-                (let ((next (dentry/first-tentry dentry)))
-                  (set-tentry/prev! tentry #f)
-                  (set-tentry/next! tentry next)
-                  (set-dentry/first-tentry! dentry tentry)
-                  (set-tentry/prev! next tentry))
-                (let ((prev (dentry/last-tentry dentry)))
-                  (set-tentry/prev! tentry prev)
-                  (set-tentry/next! tentry #f)
-                  (set-dentry/last-tentry! dentry tentry)
-                  (set-tentry/next! prev tentry))))
-           (else
-            (loop (dentry/next dentry)))))
-    tentry))
+            (set-tentry/prev! tentry #f)
+            (set-tentry/next! tentry #f)
+            (if io-registrations
+                (set-dentry/prev! io-registrations dentry))
+            (set! io-registrations dentry)
+            (if (not (eq? 'PROCESS-STATUS-CHANGE descriptor))
+                (add-to-select-registry! io-registry descriptor mode))))
+         ((and (eqv? descriptor (dentry/descriptor dentry))
+               (eq? mode (dentry/mode dentry)))
+          (set-tentry/dentry! tentry dentry)
+          (if front?
+              (let ((next (dentry/first-tentry dentry)))
+                (set-tentry/prev! tentry #f)
+                (set-tentry/next! tentry next)
+                (set-dentry/first-tentry! dentry tentry)
+                (set-tentry/prev! next tentry))
+              (let ((prev (dentry/last-tentry dentry)))
+                (set-tentry/prev! tentry prev)
+                (set-tentry/next! tentry #f)
+                (set-dentry/last-tentry! dentry tentry)
+                (set-tentry/next! prev tentry))))
+         (else
+          (loop (dentry/next dentry))))))
 
 (define (%deregister-io-thread-event tentry)
   (assert-locked '%deregister-io-thread-event)
   (if (tentry/dentry tentry)
       (delete-tentry! tentry)))
 
-(define (%deregister-io-thread-events thread permanent?)
+(define (%deregister-io-thread-events thread)
   (assert-locked '%deregister-io-thread-events)
   (let loop ((dentry io-registrations) (tentries '()))
     (if (not dentry)
@@ -850,9 +849,7 @@ USA.
                (if (not tentry)
                    tentries
                    (loop (tentry/next tentry)
-                         (if (and (eq? thread (tentry/thread tentry))
-                                  (or permanent?
-                                      (not (tentry/permanent? tentry))))
+                         (if (eq? thread (tentry/thread tentry))
                              (cons tentry tentries)
                              tentries))))))))
 
@@ -892,34 +889,18 @@ USA.
                                         (and e
                                              (lambda () (e mode)))))
                                 events)))
-                     (if (tentry/permanent? tentry)
-                         (move-tentry-to-back! tentry)
-                         (delete-tentry! tentry))
+                     (delete-tentry! tentry)
                      (loop (fix:+ i 1) events))))))
          (do ((events events (cdr events)))
              ((not (pair? events)))
            (%signal-thread-event (caar events) (cdar events)))))))
 
-(define (move-tentry-to-back! tentry)
-  (assert-locked 'move-tentry-to-back!)
-  (let ((next (tentry/next tentry)))
-    (if next
-       (let ((dentry (tentry/dentry tentry))
-             (prev (tentry/prev tentry)))
-         (set-tentry/prev! tentry (dentry/last-tentry dentry))
-         (set-tentry/next! tentry #f)
-         (set-dentry/last-tentry! dentry tentry)
-         (set-tentry/prev! next prev)
-         (if (not prev) (set-dentry/first-tentry! dentry next))))))
-
 (define (delete-tentry! tentry)
   (assert-locked 'delete-tentry!)
   (let ((dentry (tentry/dentry tentry))
        (prev (tentry/prev tentry))
        (next (tentry/next tentry)))
     (set-tentry/dentry! tentry #f)
-    (set-tentry/thread! tentry #f)
-    (set-tentry/event! tentry #f)
     (set-tentry/prev! tentry #f)
     (set-tentry/next! tentry #f)
     (if prev
@@ -1173,7 +1154,7 @@ USA.
            (block-events? (thread/block-events? thread)))
       (set-thread/block-events?! thread #t)
       (ring/discard-all (thread/pending-events thread))
-      (%deregister-io-thread-events thread #f)
+      (%deregister-io-thread-events thread)
       (%discard-thread-timer-records thread)
       (set-thread/block-events?! thread block-events?))
      (%maybe-toggle-thread-timer))))