Do NOT use permanently-register-io-thread-event in Edwin.

Edwin does not consume the IO in the thread event.  This worked in a
uni-processing world where another thread could consume the IO in
round-robin fashion, but in an SMPing world there is no way to know
when it is appropriate to signal another event.  In a naive
implementation (without special handling of these events), an idle
processor would spin, queuing MANY "IO ready" events to one thread
until another thread consumed the IO.

Edwin's X11 and console display types now block for IO on multiple
descriptors, the X or tty descriptor PLUS the subprocess output
descriptors.  They no longer use permanent IO thread events to handle
the latter.

Edwin's remaining uses of permanently-register-io-thread-event are in
single-threaded OS2 and Win32 worlds.  The runtime's only uses are in
the OS2 and X11 graphics devices where the IO *is* consumed during the
event.

diff --git a/src/edwin/edwin.pkg b/src/edwin/edwin.pkg
index 51a1da8538a1d0dc2ad2f93fe8ad8b8a71247f55..811069443d04f9f8a7a64d4a9ac1da5b2012260d 100644 (file)
--- a/src/edwin/edwin.pkg
+++ b/src/edwin/edwin.pkg
@@ -984,7 +984,10 @@ USA.
     (parent (edwin screen))
     (export (edwin)
            resize-screen)
+    (import (edwin process)
+           register-process-output-events)
     (import (runtime primitive-io)
+           channel-descriptor-for-select
            %channel-read
            channel-type=terminal?
            have-select?
@@ -1038,6 +1041,8 @@ USA.
            screen-xterm
            xterm-screen/set-icon-name
            xterm-screen/set-name)
