Reimplement permanently-register-io-thread-event for SMPability.

Remove permanent tentries (waiting thread entries) from
io-registrations.  Replace them with an event wrapper that loops,
re-registering after the wrapped event finishes.  The loop assumes IO
is being consumed during the event.  If not, it may spin forever.

Remove the notion of registering for the "front" of the queue too.

The X graphics device must take care to de-register its IO event
before closing the display, else the thread system may apply test-
select-registry to a closed descriptor.

diff --git a/src/runtime/thread.scm b/src/runtime/thread.scm
index 8bd9bafb92b0173bbff7416e98c6d8470eaec784..64d9f9bc5a954c17d3e1f554ecbed5212c13b62e 100644 (file)
--- a/src/runtime/thread.scm
+++ b/src/runtime/thread.scm
@@ -415,7 +415,7 @@ USA.
     (set-thread/block-events?! thread #t)
     (ring/discard-all (thread/pending-events thread))
     (translate-to-state-point (thread/root-state-point 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)
@@ -475,7 +475,7 @@ USA.
      (del-assq! thread (thread/joined-threads (car threads)))))
   (set-thread/joined-to! thread '()))
 \f
-;;;; I/O Thread Events
+;;;; IO Thread Events
 
 (define io-registry)
 (define io-registrations)
@@ -489,11 +489,10 @@ USA.
   next)
 
 (define-structure (tentry (conc-name tentry/)
-                         (constructor make-tentry (thread event permanent?)))
+                         (constructor make-tentry (thread event)))
   dentry
   thread
   event
-  (permanent? #f read-only #t)
   prev
   next)
 
@@ -558,8 +557,7 @@ USA.
                   thread
                   (lambda (mode)
                     (set! result mode)
-                    unspecific)
-                  #f #t))
+                    unspecific)))
            (set! registration-2
                  (%register-io-thread-event
                   'PROCESS-STATUS-CHANGE
@@ -568,8 +566,7 @@ USA.
                   (lambda (mode)
                     mode
                     (set! result 'PROCESS-STATUS-CHANGE)
-                    unspecific)
-                  #f #t)))
+                    unspecific))))
          (%maybe-toggle-thread-timer))
        (lambda ()
          (%suspend-current-thread)
@@ -585,28 +582,52 @@ USA.
       (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))
+  (let ((stop? #f)
+       (registration #f))
+    (letrec ((handler
+             (named-lambda (permanent-io-event mode*)
+               (if (not stop?)
+                   (event mode*))
+               (if (not (or stop? (memq mode* '(ERROR HANGUP #F))))
+                   (register))))
+            (register
+             (lambda ()
+               (deregister)
+               (if (not stop?)
+                   (set! registration
+                         (register-io-thread-event descriptor mode
+                                                   thread handler)))))
+            (deregister
+             (lambda ()
+               (if registration
+                   (begin
+                     (deregister-io-thread-event registration)
+                     (set! registration #f))))))
+      (register)
+      (cons 'DEREGISTER-PERMANENT-IO-EVENT
+           (lambda ()
+             (set! stop? #t)
+             (deregister))))))
 
 (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)
+  (guarantee-select-mode mode 'REGISTER-IO-THREAD-EVENT)
+  (guarantee-thread thread 'REGISTER-IO-THREAD-EVENT)
   (without-interrupts
    (lambda ()
      (let ((registration
-           (%register-io-thread-event descriptor mode thread event
-                                      permanent? #f)))
+           (%register-io-thread-event descriptor mode thread event)))
        (%maybe-toggle-thread-timer)
        registration))))
 
-(define (deregister-io-thread-event tentry)
+(define (deregister-io-thread-event registration)
+  (if (and (pair? registration)
+          (eq? (car registration) 'DEREGISTER-PERMANENT-IO-EVENT))
+      ((cdr registration))
+      (deregister-io-thread-event* registration)))
+
+(define (deregister-io-thread-event* tentry)
   (if (not (tentry? tentry))
-      (error:wrong-type-argument tentry "I/O thread event registration"
+      (error:wrong-type-argument tentry "IO thread event registration"
                                 'DEREGISTER-IO-THREAD-EVENT))
   (without-interrupts
    (lambda ()
@@ -663,9 +684,8 @@ USA.
           (dloop (dentry/next dentry)))))
   (%maybe-toggle-thread-timer))
 \f
-(define (%register-io-thread-event descriptor mode thread event permanent?
-                                  front?)
-  (let ((tentry (make-tentry thread event permanent?)))
+(define (%register-io-thread-event descriptor mode thread event)
+  (let ((tentry (make-tentry thread event)))
     (let loop ((dentry io-registrations))
       (cond ((not dentry)
             (let ((dentry
@@ -686,17 +706,11 @@ USA.
            ((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))))
+            (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))
@@ -705,7 +719,7 @@ USA.
   (if (tentry/dentry tentry)
       (delete-tentry! tentry)))
 
-(define (%deregister-io-thread-events thread permanent?)
+(define (%deregister-io-thread-events thread)
   (let loop ((dentry io-registrations) (tentries '()))
     (if (not dentry)
        (do ((tentries tentries (cdr tentries)))
@@ -717,9 +731,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))))))))
 
@@ -758,25 +770,12 @@ 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)
-  (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)
   (let ((dentry (tentry/dentry tentry))
        (prev (tentry/prev tentry))
@@ -1010,7 +1009,7 @@ USA.
     (let ((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)

diff --git a/src/runtime/x11graph.scm b/src/runtime/x11graph.scm
index 8db486d6b334c923067c0044b7d7f506836812e6..d47b5d005f8555d1a3f69df1a9e552ded1504974 100644 (file)
--- a/src/runtime/x11graph.scm
+++ b/src/runtime/x11graph.scm
@@ -232,6 +232,7 @@ USA.
                                       x-window/xw
                                       set-x-window/xw!)
                    read-only #t)
+  (previewer-registration #f)
   (event-queue (make-queue))
   (properties (make-1d-table) read-only #t))
 
@@ -257,7 +258,7 @@ USA.
              (error "Unable to open display:" name))
          (let ((display (make-x-display name xd)))
            (add-to-gc-finalizer! display-finalizer display)
-           (make-event-previewer display)
+           (register-event-previewer! display)
            display)))))
 
 (define (x-graphics/close-display display)
@@ -266,12 +267,17 @@ USA.
      (if (x-display/xd display)
         (begin
           (remove-all-from-gc-finalizer! (x-display/window-finalizer display))
+          (let ((registration (x-display/previewer-registration display)))
+            (if registration
+                (begin
+                  (deregister-io-thread-event registration)
+                  (set-x-display/previewer-registration! display #f))))
           (remove-from-gc-finalizer! display-finalizer display))))))
 
 (define (x-graphics/open-display? display)
   (if (x-display/xd display) #t #f))
 \f
-(define (make-event-previewer display)
+(define (register-event-previewer! display)
   (let ((registration))
     (set! registration
          (permanently-register-io-thread-event
@@ -301,7 +307,7 @@ USA.
                        (if event
                            (begin (process-event display event)
                                   (loop))))))))))))
-    registration))
+    (set-x-display/previewer-registration! display registration)))
 
 (define (read-event display)
   (letrec ((loop