Keep separate queues for input and output channels, so the VM doesn't

get confused handling events/interrupts.
I despise myself.

scheme/vm/interfaces.scm

@@ -330,9 +330,12 @@
 	  output-channel?
 	  open?
 
-	  channel-queue-empty?
+	  input-channel-queue-empty?
-	  enqueue-channel!
+	  output-channel-queue-empty?
-	  dequeue-channel!
+	  enqueue-input-channel!
+	  dequeue-input-channel!
+	  enqueue-output-channel!
+	  dequeue-output-channel!
 	  vm-channel-abort
 	  ))
 

scheme/vm/interrupt.scm

@@ -58,10 +58,17 @@
 	 (set! *finalize-these* null)
 	 (push (enter-fixnum *enabled-interrupts*))
 	 2)
-	((or (eq? pending-interrupt (enum interrupt i/o-read-completion))
+	((eq? pending-interrupt (enum interrupt i/o-read-completion))
-	     (eq? pending-interrupt (enum interrupt i/o-write-completion)))
+	 (let ((channel (dequeue-input-channel!)))
-	 (let ((channel (dequeue-channel!)))
+	   (if (not (input-channel-queue-empty?))
-	   (if (not (channel-queue-empty?))
+	       (note-interrupt! pending-interrupt))
+	   (push channel)
+	   (push (channel-os-status channel))
+	   (push (enter-fixnum *enabled-interrupts*))
+	   3))
+	((eq? pending-interrupt (enum interrupt i/o-write-completion))
+	 (let ((channel (dequeue-output-channel!)))
+	   (if (not (output-channel-queue-empty?))
 	       (note-interrupt! pending-interrupt))
 	   (push channel)
 	   (push (channel-os-status channel))
@@ -234,10 +241,10 @@
 	((eq? event (enum events keyboard-interrupt-event))
 	 (interrupt-bit (enum interrupt keyboard)))
 	((eq? event (enum events io-read-completion-event))
-	 (enqueue-channel! channel status)
+	 (enqueue-input-channel! channel status)
 	 (interrupt-bit (enum interrupt i/o-read-completion)))
 	((eq? event (enum events io-write-completion-event))
-	 (enqueue-channel! channel status)
+	 (enqueue-output-channel! channel status)
 	 (interrupt-bit (enum interrupt i/o-write-completion)))
 	((eq? event (enum events os-signal-event))
 	 (interrupt-bit (enum interrupt os-signal)))

scheme/vm/vmio.scm

@@ -38,8 +38,10 @@
 			  (output-port->channel (current-error-port)))))))
   (set! *vm-channels* (make-vector *number-of-channels*
 				   (input-port->channel (current-input-port))))
-  (set! *pending-channels-head* false)
+  (set! *pending-input-channels-head* false)
-  (set! *pending-channels-tail* false)
+  (set! *pending-input-channels-tail* false)
+  (set! *pending-output-channels-head* false)
+  (set! *pending-output-channels-tail* false)
   (if (null-pointer? *vm-channels*)
       (error "out of memory, unable to continue"))
   (vector+length-fill! *vm-channels* *number-of-channels* false)
@@ -115,7 +117,10 @@
 	 (let ((old-index (extract-fixnum (channel-os-index channel))))
 	   (if (vm-eq? (channel-os-status channel)
 		       true)
-	       (enqueue-channel! old-index (channel-abort old-index)))
+	       (if (or (= input-status (channel-status channel))
+		       (= special-input-status (channel-status channel)))
+		   (enqueue-input-channel! old-index (channel-abort old-index))
+		   (enqueue-output-channel! old-index (channel-abort old-index))))
 	   (vector-set! *vm-channels* old-index false)
 	   (vector-set! *vm-channels* os-index channel)
 	   (set-channel-os-index! channel (enter-fixnum os-index))
