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 b559d5633b6d7ad776f58f26875b37ac7af1ad9c..cb38f658f672e8e73959dab7802b1c68f63f033c 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 8c63693f9a3250f4622dd49670c69dc377b3f138..9b8e5b39a486a53a36110d1422df0c31f32d58b5 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 308cc7ff11ef728a17428ce41b1e4ed109448f51..5bf4077a623cda1f22d35a930772ef9dd026275f 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 e4930b1c8dc1cc2bd73c0678c1b59e43bd9e9988..cc7b474f8a78e2be84219e3676de53217985ba92 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))