From 52eea88fdbcae622d13eebee7c48e9353f3c832d Mon Sep 17 00:00:00 2001
From: Matt Birkholz <puck@birchwood-abbey.net>
Date: Sun, 5 Jul 2015 09:21:17 -0700
Subject: [PATCH] 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.
---
 src/edwin/edwin.pkg   |   5 ++
 src/edwin/process.scm | 138 ++++++++++++++-------------------
 src/edwin/tterm.scm   |  55 +++++++++-----
 src/edwin/xterm.scm   | 173 ++++++++++++++++++++++--------------------
 4 files changed, 192 insertions(+), 179 deletions(-)

diff --git a/src/edwin/edwin.pkg b/src/edwin/edwin.pkg
index 51a1da853..811069443 100644
--- 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 652442034..c5a05bfe5 100644
--- 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)))))
 
 (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."
 
 ;;;; 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))))))
 
 (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)))))
 
+(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 84651d1c1..f57b3dd3b 100644
--- 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 416ebd8bf..c6454bc21 100644
--- a/src/edwin/xterm.scm
+++ b/src/edwin/xterm.scm
@@ -496,24 +496,23 @@ USA.
 		      (guarantee-result)))))))))))
 
 (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?))))))))))
-
-(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)))))))
+
+(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))))
 
 (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."
 
 ;;;; 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))
-- 
2.25.1