+    (import (edwin process)
+           register-process-output-events)
     (initialization (initialize-package!)))
 
   (define-package (edwin x-keys)

diff --git a/src/edwin/process.scm b/src/edwin/process.scm
index 652442034c0bc24e74dd48282de54086b860b632..c5a05bfe54e019094a587b2c10e4fccaffb95dcd 100644 (file)
--- a/src/edwin/process.scm
+++ b/src/edwin/process.scm
@@ -34,7 +34,6 @@ USA.
 (add-event-receiver! editor-initializations
   (lambda ()
     (set! edwin-processes '())
-    (set! process-input-queue (cons '() '()))
     (set-variable! exec-path (os/exec-path))
     (set-variable! shell-file-name (os/shell-file-name))))
 
@@ -79,8 +78,7 @@ Initialized from the SHELL environment variable."
   (filter #f)
   (sentinel #f)
   (kill-without-query #f)
-  (notification-tick (cons #f #f))
-  (input-registration #f))
+  (notification-tick (cons #f #f)))
 
 (define-integrable (process-arguments process)
   (subprocess-arguments (process-subprocess process)))
@@ -127,13 +125,6 @@ Initialized from the SHELL environment variable."
    (let ((buffer (process-buffer process)))
      (and buffer
          (mark-right-inserting-copy (buffer-end buffer))))))
-
-(define (deregister-process-input process)
-  (let ((registration (process-input-registration process)))
-    (if registration
-       (begin
-         (set-process-input-registration! process #f)
-         (deregister-io-thread-event registration)))))
 \f
 (define (start-process name buffer environment program . arguments)
   (let ((make-subprocess
@@ -161,9 +152,7 @@ Initialized from the SHELL environment variable."
                 buffer)))
           (let ((channel (subprocess-input-channel subprocess)))
             (if channel
-                (begin
-                  (channel-nonblocking channel)
-                  (register-process-input process channel))))
+                (channel-nonblocking channel)))
           (update-process-mark! process)
           (subprocess-put! subprocess 'EDWIN-PROCESS process)
           (set! edwin-processes (cons process edwin-processes))
@@ -185,7 +174,6 @@ Initialized from the SHELL environment variable."
           (begin
             (subprocess-kill subprocess)
             (%perform-status-notification process 'SIGNALLED #f)))
-       (deregister-process-input process)
        (let ((buffer (process-buffer process)))
         (if (buffer-alive? buffer)
             (buffer-modeline-event! buffer 'PROCESS-STATUS)))
@@ -214,75 +202,49 @@ Initialized from the SHELL environment variable."
 \f
 ;;;; Input and Output
 
-(define process-input-queue)
-
-(define (register-process-input process channel)
-  (set-process-input-registration!
-   process
-   (permanently-register-io-thread-event
-    (channel-descriptor-for-select channel)
-    'READ
-    (current-thread)
-    (lambda (mode)
-      mode
-      (let ((queue process-input-queue))
-       (if (not (memq process (car queue)))
-           (let ((tail (list process)))
-             (if (null? (cdr queue))
-                 (set-car! queue tail)
-                 (set-cdr! (cdr queue) tail))
-             (set-cdr! queue tail))))))))
-
 (define (process-output-available?)
-  (not (null? (car process-input-queue))))
-
-(define (accept-process-output)
-  (let ((queue process-input-queue))
-    (let loop ((output? #f))
-      (if (null? (car queue))
-         output?
-         (let ((interrupt-mask (set-interrupt-enables! interrupt-mask/gc-ok)))
-           (let ((process (caar queue)))
-             (set-car! queue (cdar queue))
-             (if (null? (car queue))
-                 (set-cdr! queue '()))
-             (let ((output?
-                    (if (poll-process-for-output process #t) #t output?)))
-               (set-interrupt-enables! interrupt-mask)
-               (loop output?))))))))
-
-(define (poll-process-for-output process do-status?)
-  (and (let ((channel (subprocess-input-channel (process-subprocess process))))
-        (and channel
-             (channel-open? channel)))
-       (let ((port (subprocess-input-port (process-subprocess process)))
-            (buffer (make-string 512))
-            (output? #f))
-        (let ((close-input
-               (lambda ()
-                 (deregister-process-input process)
-                 (close-port port)
-                 (if do-status?
-                     (begin
-                       (%update-global-notification-tick)
-                       (if (poll-process-for-status-change process)
-                           (set! output? #t)))))))
-          (let loop ()
-            (let ((n
+  (let loop ((processes edwin-processes))
+    (and (pair? processes)
+        (or (let ((port (subprocess-input-port
+                         (process-subprocess (car processes)))))
+              (and port
+                   (port/open? port)
                    (call-with-current-continuation
                     (lambda (k)
-                      (bind-condition-handler (list condition-type:port-error)
-                          (lambda (condition) condition (k 0))
+                      (bind-condition-handler
+                          (list condition-type:port-error)
+                          (lambda (condition) condition (k #f))
                         (lambda ()
-                          (input-port/read-string! port buffer)))))))
-              (if n
-                  (if (fix:= n 0)
-                      (close-input)
-                      (begin
-                        (if (output-substring process buffer n)
-                            (set! output? #t))
-                        (loop)))))))
-        output?)))
+                          (input-port/peek-char port)))))))
+            (loop (cdr processes))))))
+
+(define (accept-process-output)
+  (let loop ((processes edwin-processes)
+            (output? #f))
+    (if (pair? processes)
+       (loop (or (poll-process-for-output (car processes))
+                 output?)
+             (cdr processes))
+       output?)))
+
+(define input-buffer (make-string 512))
+
+(define (poll-process-for-output process)
+  (let ((port (subprocess-input-port (process-subprocess process))))
+    (and (port/open? port)
+        (let ((n
+               (call-with-current-continuation
+                (lambda (k)
+                  (bind-condition-handler (list condition-type:port-error)
+                      (lambda (condition) condition (k #t))
+                    (lambda ()
+                      (input-port/read-string! port input-buffer)))))))
+          (if (or (not (fixnum? n))
+                  (fix:= n 0))
+              (close-port port)
+              (output-substring process input-buffer n))
+          (and (fixnum? n)
+               (fix:> n 0))))))
 \f
 (define (process-send-eof process)
   (process-send-char process #\EOT))
@@ -337,8 +299,24 @@ Initialized from the SHELL environment variable."
                                      status
                                      (process-exit-reason process)))))
 \f
+(define (register-process-output-events thread event)
+  (append-map!
+   (lambda (process)
+     (let* ((subprocess (process-subprocess process))
+           (channel (subprocess-output-channel subprocess)))
+       (if (channel-open? channel)
+          (list (register-io-thread-event
+                 (channel-descriptor-for-select channel) 'READ
+                 thread event))
+          '())))
+   edwin-processes))
+
 (define (perform-status-notification process status reason)
-  (poll-process-for-output process #f)
+  (if (or (eq? 'EXITED status)
+         (eq? 'SIGNALLED status))
+      (let drain ()
+       (if (poll-process-for-output process)
+           (drain))))
   (let ((value (%perform-status-notification process status reason)))
     (if (and (or (eq? 'EXITED status)
                 (eq? 'SIGNALLED status))

diff --git a/src/edwin/tterm.scm b/src/edwin/tterm.scm
index 84651d1c1785289dc32de5902e4794bf6ae993f6..f57b3dd3bcca0dde7c7059a5d22a1bde163af055 100644 (file)
--- a/src/edwin/tterm.scm
+++ b/src/edwin/tterm.scm
@@ -222,10 +222,7 @@ USA.
                                  (find (cdr key-pairs)
                                        possible-pending?))))))))))
         (read-more?                    ; -> #F or #T if some octets were read
-         (named-lambda (read-more? block?)
-           (if block?
-               (channel-blocking channel)
-               (channel-nonblocking channel))
+         (named-lambda (read-more?)
            (let ((n (%channel-read channel buffer end input-buffer-size)))
              (cond ((not n)  #F)
                    ((eq? n #T) #F)
@@ -239,35 +236,28 @@ USA.
          (named-lambda (match-event block?)
            (let loop ()
              (or (begin
-                   (read-more? #f)
+                   (read-more?)
                    (match-key))
-                 ;; Atomically poll async event sources and block.
-                 (let ((mask (set-interrupt-enables! interrupt-mask/gc-ok)))
+                 ;; Poll event sources and block.
+                 (begin
                    (cond (inferior-thread-changes?
-                          (set-interrupt-enables! mask)
                           (or (->update-event (accept-thread-output))
                               (loop)))
                          ((process-output-available?)
-                          (set-interrupt-enables! mask)
                           (or (->update-event (accept-process-output))
                               (loop)))
                          ((process-status-changes?)
-                          (set-interrupt-enables! mask)
                           (or (->update-event (handle-process-status-changes))
                               (loop)))
                          ((not have-select?)
-                          (set-interrupt-enables! mask)
                           (and block? (loop)))
                          (incomplete-pending
                           ;; Must busy-wait.
-                          (set-interrupt-enables! mask)
                           (loop))
                          (block?
-                          (read-more? #t)
-                          (set-interrupt-enables! mask)
+                          (block-for-event)
                           (loop))
                          (else
-                          (set-interrupt-enables! mask)
                           #f)))))))
         (->update-event
          (named-lambda (->update-event redisplay?)
@@ -309,11 +299,41 @@ USA.
                   match)
                  ((pair? match)
                   (cdr match))
-                 (else (error "Bogus input match:" match))))))
+                 (else (error "Bogus input match:" match)))))
+        (block-for-event
+         (named-lambda (block-for-event)
+           (let ((input-available? #f)
+                 (output-available? #f)
+                 (registrations))
+             (dynamic-wind
+              (lambda ()
+                (let ((thread (current-thread)))
+                  (set! registrations
+                        (cons
+                         (register-io-thread-event
+                          (channel-descriptor-for-select channel) 'READ
+                          thread (lambda (mode)
+                                   mode
+                                   (set! input-available? #t)))
+                         (register-process-output-events
+                          thread (lambda (mode)
+                                   mode
+                                   (set! output-available? #t)))))))
+              (lambda ()
+                (with-thread-events-blocked
+                 (lambda ()
+                   (if (and (not input-available?)
+                            (not output-available?)
+                            (not (process-status-changes?))
+                            (not inferior-thread-changes?))
+                       (suspend-current-thread))))
+                unspecific)
+              (lambda ()
+                (for-each deregister-io-thread-event registrations)))))))
       (values
        (named-lambda (halt-update?)
         (or (fix:< start end)
-            (read-more? #f)))
+            (read-more?)))
        (named-lambda (peek-no-hang)
         (let ((event (->event (match-event #f))))
           (if (input-event? event)
@@ -376,6 +396,7 @@ USA.
     (lambda (get-outside-state)
       (terminal-operation terminal-raw-input
                          (port/input-channel console-i/o-port))
+      (channel-nonblocking (port/input-channel console-i/o-port))
       (terminal-operation terminal-raw-output
                          (port/output-channel console-i/o-port))
       (tty-set-interrupt-enables 2)

diff --git a/src/edwin/xterm.scm b/src/edwin/xterm.scm
index 416ebd8bfca84826820f545be92e518f22c0eec9..c6454bc217c7be53335475b287a7f9de3286c4a2 100644 (file)
--- a/src/edwin/xterm.scm
+++ b/src/edwin/xterm.scm
@@ -496,24 +496,23 @@ USA.
                      (guarantee-result)))))))))))
 \f
 (define (read-event queue display block?)
+  (preview-events display queue)
+  (let ((event
+        (if (queue-empty? queue)
+            (if (eq? 'IN-UPDATE block?)
+                #f
+                (read-event-1 display block?))
+            (dequeue!/unsafe queue))))
+    (if (and event trace-port)
+       (write-line event trace-port))
+    event))
+
+(define (preview-events display queue)
   (let loop ()
-    (set! reading-event? #t)
-    (let ((event
-          (if (queue-empty? queue)
-              (if (eq? 'IN-UPDATE block?)
-                  (x-display-process-events display 2)
-                  (read-event-1 display block?))
-              (dequeue!/unsafe queue))))
-      (set! reading-event? #f)
-      (if (and (vector? event)
-              (fix:= (vector-ref event 0) event-type:expose))
-         (begin
-           (process-expose-event event)
-           (loop))
-         (begin
-           (if (and event trace-port)
-               (write-line event trace-port))
-           event)))))
+    (let ((event (x-display-process-events display 2)))
+      (if event
+         (begin (preview-event event queue)
+                (loop))))))
 
 (define trace-port #f)
 
@@ -542,60 +541,78 @@ USA.
                          (vector-ref event 5))))
 
 (define (read-event-1 display block?)
-  (or (x-display-process-events display 2)
+  ;; Now consider other (non-X) events.
+  (if (eq? '#T block?)
       (let loop ()
-       (let ((interrupt-mask (set-interrupt-enables! interrupt-mask/gc-ok)))
-         (cond (inferior-thread-changes?
-                (set-interrupt-enables! interrupt-mask)
-                event:inferior-thread-output)
-               ((process-output-available?)
-                (set-interrupt-enables! interrupt-mask)
-                event:process-output)
-               ((process-status-changes?)
-                (set-interrupt-enables! interrupt-mask)
-                event:process-status)
-               (else
-                (let ((flag
-                       (test-for-io-on-descriptor
-                        (x-display-descriptor display)
-                        block?
-                        'READ)))
-                  (set-interrupt-enables! interrupt-mask)
-                  (case flag
-                    ((#F) #f)
-                    ((PROCESS-STATUS-CHANGE) event:process-status)
-                    ((INTERRUPT) (loop))
-                    (else (read-event-1 display block?))))))))))
-\f
-(define (preview-event-stream)
-  (set! previewer-registration
-       (permanently-register-io-thread-event
-        (x-display-descriptor x-display-data)
-        'READ
-        (current-thread)
-        (lambda (mode)
-          mode
-          (if (not reading-event?)
-              (let loop ()
-                (let ((event (x-display-process-events x-display-data 2)))
-                  (if event
-                      (begin (preview-event event)
-                             (loop)))))))))
-  unspecific)
+       (let ((event (block-for-event display)))
+         (or event
+             (loop))))
+      (cond (inferior-thread-changes?
+            event:inferior-thread-output)
+           ((process-output-available?)
+            event:process-output)
+           ((process-status-changes?)
+            event:process-status)
+           (else #f))))
+
+(define (block-for-event display)
+  (let ((x-events-available? #f)
+       (output-available? #f)
+       (registrations))
+    (dynamic-wind
+     (lambda ()
+       (let ((thread (current-thread)))
+        (set! registrations
+              (cons
+               (register-io-thread-event
+                (x-display-descriptor display) 'READ
+                thread (lambda (mode)
+                         mode
+                         (set! x-events-available? #t)))
+               (register-process-output-events
+                thread (lambda (mode)
+                         mode
+                         (set! output-available? #t)))))))
+     (lambda ()
+       (let loop ()
+        (with-thread-events-blocked
+         (lambda ()
+           (if (and (not x-events-available?)
+                    (not output-available?)
+                    (not (process-status-changes?))
+                    (not inferior-thread-changes?))
+               (suspend-current-thread))))
+        (cond (x-events-available?
+               (let ((queue x-display-events))
+                 (preview-events display queue)
+                 (if (queue-empty? queue)
+                     #f
+                     (dequeue!/unsafe queue))))
+              ((process-status-changes?)
+               event:process-status)
+              (output-available?
+               event:process-output)
+              (inferior-thread-changes?
+               event:inferior-thread-output)
+              (else
+               (loop)))))
+     (lambda ()
+       (for-each deregister-io-thread-event registrations)
+       (set! registrations)))))
 
 (define (wait-for-event interval predicate process-event)
   (let ((timeout (+ (real-time-clock) interval)))
-    (fluid-let ((reading-event? #t))
-      (let loop ()
-       (let ((event (x-display-process-events x-display-data 2)))
-         (if event
-             (if (and (vector? event) (predicate event))
-                 (or (process-event event) (loop))
-                 (begin (preview-event event) (loop)))
-             (and (< (real-time-clock) timeout)
-                  (loop))))))))
-
-(define (preview-event event)
+    (let loop ()
+      (let ((event (x-display-process-events x-display-data 2)))
+       (if event
+           (if (and (vector? event) (predicate event))
+               (or (process-event event) (loop))
+               (begin (preview-event event x-display-events) (loop)))
+           ;; Busy loop!
+           (and (< (real-time-clock) timeout)
+                (loop)))))))
+\f
+(define (preview-event event queue)
   (cond ((and signal-interrupts?
              (vector? event)
              (fix:= event-type:key-press (vector-ref event 0))
@@ -605,7 +622,7 @@ USA.
                            (merge-bucky-bits (string-ref string 0)
                                              (vector-ref event 3)))
                    (string-find-next-char string #\BEL))))
-        (clean-event-queue x-display-events)
+        (clean-event-queue queue)
         (signal-interrupt!))
        ((and (vector? event)
              (fix:= event-type:expose (vector-ref event 0)))
@@ -616,9 +633,9 @@ USA.
                  (fix:= event-type:visibility (vector-ref event 0))))
         (let ((result (process-special-event event)))
           (if result
-              (enqueue!/unsafe x-display-events result))))
+              (enqueue!/unsafe queue result))))
        (else
-        (enqueue!/unsafe x-display-events event))))
+        (enqueue!/unsafe queue event))))
 
 (define (clean-event-queue queue)
   ;; Flush keyboard and mouse events from the input queue.  Other
@@ -640,8 +657,8 @@ USA.
     (enqueue!/unsafe queue (car events))))
 \f
 (define (process-change-event event)
-  (cond ((fix:= event event:process-output) (accept-process-output))
-       ((fix:= event event:process-status) (handle-process-status-changes))
+  (cond ((fix:= event event:process-status) (handle-process-status-changes))
+       ((fix:= event event:process-output) (accept-process-output))
        ((fix:= event event:inferior-thread-output) (accept-thread-output))
        (else (error "Illegal change event:" event))))
 
@@ -1312,23 +1329,15 @@ Otherwise, it is copied from the primary selection."
 \f
 ;;;; Interrupts
 
-(define reading-event?)
 (define signal-interrupts?)
 (define last-focus-time)
-(define previewer-registration)
 (define ignore-button-state)
 
 (define (with-editor-interrupts-from-x receiver)
-  (fluid-let ((reading-event? #f)
-             (signal-interrupts? #t)
+  (fluid-let ((signal-interrupts? #t)
              (last-focus-time #f)
-             (previewer-registration)
              (ignore-button-state #f))
-    (dynamic-wind
-     preview-event-stream
-     (lambda () (receiver (lambda (thunk) (thunk)) '()))
-     (lambda ()
-       (deregister-io-thread-event previewer-registration)))))
+    (receiver (lambda (thunk) (thunk)) '())))
 
 (define (with-x-interrupts-enabled thunk)
   (with-signal-interrupts #t thunk))