@@ -151,7 +156,10 @@
   (let ((os-index (extract-fixnum (channel-os-index channel))))
     (if (vm-eq? (channel-os-status channel)
 		true)
-	(enqueue-channel! os-index (channel-abort os-index)))
+	(if (or (= input-status (channel-status channel))
+		(= special-input-status (channel-status channel)))
+	    (enqueue-input-channel! os-index (channel-abort os-index))
+	    (enqueue-output-channel! os-index (channel-abort os-index))))
     (let ((status (if (or (= input-status (channel-status channel))
 			  (= special-input-status (channel-status channel)))
 		      (close-input-channel os-index)
@@ -221,66 +229,115 @@
 ;
 ; WindowsNT: we will need a fancier GC or something.
 
-; These are a queue of channels with pending interrupts
+; These are queues of channels with pending interrupts
 
-(define *pending-channels-head* false)
+(define *pending-input-channels-head* false)
-(define *pending-channels-tail* false)
+(define *pending-input-channels-tail* false)
 
-(define (channel-queue-empty?)
+(define *pending-output-channels-head* false)
-  (false? *pending-channels-head*))
+(define *pending-output-channels-tail* false)
 
-(define (enqueue-channel! index status)
+(define (input-channel-queue-empty?)
+  (false? *pending-input-channels-head*))
+
+(define (output-channel-queue-empty?)
+  (false? *pending-output-channels-head*))
+
+(define-syntax define-enqueue-channel!
+  (syntax-rules ()
+    ((define-enqueue-channel! name *head* *tail*)
+     (define (name index status)
        (let ((channel (os-index->channel index)))
 	 (set-channel-os-status! channel (enter-fixnum status))
 	 (cond ((not (false? (channel-next channel))) ; already queued (how?)
 		(unspecific))  ; for the type checker
-	  ((false? *pending-channels-head*)
+	       ((false? *head*)
-	   (set! *pending-channels-head* channel)
+		(set! *head* channel)
-	   (set! *pending-channels-tail* channel))
+		(set! *tail* channel))
 	       (else
-	   (set-channel-next! *pending-channels-tail* channel)
+		(set-channel-next! *tail* channel)
-	   (set! *pending-channels-tail* channel)))))
+		(set! *tail* channel))))))))
 
-(define (dequeue-channel!)
+(define-enqueue-channel! enqueue-input-channel!
-  (let* ((channel *pending-channels-head*)
+  *pending-input-channels-head*
+  *pending-input-channels-tail*)
+(define-enqueue-channel! enqueue-output-channel!
+  *pending-output-channels-head*
+  *pending-output-channels-tail*)
+
+(define-syntax define-dequeue-channel!
+  (syntax-rules ()
+   ((define-dequeue-channel! name *head* *tail*)
+    (define (name)
+      (let* ((channel *head*)
 	     (next (channel-next channel)))
-    (set! *pending-channels-head* next)
+	(set! *head* next)
 	(set-channel-next! channel false)
 	(if (false? next)
-	(set! *pending-channels-tail* false))
+	    (set! *tail* false))
-    channel))
+	channel)))))
+
+(define-dequeue-channel! dequeue-input-channel!
+  *pending-input-channels-head*
+  *pending-input-channels-tail*)
+(define-dequeue-channel! dequeue-output-channel!
+  *pending-output-channels-head*
+  *pending-output-channels-tail*)
 
 ; See if a the OS has already finished with CHANNEL and return its status
 ; if it has.  If not, call the OS and have it abort the channel's current
 ; operation.
 
 (define (vm-channel-abort channel)
-  (let ((head *pending-channels-head*))
+  (cond ((and (false? *pending-input-channels-head*)
-    (cond ((false? head)
+	      (false? *pending-output-channels-head*))
 	 (set-channel-os-status! channel false) ; no longer pending
 	 (enter-fixnum (channel-abort
 			(extract-fixnum (channel-os-index channel)))))
-	  ((vm-eq? channel head)
+	((vm-eq? channel *pending-input-channels-head*)
-	   (dequeue-channel!)
+	 (dequeue-input-channel!)
+	 (channel-os-status channel))
+	((vm-eq? channel *pending-output-channels-head*)
+	 (dequeue-output-channel!)
 	 (channel-os-status channel))
 	(else
-	   (let loop ((ch (channel-next head)) (prev head))
+	 (let loop ((ch (channel-next *pending-input-channels-head*))
+		    (prev *pending-input-channels-head*))
+	   (cond ((false? ch)
+		  (let loop ((ch (channel-next *pending-output-channels-head*))
+			     (prev *pending-output-channels-head*))
 		    (cond ((false? ch)
 			   (set-channel-os-status! channel false) ; no longer pending
 			   (enter-fixnum (channel-abort
 					  (extract-fixnum (channel-os-index channel)))))
 			  ((vm-eq? ch channel)
-		    (if (vm-eq? ch *pending-channels-tail*)
+			   (if (vm-eq? ch *pending-output-channels-tail*)
-			(set! *pending-channels-tail* prev))
+			       (set! *pending-output-channels-tail* prev))
 			   (set-channel-next! prev (channel-next ch))
 			   (set-channel-next! ch false)
 			   (channel-os-status ch))
 			  (else
-		    (loop (channel-next ch) ch))))))))
+			   (loop (channel-next ch) ch)))))
+
+		 ((vm-eq? ch channel)
+		  (if (vm-eq? ch *pending-input-channels-tail*)
+		      (set! *pending-input-channels-tail* prev))
+		  (set-channel-next! prev (channel-next ch))
+		  (set-channel-next! ch false)
+		  (channel-os-status ch))
+
+		 (else
+		  (loop (channel-next ch) ch)))))))
 
 (define (trace-io trace-value)
-  (set! *pending-channels-head* (trace-value *pending-channels-head*))
+  (set! *pending-input-channels-head*
-  (set! *pending-channels-tail* (trace-value *pending-channels-tail*)))
+	(trace-value *pending-input-channels-head*))
+  (set! *pending-input-channels-tail*
+	(trace-value *pending-input-channels-tail*))
+  (set! *pending-output-channels-head*
+	(trace-value *pending-output-channels-head*))
+  (set! *pending-output-channels-tail*
+	(trace-value *pending-output-channels-tail*)))
 
 ;----------------------------------------------------------------
 ; Automatically closing channels.