From: Matt Birkholz <matt@birchwood-abbey.net>
Date: Tue, 9 Aug 2016 20:30:39 +0000 (-0700)
Subject: x11-screen: Backport elimination of keyboard busy loop.
X-Git-Tag: mit-scheme-pucked-9.2.12~261^2~1
X-Git-Url: https://birchwood-abbey.net/git?a=commitdiff_plain;h=8dc9dd07967cbd8282622745eba89487a671c032;p=mit-scheme.git

x11-screen: Backport elimination of keyboard busy loop.
---

diff --git a/src/x11-screen/x11-screen.scm b/src/x11-screen/x11-screen.scm
index 17be1a0d1..f82160cca 100644
--- a/src/x11-screen/x11-screen.scm
+++ b/src/x11-screen/x11-screen.scm
@@ -372,49 +372,41 @@ USA.
 				 update-screens!
 				 #f))))
 	(let ((get-next-event
-	       (lambda (block?)
-		 (let loop ()
-		   (let ((event (read-event queue display block?)))
-		     (cond ((or (not event) (input-event? event))
-			    event)
-			   ((not (vector? event))
-			    (let ((flag (process-change-event event)))
-			      (if flag
-				  (pce-event flag)
-				  (loop))))
-			   (else
-			    (or (process-event event)
-				(loop)))))))))
+	       (lambda (msec)
+		 (let ((timeout (and msec (+ (real-time-clock) msec))))
+		   (let loop ()
+		     (let ((event (read-event queue display timeout)))
+		       (cond ((or (not event) (input-event? event))
+			      event)
+			     ((not (vector? event))
+			      (let ((flag (process-change-event event)))
+				(if flag
+				    (pce-event flag)
+				    (loop))))
+			     (else
+			      (or (process-event event)
+				  (loop))))))))))
 	  (let ((probe
-		 (lambda (block?)
-		   (let ((result (get-next-event block?)))
+		 (lambda (msec)
+		   (let ((result (get-next-event msec)))
 		     (if result
 			 (set! pending-result result))
-		     result)))
-		(guarantee-result
-		 (lambda ()
-		   (or (get-next-event #t)
-		       (error "#F returned from blocking read")))))
+		     result))))
 	    (values
 	     (lambda ()			;halt-update?
 	       (or pending-result
 		   (fix:< start end)
-		   (probe 'IN-UPDATE)))
-	     (lambda (timeout)		;peek-no-hang
-	       (keyboard-peek-busy-no-hang
-		(lambda ()
-		  (or pending-result
-		      (and (fix:< start end)
-			   (string-ref string start))
-		      (probe #f)))
-		timeout))
+		   (probe 0)))
+	     (lambda (msec)		;peek-no-hang
+	       (or pending-result
+		   (and (fix:< start end)
+			(string-ref string start))
+		   (probe msec)))
 	     (lambda ()			;peek
 	       (or pending-result
-		   (if (fix:< start end)
-		       (string-ref string start)
-		       (let ((result (guarantee-result)))
-			 (set! pending-result result)
-			 result))))
+		   (and (fix:< start end)
+			(string-ref string start))
+		   (probe #f)))
 	     (lambda ()			;read
 	       (cond (pending-result
 		      => (lambda (result)
@@ -425,26 +417,22 @@ USA.
 			(set! start (fix:+ start 1))
 			char))
 		     (else
-		      (guarantee-result)))))))))))
+		      (or (get-next-event #f)
+			  (error "#F returned from blocking read"))))))))))))
 
-(define (read-event queue display block?)
-  (let loop ()
-    (let* ((empty "empty")
-	   (event* (with-thread-events-blocked
-		    (lambda ()
-		      (if (queue-empty? queue)
-			  empty
-			  (dequeue!/unsafe queue)))))
-	   (event (if (eq? event* empty)
-		      (and (not (memq block? '(IN-UPDATE #f)))
-			   (block-for-event display))
-		      event*)))
-      (if (and event trace-port)
-	  (write-line event trace-port))
-      (or event
-	  (if (memq block? '(IN-UPDATE #f))
-	      #f
-	      (loop))))))
+(define (read-event queue display timeout)
+  (let* ((empty "empty")
+	 (event* (with-thread-events-blocked
+		  (lambda ()
+		    (if (queue-empty? queue)
+			empty
+			(dequeue!/unsafe queue)))))
+	 (event (if (eq? event* empty)
+		    (block-for-event display timeout)
+		    event*)))
+    (if (and event trace-port)
+	(write-line event trace-port))
+    event))
 
 (define trace-port #f)
 
@@ -472,22 +460,31 @@ USA.
 			  (vector-ref event 4)
 			  (vector-ref event 5))))
 
-(define (block-for-event display)
+(define (block-for-event display timeout)
   display
   (let ((queue x-display-events)
 	(output-available? #f)
+	(timed-out? #f)
+	(thread (current-thread))
+	(timer)
 	(registrations))
     (let loop ()
-      ;; Test-select-registry does not detect input in port buffers.
-      ;; Drain them before suspending.
+      ;; IO events are not delivered when input lingers in port buffers.
+      ;; Incrementally drain the ports before suspending.
       (set! output-available? (accept-process-output))
+
       (dynamic-wind
        (lambda ()
+	 (set! timer
+	       (and timeout
+		    (register-time-event timeout
+					 (lambda ()
+					   (set! timed-out? #t)))))
 	 (set! registrations
 	       (if output-available?
 		   '()
 		   (register-process-output-events
-		    (current-thread)
+		    thread
 		    (lambda (mode)
 		      mode
 		      (set! output-available? #t))))))
@@ -507,17 +504,25 @@ USA.
 
 	    (if (and (queue-empty? queue)
 		     (not output-available?)
+		     (not timed-out?)
 		     (not (process-status-changes?))
 		     (not inferior-thread-changes?))
 		(suspend-current-thread)))))
        (lambda ()
-	 (for-each deregister-io-thread-event registrations)
-	 (set! registrations)))
+	 (if (eq? (current-thread) thread)
+	     (begin
+	       (if timer (deregister-time-event timer))
+	       (set! timer)
+	       (for-each deregister-io-thread-event registrations)
+	       (set! registrations)))))
+
       (or (with-thread-events-blocked
 	   (lambda ()
 	     (and (not (queue-empty? queue))
 		  (dequeue!/unsafe queue))))
-	  (cond ((process-status-changes?)
+	  (cond (timed-out?
+		 #f)
+		((process-status-changes?)
 		 event:process-status)
 		(output-available?
 		 event:process-output)