From: Chris Hanson <org/chris-hanson/cph>
Date: Wed, 22 Jan 2003 02:06:44 +0000 (+0000)
Subject: Use new I/O synchronization primitives.  Requires microcode 14.11 or
X-Git-Tag: 20090517-FFI~2059
X-Git-Url: https://birchwood-abbey.net/git?a=commitdiff_plain;h=a1caec5798c55ade053408c1ea91489f54a72f84;p=mit-scheme.git

Use new I/O synchronization primitives.  Requires microcode 14.11 or
later.
---

diff --git a/v7/src/runtime/dosprm.scm b/v7/src/runtime/dosprm.scm
index 909246b3a..574ce7420 100644
--- a/v7/src/runtime/dosprm.scm
+++ b/v7/src/runtime/dosprm.scm
@@ -1,8 +1,9 @@
 #| -*-Scheme-*-
 
-$Id: dosprm.scm,v 1.44 2002/11/20 19:46:19 cph Exp $
+$Id: dosprm.scm,v 1.45 2003/01/22 02:04:55 cph Exp $
 
-Copyright (c) 1992-2000 Massachusetts Institute of Technology
+Copyright 1992,1993,1994,1995,1996,1998 Massachusetts Institute of Technology
+Copyright 1999,2000,2003 Massachusetts Institute of Technology
 
 This file is part of MIT Scheme.
 
@@ -403,92 +404,9 @@ Inc., 59 Temple Place - Suite 330, Boston, MA 02111-1307, USA.
 		 (close-port port)
 		 (set! port #f)
 		 unspecific))))))))
-
-(define (select-internal console? handles block?)
-  (let* ((nt/qs-allinput #xff)
-	 (select
-	  (if console?
-	      (lambda (period)
-		((ucode-primitive nt:msgwaitformultipleobjects 4)
-		 handles #f period nt/qs-allinput))
-	      (lambda (period)
-		((ucode-primitive nt:waitformultipleobjects 3)
-		 handles #f period)))))
-    (if (not block?)
-	(select 0)
-	(let loop ()
-	  (let ((res (select 20)))
-	    (if (zero? res)
-		(loop)
-		res))))))
 	       
 (define console-channel-descriptor)
 
 (define (cache-console-channel-descriptor!)
   (set! console-channel-descriptor -1)
-  unspecific)
-
-(define (select-descriptor descriptor block?)
-  (define (select-result result)
-    (cond ((fix:> result 0)
-	   'INPUT-AVAILABLE)
-	  ((fix:< result 0)
-	   (error "Illegal result from select-internal" result))
-	  (else
-	   #f)))
-
-  (select-result
-   (if (= descriptor console-channel-descriptor)
-       (select-internal true '#() block?)
-       (select-internal false (vector descriptor) block?))))
-
-(define-structure (nt-select-registry
-		   (conc-name nt-select-registry/)
-		   (constructor nt-select-registry/make))
-  console
-  descriptors)
-
-(define-integrable (find-descriptor df dl)
-  (list-search-positive dl
-    (lambda (d)
-      (= d df))))
-
-(define (make-select-registry . descriptors)
-  (cond ((find-descriptor console-channel-descriptor descriptors)
-	 => (lambda (ccd)
-	      (nt-select-registry/make console-channel-descriptor
-				       (delq! ccd descriptors))))
-	(else
-	 (nt-select-registry/make false descriptors))))
-
-(define (add-to-select-registry! registry descriptor)
-  (cond ((= descriptor console-channel-descriptor)
-	 (set-nt-select-registry/console! registry console-channel-descriptor))
-	((not (find-descriptor descriptor
-			       (nt-select-registry/descriptors registry)))
-	 (set-nt-select-registry/descriptors!
-	  registry
-	  (cons descriptor (nt-select-registry/descriptors registry))))))
-
-(define (remove-from-select-registry! registry descriptor)
-  (cond ((= descriptor console-channel-descriptor)
-	 (set-nt-select-registry/console! registry false))
-	((find-descriptor descriptor (nt-select-registry/descriptors registry))
-	 => (lambda (dr)
-	      (set-nt-select-registry/descriptors!
-	       registry
-	       (delq! dr (nt-select-registry/descriptors registry)))))))
-
-(define (select-registry-test registry block?)
-  (let* ((handles (list->vector (nt-select-registry/descriptors registry)))
-	 (result (select-internal (nt-select-registry/console registry)
-				  handles
-				  block?)))
-    (cond ((fix:< result 0)
-	   (error "Illegal result from select-internal" result))
-	  ((fix:= result 0)
-	   #f)
-	  ((fix:> result (vector-length handles))
-	   (list (nt-select-registry/console registry)))
-	  (else
-	   (list (vector-ref handles (fix:- result 1)))))))
\ No newline at end of file
+  unspecific)
\ No newline at end of file
diff --git a/v7/src/runtime/io.scm b/v7/src/runtime/io.scm
index 962d13846..9e2521f6e 100644
--- a/v7/src/runtime/io.scm
+++ b/v7/src/runtime/io.scm
@@ -1,8 +1,10 @@
 #| -*-Scheme-*-
 
-$Id: io.scm,v 14.66 2002/12/09 05:40:04 cph Exp $
+$Id: io.scm,v 14.67 2003/01/22 02:05:02 cph Exp $
 
-Copyright (c) 1988-2002 Massachusetts Institute of Technology
+Copyright 1986,1987,1988,1990,1991,1993 Massachusetts Institute of Technology
+Copyright 1994,1995,1998,1999,2000,2001 Massachusetts Institute of Technology
+Copyright 2002,2003 Massachusetts Institute of Technology
 
 This file is part of MIT Scheme.
 
@@ -29,15 +31,16 @@ Inc., 59 Temple Place - Suite 330, Boston, MA 02111-1307, USA.
 
 (define open-channels-list)
 (define open-directories)
-(define have-select?)
 
 (define (initialize-package!)
   (set! open-channels-list (list 'OPEN-CHANNELS-LIST))
   (add-gc-daemon! close-lost-open-files-daemon)
   (set! open-directories
 	(make-gc-finalizer (ucode-primitive new-directory-close 1)))
-  (set! have-select? ((ucode-primitive have-select? 0)))
-  (add-event-receiver! event:after-restore primitive-io/reset!))
+  (add-event-receiver! event:after-restore
+    (lambda ()
+      (close-all-open-channels-internal (lambda (ignore) ignore))))
+  (initialize-select-registry!))
 
 (define-structure (channel (constructor %make-channel))
   ;; This structure serves two purposes.  First, because a descriptor
@@ -77,7 +80,7 @@ Inc., 59 Temple Place - Suite 330, Boston, MA 02111-1307, USA.
        (system-pair-set-car! p channel)
        (set-cdr! open-channels-list (cons p (cdr open-channels-list)))))
     channel))
-
+
 (define (descriptor->channel descriptor)
   (let loop ((channels (cdr open-channels-list)))
     (and (not (null? channels))
@@ -104,7 +107,7 @@ Inc., 59 Temple Place - Suite 330, Boston, MA 02111-1307, USA.
     (or (eq? 'TERMINAL type)
 	(eq? 'UNIX-PTY-MASTER type)
 	(eq? 'OS/2-CONSOLE type))))
-
+
 (define (channel-close channel)
   (without-interrupts
    (lambda ()
@@ -127,7 +130,7 @@ Inc., 59 Temple Place - Suite 330, Boston, MA 02111-1307, USA.
 
 (define-integrable (channel-closed? channel)
   (not (channel-descriptor channel)))
-
+
 (define (close-all-open-files)
   (close-all-open-channels channel-type=file?))
 
@@ -151,13 +154,6 @@ Inc., 59 Temple Place - Suite 330, Boston, MA 02111-1307, USA.
 	   result
 	   (loop (cdr l) (cons (system-pair-car (car l)) result)))))))
 
-(define (primitive-io/reset!)
-  ;; This is invoked after disk-restoring.
-  ;; It "cleans" the new runtime system.
-  (close-all-open-channels-internal (lambda (ignore) ignore))
-  (set! have-select? ((ucode-primitive have-select? 0)))
-  unspecific)
-
 (define (close-all-open-channels-internal action)
   (without-interrupts
    (lambda ()
@@ -246,9 +242,9 @@ Inc., 59 Temple Place - Suite 330, Boston, MA 02111-1307, USA.
 	  (lambda ()
 	    (let ((do-test
 		   (lambda (k)
-		     (let ((result (test-for-input-on-channel channel)))
+		     (let ((result (test-for-io-on-channel channel 'READ)))
 		       (case result
-			 ((INPUT-AVAILABLE)
+			 ((READ)
 			  (do-read))
 			 ((PROCESS-STATUS-CHANGE)
 			  (handle-subprocess-status-change)
@@ -265,15 +261,16 @@ Inc., 59 Temple Place - Suite 330, Boston, MA 02111-1307, USA.
     (or (channel-read channel buffer start end)
 	(loop))))
 
-(define-integrable (test-for-input-on-channel channel)
-  (test-for-input-on-descriptor (channel-descriptor-for-select channel)
-				(channel-blocking? channel)))
+(define (test-for-io-on-channel channel mode)
+  (test-for-io-on-descriptor (channel-descriptor-for-select channel)
+			     (channel-blocking? channel)
+			     mode))
 
-(define (test-for-input-on-descriptor descriptor block?)
+(define (test-for-io-on-descriptor descriptor block? mode)
   (if block?
-      (or (select-descriptor descriptor #f)
-	  (block-on-input-descriptor descriptor))
-      (select-descriptor descriptor #f)))
+      (or (test-select-descriptor descriptor #f mode)
+	  (block-on-io-descriptor descriptor mode))
+      (test-select-descriptor descriptor #f mode)))
 
 (define-integrable (channel-descriptor-for-select channel)
   ((ucode-primitive channel-descriptor 1) (channel-descriptor channel)))
@@ -1185,4 +1182,137 @@ Inc., 59 Temple Place - Suite 330, Boston, MA 02111-1307, USA.
 	     (if (fix:> contents-size (string-length string))
 		 (input-buffer/set-size buffer contents-size))
 	     (substring-move! contents 0 contents-size string 0)
-	     (input-buffer/after-fill! buffer contents-size)))))))
\ No newline at end of file
+	     (input-buffer/after-fill! buffer contents-size)))))))
+
+;;;; Select registry
+
+(define have-select?)
+(define select-registry-finalizer)
+(define select-registry-result-vectors)
+
+(define (initialize-select-registry!)
+  (set! have-select? ((ucode-primitive have-select? 0)))
+  (set! select-registry-finalizer
+	(make-gc-finalizer (ucode-primitive deallocate-select-registry 1)))
+  (let ((reset-rv!
+	 (lambda ()
+	   (set! select-registry-result-vectors '())
+	   unspecific)))
+    (reset-rv!)
+    (add-event-receiver! event:after-restart reset-rv!))
+  (add-event-receiver! event:after-restore
+    (lambda ()
+      (set! have-select? ((ucode-primitive have-select? 0)))
+      unspecific)))
+
+(define-structure (select-registry
+		   (constructor %make-select-registry (handle)))
+  handle
+  (length #f))
+
+(define (make-select-registry)
+  (without-interrupts
+   (lambda ()
+     (let ((handle ((ucode-primitive allocate-select-registry 0))))
+       (let ((registry (%make-select-registry handle)))
+	 (add-to-gc-finalizer! select-registry-finalizer registry handle)
+	 registry)))))
+
+(define (add-to-select-registry! registry descriptor mode)
+  ((ucode-primitive add-to-select-registry 3)
+   (select-registry-handle registry)
+   descriptor
+   (encode-select-registry-mode mode))
+  (set-select-registry-length! registry #f))
+
+(define (remove-from-select-registry! registry descriptor mode)
+  ((ucode-primitive remove-from-select-registry 3)
+   (select-registry-handle registry)
+   descriptor
+   (encode-select-registry-mode mode))
+  (set-select-registry-length! registry #f))
+
+(define (test-select-descriptor descriptor block? mode)
+  (let ((result
+	 ((ucode-primitive test-select-descriptor 3)
+	  descriptor
+	  block?
+	  (encode-select-registry-mode mode))))
+    (case result
+      ((0) #f)
+      ((1) 'READ)
+      ((2) 'WRITE)
+      ((3) 'READ/WRITE)
+      ((-1) 'INTERRUPT)
+      ((-2)
+       (subprocess-global-status-tick)
+       'PROCESS-STATUS-CHANGE)
+      (else (error "Illegal result from TEST-SELECT-DESCRIPTOR:" result)))))
+
+(define (encode-select-registry-mode mode)
+  (case mode
+    ((READ) 1)
+    ((WRITE) 2)
+    ((READ/WRITE) 3)
+    (else (error:bad-range-argument mode 'ENCODE-SELECT-REGISTRY-MODE))))
+
+(define (test-select-registry registry block?)
+  (receive (vr vw) (allocate-select-registry-result-vectors registry)
+    (let ((result
+	   ((ucode-primitive test-select-registry 4)
+	    (select-registry-handle registry)
+	    block?
+	    vr
+	    vw)))
+      (if (> result 0)
+	  (cons vr vw)
+	  (begin
+	    (deallocate-select-registry-result-vectors vr vw)
+	    (cond ((= 0 result) #f)
+		  ((= -1 result) 'INTERRUPT)
+		  ((= -2 result)
+		   (subprocess-global-status-tick)
+		   'PROCESS-STATUS-CHANGE)
+		  (else
+		   (error "Illegal result from TEST-SELECT-REGISTRY:"
+			  result))))))))
+
+(define (allocate-select-registry-result-vectors registry)
+  (let ((interrupt-mask (set-interrupt-enables! interrupt-mask/gc-ok)))
+    (let ((n
+	   (or (select-registry-length registry)
+	       (let ((rl
+		      ((ucode-primitive select-registry-length 1)
+		       (select-registry-handle registry))))
+		 (set-select-registry-length! registry rl)
+		 rl))))
+      (let loop ((rv select-registry-result-vectors))
+	(if (pair? rv)
+	    (let ((vr (caar rv))
+		  (vw (cdar rv)))
+	      (if (and vr (fix:< n (vector-length vr)))
+		  (begin
+		    (set-car! (car rv) #f)
+		    (set-cdr! (car rv) #f)
+		    (set-interrupt-enables! interrupt-mask)
+		    (values vr vw))
+		  (loop (cdr rv))))
+	    (let loop ((m 16))
+	      (if (fix:< n m)
+		  (begin
+		    (set-interrupt-enables! interrupt-mask)
+		    (values (make-vector m) (make-vector m)))
+		  (loop (fix:* m 2)))))))))
+
+(define (deallocate-select-registry-result-vectors vr vw)
+  (let ((interrupt-mask (set-interrupt-enables! interrupt-mask/gc-ok)))
+    (let loop ((rv select-registry-result-vectors))
+      (if (pair? rv)
+	  (if (caar rv)
+	      (loop (cdr rv))
+	      (begin
+		(set-car! (car rv) vr)
+		(set-cdr! (car rv) vw)))
+	  (set! select-registry-result-vectors
+		(cons (cons vr vw) select-registry-result-vectors))))
+    (set-interrupt-enables! interrupt-mask)))
\ No newline at end of file
diff --git a/v7/src/runtime/ntprm.scm b/v7/src/runtime/ntprm.scm
index 0c16d8ff7..03cb73d04 100644
--- a/v7/src/runtime/ntprm.scm
+++ b/v7/src/runtime/ntprm.scm
@@ -1,8 +1,9 @@
 #| -*-Scheme-*-
 
-$Id: ntprm.scm,v 1.38 2002/11/20 19:46:21 cph Exp $
+$Id: ntprm.scm,v 1.39 2003/01/22 02:05:08 cph Exp $
 
-Copyright (c) 1992-2001 Massachusetts Institute of Technology
+Copyright 1995,1996,1998,1999,2000,2001 Massachusetts Institute of Technology
+Copyright 2003 Massachusetts Institute of Technology
 
 This file is part of MIT Scheme.
 
@@ -449,55 +450,9 @@ Inc., 59 Temple Place - Suite 330, Boston, MA 02111-1307, USA.
 		       (set! port #f)
 		       unspecific))))))))))
 
-(define-structure (nt-select-registry (conc-name nt-select-registry/))
-  descriptors)
-
-(define (make-select-registry . descriptors)
-  (make-nt-select-registry descriptors))
-
-(define (add-to-select-registry! registry descriptor)
-  (if (not (memv descriptor (nt-select-registry/descriptors registry)))
-      (set-nt-select-registry/descriptors!
-       registry
-       (cons descriptor (nt-select-registry/descriptors registry)))))
-
-(define (remove-from-select-registry! registry descriptor)
-  (set-nt-select-registry/descriptors!
-   registry
-   (delv! descriptor (nt-select-registry/descriptors registry))))
-
-(define (select-registry-test registry block?)
-  (let ((descriptors (list->vector (nt-select-registry/descriptors registry))))
-    (let ((result
-	   ((ucode-primitive nt:waitformultipleobjects 3)
-	    descriptors #f block?)))
-      (cond ((and (fix:<= 0 result) (fix:< result (vector-length descriptors)))
-	     (list (vector-ref descriptors result)))
-	    ((fix:= result -1) #f)
-	    ((fix:= result -2) 'INTERRUPT)
-	    ((fix:= result -3) 'PROCESS-STATUS-CHANGE)
-	    (else (error "Illegal result from select-internal:" result))))))
-
-(define (select-descriptor descriptor block?)
-  (let ((result
-	 ((ucode-primitive nt:waitformultipleobjects 3)
-	  (vector descriptor) #f block?)))
-    (case result
-      ((0) 'INPUT-AVAILABLE)
-      ((-1) #f)
-      ((-2) 'INTERRUPT)
-      ((-3) 'PROCESS-STATUS-CHANGE)
-      (else (error "Illegal result from select-internal:" result)))))
-
-(define console-channel-descriptor)
-
-(define (cache-console-channel-descriptor!)
-  (set! console-channel-descriptor
-	(channel-descriptor-for-select (tty-input-channel)))
-  unspecific)
-
 ;;;; Subprocess/Shell Support
 
+(define console-channel-descriptor)
 (define nt/hide-subprocess-windows?)
 (define nt/subprocess-argument-quote-char)
 (define nt/subprocess-argument-escape-char)
@@ -506,7 +461,9 @@ Inc., 59 Temple Place - Suite 330, Boston, MA 02111-1307, USA.
   (let ((reset!
 	 (lambda ()
 	   (reset-environment-variables!)
-	   (cache-console-channel-descriptor!))))
+	   (set! console-channel-descriptor
+		 (channel-descriptor-for-select (tty-input-channel)))
+	   unspecific)))
     (reset!)
     (add-event-receiver! event:after-restart reset!))
   (set! nt/hide-subprocess-windows? #t)
diff --git a/v7/src/runtime/os2graph.scm b/v7/src/runtime/os2graph.scm
index 9530c1c2b..922dace8e 100644
--- a/v7/src/runtime/os2graph.scm
+++ b/v7/src/runtime/os2graph.scm
@@ -1,8 +1,9 @@
 #| -*-Scheme-*-
 
-$Id: os2graph.scm,v 1.20 2002/11/20 19:46:21 cph Exp $
+$Id: os2graph.scm,v 1.21 2003/01/22 02:05:15 cph Exp $
 
-Copyright (c) 1995-2002 Massachusetts Institute of Technology
+Copyright 1995,1996,1997,1999,2000 Massachusetts Institute of Technology
+Copyright 2001,2002,2003 Massachusetts Institute of Technology
 
 This file is part of MIT Scheme.
 
@@ -119,7 +120,7 @@ Inc., 59 Temple Place - Suite 330, Boston, MA 02111-1307, USA.
 	(set! graphics-window-icon)
 	(remove-all-from-gc-finalizer! window-finalizer)
 	(remove-all-from-gc-finalizer! image-finalizer)
-	(deregister-input-thread-event event-previewer-registration)
+	(deregister-io-thread-event event-previewer-registration)
 	(set! event-previewer-registration #f)
 	(set! user-event-mask user-event-mask:default)
 	(flush-queue! user-event-queue)
@@ -207,10 +208,13 @@ Inc., 59 Temple Place - Suite 330, Boston, MA 02111-1307, USA.
       (begin
 	(set! event-descriptor (os2win-open-event-qid))
 	(set! event-previewer-registration
-	      (permanently-register-input-thread-event
+	      (permanently-register-io-thread-event
 	       event-descriptor
+	       'READ
 	       (current-thread)
-	       read-and-process-event))
+	       (lambda (mode)
+		 mode
+		 (read-and-process-event))))
 	(set! graphics-window-icon
 	      (os2win-load-pointer HWND_DESKTOP NULLHANDLE IDI_GRAPHICS))))
   (open-window descriptor->device
@@ -850,8 +854,8 @@ Inc., 59 Temple Place - Suite 330, Boston, MA 02111-1307, USA.
      (let loop ()
        (if (queue-empty? user-event-queue)
 	   (begin
-	     (if (eq? 'INPUT-AVAILABLE
-		      (test-for-input-on-descriptor event-descriptor #t))
+	     (if (eq? 'READ
+		      (test-for-io-on-descriptor event-descriptor #t 'READ))
 		 (read-and-process-event))
 	     (loop))
 	   (dequeue! user-event-queue))))))
diff --git a/v7/src/runtime/os2prm.scm b/v7/src/runtime/os2prm.scm
index 28bef94d1..9c8d19460 100644
--- a/v7/src/runtime/os2prm.scm
+++ b/v7/src/runtime/os2prm.scm
@@ -1,8 +1,9 @@
 #| -*-Scheme-*-
 
-$Id: os2prm.scm,v 1.49 2002/11/20 19:46:21 cph Exp $
+$Id: os2prm.scm,v 1.50 2003/01/22 02:05:21 cph Exp $
 
-Copyright (c) 1994-2001 Massachusetts Institute of Technology
+Copyright 1994,1995,1997,1998,1999,2000 Massachusetts Institute of Technology
+Copyright 2001,2003 Massachusetts Institute of Technology
 
 This file is part of MIT Scheme.
 
@@ -348,100 +349,10 @@ Inc., 59 Temple Place - Suite 330, Boston, MA 02111-1307, USA.
 		       (close-port port)
 		       (set! port #f)
 		       unspecific))))))))))
-
-(define (initialize-system-primitives!)
-  (discard-select-registry-result-vectors!)
-  (add-event-receiver! event:after-restart
-		       discard-select-registry-result-vectors!))
-
-(define os2/select-registry-lub)
-(define select-registry-result-vectors)
-
-(define (discard-select-registry-result-vectors!)
-  (set! os2/select-registry-lub ((ucode-primitive os2-select-registry-lub 0)))
-  (set! select-registry-result-vectors '())
-  unspecific)
 
-(define (allocate-select-registry-result-vector)
-  (let ((interrupt-mask (set-interrupt-enables! interrupt-mask/gc-ok)))
-    (let ((v
-	   (let loop ((rv select-registry-result-vectors))
-	     (if (pair? rv)
-		 (let ((v (car rv)))
-		   (if v
-		       (begin
-			 (set-car! rv #f)
-			 v)
-		       (loop (cdr rv))))
-		 (make-string os2/select-registry-lub)))))
-      (set-interrupt-enables! interrupt-mask)
-      v)))
-
-(define (deallocate-select-registry-result-vector v)
-  (let ((interrupt-mask (set-interrupt-enables! interrupt-mask/gc-ok)))
-    (let loop ((rv select-registry-result-vectors))
-      (if (pair? rv)
-	  (if (car rv)
-	      (loop (cdr rv))
-	      (set-car! rv v))
-	  (set! select-registry-result-vectors
-		(cons v select-registry-result-vectors))))
-    (set-interrupt-enables! interrupt-mask))
+(define (initialize-system-primitives!)
   unspecific)
 
-(define (make-select-registry . descriptors)
-  (let ((registry (make-string os2/select-registry-lub)))
-    (vector-8b-fill! registry 0 os2/select-registry-lub 0)
-    (do ((descriptors descriptors (cdr descriptors)))
-	((not (pair? descriptors)))
-      (add-to-select-registry! registry (car descriptors)))
-    registry))
-
-(define (os2/guarantee-select-descriptor descriptor procedure)
-  (if (not (and (fix:fixnum? descriptor)
-		(fix:<= 0 descriptor)
-		(fix:< descriptor os2/select-registry-lub)))
-      (error:wrong-type-argument descriptor "select descriptor" procedure))
-  descriptor)
-
-(define (add-to-select-registry! registry descriptor)
-  (os2/guarantee-select-descriptor descriptor 'ADD-TO-SELECT-REGISTRY!)
-  (vector-8b-set! registry descriptor 1))
-
-(define (remove-from-select-registry! registry descriptor)
-  (os2/guarantee-select-descriptor descriptor 'REMOVE-FROM-SELECT-REGISTRY!)
-  (vector-8b-set! registry descriptor 0))
-
-(define (select-descriptor descriptor block?)
-  (vector-ref os2/select-result-values
-	      ((ucode-primitive os2-select-descriptor 2) descriptor block?)))
-
-(define (select-registry-test registry block?)
-  (let ((result-vector (allocate-select-registry-result-vector)))
-    (let ((result
-	   ((ucode-primitive os2-select-registry-test 3) registry
-							 result-vector
-							 block?)))
-      (if (fix:= result 0)
-	  (let loop
-	      ((index (fix:- os2/select-registry-lub 1))
-	       (descriptors '()))
-	    (let ((descriptors
-		   (if (fix:= 0 (vector-8b-ref result-vector index))
-		       descriptors
-		       (cons index descriptors))))
-	      (if (fix:= 0 index)
-		  (begin
-		    (deallocate-select-registry-result-vector result-vector)
-		    descriptors)
-		  (loop (fix:- index 1) descriptors))))
-	  (begin
-	    (deallocate-select-registry-result-vector result-vector)
-	    (vector-ref os2/select-result-values result))))))
-
-(define os2/select-result-values
-  '#(INPUT-AVAILABLE #F INTERRUPT PROCESS-STATUS-CHANGE))
-
 ;;;; Subprocess/Shell Support
 
 (define (os/make-subprocess filename arguments environment working-directory
diff --git a/v7/src/runtime/runtime.pkg b/v7/src/runtime/runtime.pkg
index d7c15e767..272522bc8 100644
--- a/v7/src/runtime/runtime.pkg
+++ b/v7/src/runtime/runtime.pkg
@@ -1,6 +1,6 @@
 #| -*-Scheme-*-
 
-$Id: runtime.pkg,v 14.422 2003/01/09 19:36:50 cph Exp $
+$Id: runtime.pkg,v 14.423 2003/01/22 02:05:28 cph Exp $
 
 Copyright (c) 1988,1989,1990,1991,1992 Massachusetts Institute of Technology
 Copyright (c) 1993,1994,1995,1996,1997 Massachusetts Institute of Technology
@@ -568,7 +568,6 @@ Inc., 59 Temple Place - Suite 330, Boston, MA 02111-1307, USA.
 (define-package (runtime os-primitives)
   (parent (runtime))
   (export ()
-	  add-to-select-registry!
 	  copy-file
 	  current-home-directory
 	  current-user-name
@@ -598,7 +597,6 @@ Inc., 59 Temple Place - Suite 330, Boston, MA 02111-1307, USA.
 	  file-time->universal-time
 	  get-environment-variable
 	  init-file-specifier->pathname
-	  make-select-registry
 	  os/default-end-of-line-translation
 	  os/exec-path
 	  os/executable-pathname-types
@@ -608,9 +606,6 @@ Inc., 59 Temple Place - Suite 330, Boston, MA 02111-1307, USA.
 	  os/make-subprocess
 	  os/parse-path-string
 	  os/shell-file-name
-	  remove-from-select-registry!
-	  select-descriptor
-	  select-registry-test
 	  set-file-modes!
 	  set-file-times!
 	  temporary-directory-pathname
@@ -2530,8 +2525,8 @@ Inc., 59 Temple Place - Suite 330, Boston, MA 02111-1307, USA.
 	  terminal-raw-input
 	  terminal-raw-output
 	  terminal-set-state
-	  test-for-input-on-channel
-	  test-for-input-on-descriptor
+	  test-for-io-on-channel
+	  test-for-io-on-descriptor
 	  tty-input-channel
 	  tty-output-channel
 	  with-channel-blocking)
@@ -2604,7 +2599,11 @@ Inc., 59 Temple Place - Suite 330, Boston, MA 02111-1307, USA.
   (export (runtime x-graphics)
 	  have-select?)
   (export (runtime thread)
-	  have-select?)
+	  add-to-select-registry!
+	  have-select?
+	  make-select-registry
+	  remove-from-select-registry!
+	  test-select-registry)
   (export (runtime directory)
 	  directory-channel/descriptor)
   (initialization (initialize-package!)))
@@ -3957,8 +3956,8 @@ Inc., 59 Temple Place - Suite 330, Boston, MA 02111-1307, USA.
 	  create-thread-continuation
 	  current-thread
 	  deregister-all-events
-	  deregister-input-descriptor-events
-	  deregister-input-thread-event
+	  deregister-io-descriptor-events
+	  deregister-io-thread-event
 	  deregister-timer-event
 	  detach-thread
 	  exit-current-thread
@@ -3966,8 +3965,8 @@ Inc., 59 Temple Place - Suite 330, Boston, MA 02111-1307, USA.
 	  lock-thread-mutex
 	  make-thread-mutex
 	  other-running-threads?
-	  permanently-register-input-thread-event
-	  register-input-thread-event
+	  permanently-register-io-thread-event
+	  register-io-thread-event
 	  register-timer-event
 	  restart-thread
 	  set-thread-timer-interval!
@@ -3996,7 +3995,7 @@ Inc., 59 Temple Place - Suite 330, Boston, MA 02111-1307, USA.
   (export (runtime interrupt-handler)
 	  thread-timer-interrupt-handler)
   (export (runtime primitive-io)
-	  block-on-input-descriptor)
+	  block-on-io-descriptor)
   (export (runtime continuation)
 	  get-thread-event-block
 	  set-thread-event-block!)
diff --git a/v7/src/runtime/socket.scm b/v7/src/runtime/socket.scm
index 30f0cee2e..13c8187b8 100644
--- a/v7/src/runtime/socket.scm
+++ b/v7/src/runtime/socket.scm
@@ -1,8 +1,9 @@
 #| -*-Scheme-*-
 
-$Id: socket.scm,v 1.19 2002/11/20 19:46:23 cph Exp $
+$Id: socket.scm,v 1.20 2003/01/22 02:05:34 cph Exp $
 
-Copyright (c) 1990-2002 Massachusetts Institute of Technology
+Copyright 1996,1997,1998,1999,2001,2002 Massachusetts Institute of Technology
+Copyright 2003 Massachusetts Institute of Technology
 
 This file is part of MIT Scheme.
 
@@ -92,9 +93,10 @@ Inc., 59 Temple Place - Suite 330, Boston, MA 02111-1307, USA.
 	   (lambda ()
 	     (let ((do-test
 		    (lambda (k)
-		      (let ((result (test-for-input-on-channel server-socket)))
+		      (let ((result
+			     (test-for-io-on-channel server-socket 'READ)))
 			(case result
-			  ((INPUT-AVAILABLE)
+			  ((READ)
 			   (open-channel
 			    (lambda (p)
 			      (with-thread-timer-stopped
diff --git a/v7/src/runtime/thread.scm b/v7/src/runtime/thread.scm
index fba9d6722..50379cc28 100644
--- a/v7/src/runtime/thread.scm
+++ b/v7/src/runtime/thread.scm
@@ -1,8 +1,9 @@
 #| -*-Scheme-*-
 
-$Id: thread.scm,v 1.36 2002/11/20 19:46:23 cph Exp $
+$Id: thread.scm,v 1.37 2003/01/22 02:05:41 cph Exp $
 
-Copyright (c) 1991-1999 Massachusetts Institute of Technology
+Copyright 1991,1992,1993,1998,1999,2001 Massachusetts Institute of Technology
+Copyright 2003 Massachusetts Institute of Technology
 
 This file is part of MIT Scheme.
 
@@ -97,8 +98,8 @@ Inc., 59 Temple Place - Suite 330, Boston, MA 02111-1307, USA.
   (set! thread-timer-running? #f)
   (set! timer-records #f)
   (set! timer-interval 100)
-  (initialize-input-blocking)
-  (add-event-receiver! event:after-restore initialize-input-blocking)
+  (initialize-io-blocking)
+  (add-event-receiver! event:after-restore initialize-io-blocking)
   (detach-thread (make-thread #f))
   (add-event-receiver! event:before-exit stop-thread-timer))
 
@@ -121,7 +122,7 @@ Inc., 59 Temple Place - Suite 330, Boston, MA 02111-1307, USA.
   (map-over-population thread-population (lambda (thread) thread)))
 
 (define (thread-execution-state thread)
-  (guarantee-thread thread thread-execution-state)
+  (guarantee-thread thread 'THREAD-EXECUTION-STATE)
   (thread/execution-state thread))
 
 (define (create-thread root-continuation thunk)
@@ -183,7 +184,7 @@ Inc., 59 Temple Place - Suite 330, Boston, MA 02111-1307, USA.
   (thread/next (current-thread)))
 
 (define (thread-continuation thread)
-  (guarantee-thread thread thread-continuation)
+  (guarantee-thread thread 'THREAD-CONTINUATION)
   (without-interrupts
    (lambda ()
      (and (eq? 'WAITING (thread/execution-state thread))
@@ -215,7 +216,7 @@ Inc., 59 Temple Place - Suite 330, Boston, MA 02111-1307, USA.
       (begin
 	(set! last-running-thread #f)
 	(%maybe-toggle-thread-timer)
-	(wait-for-input))))
+	(wait-for-io))))
 
 (define (run-thread thread)
   (let ((continuation (thread/continuation thread)))
@@ -239,7 +240,7 @@ Inc., 59 Temple Place - Suite 330, Boston, MA 02111-1307, USA.
     (lambda (thread)
       (let ((block-events? (thread/block-events? thread)))
 	(set-thread/block-events?! thread #f)
-	(maybe-signal-input-thread-events)
+	(maybe-signal-io-thread-events)
 	(let ((any-events? (handle-thread-events thread)))
 	  (set-thread/block-events?! thread block-events?)
 	  (if (not any-events?)
@@ -260,7 +261,7 @@ Inc., 59 Temple Place - Suite 330, Boston, MA 02111-1307, USA.
 	    (thread-not-running thread 'STOPPED))))))))
 
 (define (restart-thread thread discard-events? event)
-  (guarantee-thread thread restart-thread)
+  (guarantee-thread thread 'RESTART-THREAD)
   (let ((discard-events?
 	 (if (eq? discard-events? 'ASK)
 	     (prompt-for-confirmation
@@ -283,7 +284,7 @@ Inc., 59 Temple Place - Suite 330, Boston, MA 02111-1307, USA.
 (define (thread-timer-interrupt-handler)
   (set-interrupt-enables! interrupt-mask/gc-ok)
   (deliver-timer-events)
-  (maybe-signal-input-thread-events)
+  (maybe-signal-io-thread-events)
   (let ((thread first-running-thread))
     (cond ((not thread)
 	   (%maybe-toggle-thread-timer))
@@ -324,7 +325,7 @@ Inc., 59 Temple Place - Suite 330, Boston, MA 02111-1307, USA.
     (set-thread/block-events?! thread #t)
     (ring/discard-all (thread/pending-events thread))
     (translate-to-state-point (thread/root-state-point thread))
-    (%deregister-input-thread-events thread #t)
+    (%deregister-io-thread-events thread #t)
     (%discard-thread-timer-records thread)
     (%disassociate-joined-threads thread)
     (%disassociate-thread-mutexes thread)
@@ -333,7 +334,7 @@ Inc., 59 Temple Place - Suite 330, Boston, MA 02111-1307, USA.
     (thread-not-running thread 'DEAD)))
 
 (define (join-thread thread event-constructor)
-  (guarantee-thread thread join-thread)
+  (guarantee-thread thread 'JOIN-THREAD)
   (let ((self (current-thread)))
     (if (eq? thread self)
 	(signal-thread-deadlock self "join thread" join-thread thread)
@@ -356,7 +357,7 @@ Inc., 59 Temple Place - Suite 330, Boston, MA 02111-1307, USA.
 		     (event-constructor thread value))))))))))
 
 (define (detach-thread thread)
-  (guarantee-thread thread detach-thread)
+  (guarantee-thread thread 'DETACH-THREAD)
   (without-interrupts
    (lambda ()
      (if (eq? (thread/exit-value thread) detached-thread-marker)
@@ -369,7 +370,7 @@ Inc., 59 Temple Place - Suite 330, Boston, MA 02111-1307, USA.
 (define (release-joined-threads thread value)
   (set-thread/exit-value! thread value)
   (do ((joined (thread/joined-threads thread) (cdr joined)))
-      ((null? joined))
+      ((not (pair? joined)))
     (let ((joined (caar joined))
 	  (event ((cdar joined) thread value)))
       (set-thread/joined-to! joined (delq! thread (thread/joined-to joined)))
@@ -378,19 +379,20 @@ Inc., 59 Temple Place - Suite 330, Boston, MA 02111-1307, USA.
 
 (define (%disassociate-joined-threads thread)
   (do ((threads (thread/joined-to thread) (cdr threads)))
-      ((null? threads))
+      ((not (pair? threads)))
     (set-thread/joined-threads!
      (car threads)
      (del-assq! thread (thread/joined-threads (car threads)))))
   (set-thread/joined-to! thread '()))
 
-;;;; Input Thread Events
+;;;; I/O Thread Events
 
-(define input-registry)
-(define input-registrations)
+(define io-registry)
+(define io-registrations)
 
 (define-structure (dentry (conc-name dentry/))
   (descriptor #f read-only #t)
+  (mode #f read-only #t)
   first-tentry
   last-tentry
   prev
@@ -405,16 +407,16 @@ Inc., 59 Temple Place - Suite 330, Boston, MA 02111-1307, USA.
   prev
   next)
 
-(define (initialize-input-blocking)
-  (set! input-registry (and have-select? (make-select-registry)))
-  (set! input-registrations #f)
+(define (initialize-io-blocking)
+  (set! io-registry (and have-select? (make-select-registry)))
+  (set! io-registrations #f)
   unspecific)
 
-(define-integrable (maybe-signal-input-thread-events)
-  (if input-registrations
-      (signal-select-result (select-registry-test input-registry #f))))
+(define (maybe-signal-io-thread-events)
+  (if io-registrations
+      (signal-select-result (test-select-registry io-registry #f))))
 
-(define (wait-for-input)
+(define (wait-for-io)
   (let ((catch-errors
 	 (lambda (thunk)
 	   (let ((thread (console-thread)))
@@ -430,7 +432,7 @@ Inc., 59 Temple Place - Suite 330, Boston, MA 02111-1307, USA.
 			  condition
 			  (within-continuation k thunk))
 		      thunk))))))))
-    (if (not input-registrations)
+    (if (not io-registrations)
 	(begin
 	  ;; Busy-waiting here is a bad idea -- should implement a
 	  ;; primitive to block the Scheme process while waiting for a
@@ -443,22 +445,22 @@ Inc., 59 Temple Place - Suite 330, Boston, MA 02111-1307, USA.
 	       (catch-errors
 		(lambda ()
 		  (set-interrupt-enables! interrupt-mask/all)
-		  (select-registry-test input-registry #t)))))
+		  (test-select-registry io-registry #t)))))
 	  (set-interrupt-enables! interrupt-mask/gc-ok)
 	  (signal-select-result result)
 	  (let ((thread first-running-thread))
 	    (if thread
 		(if (thread/continuation thread)
 		    (run-thread thread))
-		(wait-for-input)))))))
+		(wait-for-io)))))))
 
 (define (signal-select-result result)
   (cond ((pair? result)
-	 (signal-input-thread-events result))
+	 (signal-io-thread-events (car result) (cdr result)))
 	((eq? 'PROCESS-STATUS-CHANGE result)
-	 (signal-input-thread-events '(PROCESS-STATUS-CHANGE)))))
+	 (signal-io-thread-events '#(1 PROCESS-STATUS-CHANGE) '#(0)))))
 
-(define (block-on-input-descriptor descriptor)
+(define (block-on-io-descriptor descriptor mode)
   (without-interrupts
    (lambda ()
      (let ((result 'INTERRUPT)
@@ -468,18 +470,21 @@ Inc., 59 Temple Place - Suite 330, Boston, MA 02111-1307, USA.
 	(lambda ()
 	  (let ((thread (current-thread)))
 	    (set! registration-1
-		  (%register-input-thread-event
+		  (%register-io-thread-event
 		   descriptor
+		   mode
 		   thread
-		   (lambda ()
-		     (set! result 'INPUT-AVAILABLE)
+		   (lambda (mode)
+		     (set! result mode)
 		     unspecific)
 		   #f #t))
 	    (set! registration-2
-		  (%register-input-thread-event
+		  (%register-io-thread-event
 		   'PROCESS-STATUS-CHANGE
+		   'READ
 		   thread
-		   (lambda ()
+		   (lambda (mode)
+		     mode
 		     (set! result 'PROCESS-STATUS-CHANGE)
 		     unspecific)
 		   #f #t)))
@@ -488,95 +493,98 @@ Inc., 59 Temple Place - Suite 330, Boston, MA 02111-1307, USA.
 	  (%suspend-current-thread)
 	  result)
 	(lambda ()
-	  (%deregister-input-thread-event registration-1)
-	  (%deregister-input-thread-event registration-2)))))))
+	  (%deregister-io-thread-event registration-2)
+	  (%deregister-io-thread-event registration-1)))))))
 
-(define (permanently-register-input-thread-event descriptor thread event)
-  (guarantee-thread thread permanently-register-input-thread-event)
+(define (permanently-register-io-thread-event descriptor mode thread event)
+  (guarantee-thread thread 'PERMANENTLY-REGISTER-IO-THREAD-EVENT)
   (without-interrupts
    (lambda ()
-     (%register-input-thread-event descriptor thread event #t #f))))
+     (%register-io-thread-event descriptor mode thread event #t #f))))
 
-(define (register-input-thread-event descriptor thread event)
-  (guarantee-thread thread register-input-thread-event)
+(define (register-io-thread-event descriptor mode thread event)
+  (guarantee-thread thread 'REGISTER-IO-THREAD-EVENT)
   (without-interrupts
    (lambda ()
-     (%register-input-thread-event descriptor thread event #f #f))))
+     (%register-io-thread-event descriptor mode thread event #f #f))))
 
-(define (deregister-input-thread-event tentry)
+(define (deregister-io-thread-event tentry)
   (if (not (tentry? tentry))
-      (error:wrong-type-argument tentry "input thread event registration"
-				 'DEREGISTER-INPUT-THREAD-EVENT))
+      (error:wrong-type-argument tentry "I/O thread event registration"
+				 'DEREGISTER-IO-THREAD-EVENT))
   (without-interrupts
    (lambda ()
-     (%deregister-input-thread-event tentry)
+     (%deregister-io-thread-event tentry)
      (%maybe-toggle-thread-timer))))
 
-(define (deregister-input-descriptor-events descriptor)
+(define (deregister-io-descriptor-events descriptor mode)
   (without-interrupts
    (lambda ()
-     (let loop ((dentry input-registrations))
-       (if dentry
-	   (if (eqv? descriptor (dentry/descriptor dentry))
-	       (begin
-		 (if (not (eq? 'PROCESS-STATUS-CHANGE descriptor))
-		     (remove-from-select-registry! input-registry descriptor))
-		 (let ((prev (dentry/prev dentry))
-		       (next (dentry/next dentry)))
-		   (if prev
-		       (set-dentry/next! prev next)
-		       (set! input-registrations next))
-		   (if next
-		       (set-dentry/prev! next prev))))
-	       (loop (dentry/next dentry))))))))
+     (let loop ((dentry io-registrations))
+       (cond ((not dentry)
+	      unspecific)
+	     ((and (eqv? descriptor (dentry/descriptor dentry))
+		   (eq? mode (dentry/mode dentry)))
+	      (if (not (eq? 'PROCESS-STATUS-CHANGE descriptor))
+		  (remove-from-select-registry! io-registry descriptor mode))
+	      (let ((prev (dentry/prev dentry))
+		    (next (dentry/next dentry)))
+		(if prev
+		    (set-dentry/next! prev next)
+		    (set! io-registrations next))
+		(if next
+		    (set-dentry/prev! next prev))))
+	     (else
+	      (loop (dentry/next dentry))))))))
 
-(define (%register-input-thread-event descriptor thread event
-				      permanent? front?)
-  (let ((tentry (make-tentry thread event permanent?))
-	(dentry
-	 (let loop ((dentry input-registrations))
-	   (and dentry
-		(if (eqv? descriptor (dentry/descriptor dentry))
-		    dentry
-		    (loop (dentry/next dentry)))))))
-    (if (not dentry)
-	(let ((dentry (make-dentry descriptor #f #f #f #f)))
-	  (set-tentry/dentry! tentry dentry)
-	  (set-tentry/prev! tentry #f)
-	  (set-tentry/next! tentry #f)
-	  (set-dentry/first-tentry! dentry tentry)
-	  (set-dentry/last-tentry! dentry tentry)
-	  (if input-registrations
-	      (set-dentry/prev! input-registrations dentry))
-	  (set-dentry/next! dentry input-registrations)
-	  (set! input-registrations dentry)
-	  (if (not (eq? 'PROCESS-STATUS-CHANGE descriptor))
-	      (add-to-select-registry! input-registry descriptor)))
-	(begin
-	  (set-tentry/dentry! tentry dentry)
-	  (if front?
-	      (let ((next (dentry/first-tentry dentry)))
-		(set-tentry/prev! tentry #f)
-		(set-tentry/next! tentry next)
-		(set-dentry/first-tentry! dentry tentry)
-		(set-tentry/prev! next tentry))
-	      (let ((prev (dentry/last-tentry dentry)))
-		(set-tentry/prev! tentry prev)
-		(set-tentry/next! tentry #f)
-		(set-dentry/last-tentry! dentry tentry)
-		(set-tentry/next! prev tentry)))))
+(define (%register-io-thread-event descriptor mode thread event permanent?
+				   front?)
+  (let ((tentry (make-tentry thread event permanent?)))
+    (let loop ((dentry io-registrations))
+      (cond ((not dentry)
+	     (let ((dentry
+		    (make-dentry descriptor
+				 mode
+				 tentry
+				 tentry
+				 #f
+				 io-registrations)))
+	       (set-tentry/dentry! tentry dentry)
+	       (set-tentry/prev! tentry #f)
+	       (set-tentry/next! tentry #f)
+	       (if io-registrations
+		   (set-dentry/prev! io-registrations dentry))
+	       (set! io-registrations dentry)
+	       (if (not (eq? 'PROCESS-STATUS-CHANGE descriptor))
+		   (add-to-select-registry! io-registry descriptor mode))))
+	    ((and (eqv? descriptor (dentry/descriptor dentry))
+		  (eq? mode (dentry/mode dentry)))
+	     (set-tentry/dentry! tentry dentry)
+	     (if front?
+		 (let ((next (dentry/first-tentry dentry)))
+		   (set-tentry/prev! tentry #f)
+		   (set-tentry/next! tentry next)
+		   (set-dentry/first-tentry! dentry tentry)
+		   (set-tentry/prev! next tentry))
+		 (let ((prev (dentry/last-tentry dentry)))
+		   (set-tentry/prev! tentry prev)
+		   (set-tentry/next! tentry #f)
+		   (set-dentry/last-tentry! dentry tentry)
+		   (set-tentry/next! prev tentry))))
+	    (else
+	     (loop (dentry/next dentry)))))
     (%maybe-toggle-thread-timer)
     tentry))
 
-(define (%deregister-input-thread-event tentry)
+(define (%deregister-io-thread-event tentry)
   (if (tentry/dentry tentry)
       (delete-tentry! tentry)))
 
-(define (%deregister-input-thread-events thread permanent?)
-  (let loop ((dentry input-registrations) (tentries '()))
+(define (%deregister-io-thread-events thread permanent?)
+  (let loop ((dentry io-registrations) (tentries '()))
     (if (not dentry)
 	(do ((tentries tentries (cdr tentries)))
-	    ((null? tentries))
+	    ((not (pair? tentries)))
 	  (delete-tentry! (car tentries)))
 	(loop (dentry/next dentry)
 	      (let loop
@@ -590,30 +598,44 @@ Inc., 59 Temple Place - Suite 330, Boston, MA 02111-1307, USA.
 			      (cons tentry tentries)
 			      tentries))))))))
 
-(define (signal-input-thread-events descriptors)
-  (let loop ((dentry input-registrations) (events '()))
-    (cond ((not dentry)
-	   (do ((events events (cdr events)))
-	       ((null? events))
-	     (%signal-thread-event (caar events) (cdar events)))
-	   (%maybe-toggle-thread-timer))
-	  ((let ((descriptor (dentry/descriptor dentry)))
-	     (let loop ((descriptors descriptors))
-	       (and (not (null? descriptors))
-		    (or (eqv? descriptor (car descriptors))
-			(loop (cdr descriptors))))))
-	   (let ((next (dentry/next dentry))
-		 (tentry (dentry/first-tentry dentry)))
-	     (let ((events
-		    (cons (cons (tentry/thread tentry)
-				(tentry/event tentry))
-			  events)))
-	       (if (tentry/permanent? tentry)
-		   (move-tentry-to-back! tentry)
-		   (delete-tentry! tentry))
-	       (loop next events))))
-	  (else
-	   (loop (dentry/next dentry) events)))))
+(define (signal-io-thread-events vr vw)
+  (let ((search
+	 (lambda (descriptor v)
+	   (let ((n (vector-ref v 0)))
+	     (let loop ((i 1))
+	       (and (fix:<= i n)
+		    (or (eqv? descriptor (vector-ref v i))
+			(loop (fix:+ i 1)))))))))
+    (let loop ((dentry io-registrations) (events '()))
+      (if dentry
+	  (let ((mode
+		 (let ((descriptor (dentry/descriptor dentry))
+		       (mode (dentry/mode dentry)))
+		   (case mode
+		     ((READ) (and (search descriptor vr) 'READ))
+		     ((WRITE) (and (search descriptor vw) 'WRITE))
+		     ((READ/WRITE)
+		      (if (search descriptor vr)
+			  (if (search descriptor vw) 'READ/WRITE 'READ)
+			  (if (search descriptor vw) 'WRITE #f)))
+		     (else #f)))))
+	    (if mode
+		(let ((next (dentry/next dentry))
+		      (tentry (dentry/first-tentry dentry)))
+		  (let ((events
+			 (cons (cons (tentry/thread tentry)
+				     (let ((e (tentry/event tentry)))
+				       (and e
+					    (lambda () (e mode)))))
+			       events)))
+		    (if (tentry/permanent? tentry)
+			(move-tentry-to-back! tentry)
+			(delete-tentry! tentry))
+		    (loop next events)))
+		(loop (dentry/next dentry) events)))
+	  (do ((events events (cdr events)))
+	      ((not (pair? events)))
+	    (%signal-thread-event (caar events) (cdar events)))))))
 
 (define (move-tentry-to-back! tentry)
   (let ((next (tentry/next tentry)))
@@ -645,15 +667,16 @@ Inc., 59 Temple Place - Suite 330, Boston, MA 02111-1307, USA.
 	(begin
 	  (let ((descriptor (dentry/descriptor dentry)))
 	    (if (not (eq? 'PROCESS-STATUS-CHANGE descriptor))
-		(remove-from-select-registry! input-registry descriptor)))
+		(remove-from-select-registry! io-registry
+					      descriptor
+					      (dentry/mode dentry))))
 	  (let ((prev (dentry/prev dentry))
 		(next (dentry/next dentry)))
 	    (if prev
 		(set-dentry/next! prev next)
-		(set! input-registrations next))
+		(set! io-registrations next))
 	    (if next
-		(set-dentry/prev! next prev))))))
-  unspecific)
+		(set-dentry/prev! next prev)))))))
 
 ;;;; Events
 
@@ -716,7 +739,7 @@ Inc., 59 Temple Place - Suite 330, Boston, MA 02111-1307, USA.
      unspecific)))
 
 (define (signal-thread-event thread event)
-  (guarantee-thread thread signal-thread-event)
+  (guarantee-thread thread 'SIGNAL-THREAD-EVENT)
   (let ((self first-running-thread))
     (if (eq? thread self)
 	(let ((block-events? (block-thread-events)))
@@ -761,12 +784,12 @@ Inc., 59 Temple Place - Suite 330, Boston, MA 02111-1307, USA.
 	   (let ((block-events? (thread/block-events? thread)))
 	     (set-thread/block-events?! thread #f)
 	     (deliver-timer-events)
-	     (maybe-signal-input-thread-events)
+	     (maybe-signal-io-thread-events)
 	     (handle-thread-events thread)
 	     (set-thread/block-events?! thread block-events?))
 	   (begin
 	     (deliver-timer-events)
-	     (maybe-signal-input-thread-events)))))))
+	     (maybe-signal-io-thread-events)))))))
 
 ;;;; Timer Events
 
@@ -842,7 +865,7 @@ Inc., 59 Temple Place - Suite 330, Boston, MA 02111-1307, USA.
     (let ((block-events? (thread/block-events? thread)))
       (set-thread/block-events?! thread #t)
       (ring/discard-all (thread/pending-events thread))
-      (%deregister-input-thread-events thread #f)
+      (%deregister-io-thread-events thread #f)
       (%discard-thread-timer-records thread)
       (set-thread/block-events?! thread block-events?))
     (set-interrupt-enables! interrupt-mask/all)))
@@ -883,7 +906,7 @@ Inc., 59 Temple Place - Suite 330, Boston, MA 02111-1307, USA.
 
 (define (%maybe-toggle-thread-timer)
   (cond ((and timer-interval
-	      (or input-registrations
+	      (or io-registrations
 		  (let ((current-thread first-running-thread))
 		    (and current-thread
 			 (thread/next current-thread)))))
@@ -937,11 +960,11 @@ Inc., 59 Temple Place - Suite 330, Boston, MA 02111-1307, USA.
       (error:wrong-type-argument mutex "thread-mutex" procedure)))
 
 (define (thread-mutex-owner mutex)
-  (guarantee-thread-mutex mutex thread-mutex-owner)
+  (guarantee-thread-mutex mutex 'THREAD-MUTEX-OWNER)
   (thread-mutex/owner mutex))
 
 (define (lock-thread-mutex mutex)
-  (guarantee-thread-mutex mutex lock-thread-mutex)
+  (guarantee-thread-mutex mutex 'LOCK-THREAD-MUTEX)
   (without-interrupts
    (lambda ()
      (let ((thread (current-thread))
@@ -961,7 +984,7 @@ Inc., 59 Temple Place - Suite 330, Boston, MA 02111-1307, USA.
       (set-thread-mutex/owner! mutex thread)))
 
 (define (unlock-thread-mutex mutex)
-  (guarantee-thread-mutex mutex unlock-thread-mutex)
+  (guarantee-thread-mutex mutex 'UNLOCK-THREAD-MUTEX)
   (without-interrupts
    (lambda ()
      (let ((owner (thread-mutex/owner mutex)))
@@ -981,7 +1004,7 @@ Inc., 59 Temple Place - Suite 330, Boston, MA 02111-1307, USA.
     thread))
 
 (define (try-lock-thread-mutex mutex)
-  (guarantee-thread-mutex mutex try-lock-thread-mutex)
+  (guarantee-thread-mutex mutex 'TRY-LOCK-THREAD-MUTEX)
   (without-interrupts
    (lambda ()
      (and (not (thread-mutex/owner mutex))
@@ -991,7 +1014,7 @@ Inc., 59 Temple Place - Suite 330, Boston, MA 02111-1307, USA.
 	    #t)))))
 
 (define (with-thread-mutex-locked mutex thunk)
-  (guarantee-thread-mutex mutex lock-thread-mutex)
+  (guarantee-thread-mutex mutex 'WITH-THREAD-MUTEX-LOCKED)
   (let ((thread (current-thread))
 	(grabbed-lock?))
     (dynamic-wind
@@ -1011,7 +1034,7 @@ Inc., 59 Temple Place - Suite 330, Boston, MA 02111-1307, USA.
 
 (define (%disassociate-thread-mutexes thread)
   (do ((mutexes (thread/mutexes thread) (cdr mutexes)))
-      ((null? mutexes))
+      ((not (pair? mutexes)))
     (let ((mutex (car mutexes)))
       (if (eq? (thread-mutex/owner mutex) thread)
 	  (%%unlock-thread-mutex mutex)
diff --git a/v7/src/runtime/unxprm.scm b/v7/src/runtime/unxprm.scm
index 3b017d3c7..66efd2670 100644
--- a/v7/src/runtime/unxprm.scm
+++ b/v7/src/runtime/unxprm.scm
@@ -1,8 +1,10 @@
 #| -*-Scheme-*-
 
-$Id: unxprm.scm,v 1.63 2002/11/20 19:46:24 cph Exp $
+$Id: unxprm.scm,v 1.64 2003/01/22 02:05:47 cph Exp $
 
-Copyright (c) 1988-2001 Massachusetts Institute of Technology
+Copyright 1988,1989,1990,1991,1992,1993 Massachusetts Institute of Technology
+Copyright 1994,1995,1997,1998,1999,2000 Massachusetts Institute of Technology
+Copyright 2001,2003 Massachusetts Institute of Technology
 
 This file is part of MIT Scheme.
 
@@ -185,8 +187,10 @@ Inc., 59 Temple Place - Suite 330, Boston, MA 02111-1307, USA.
 	  (set-environment-variable! variable *variable-deleted*)))
 
   (set! reset-environment-variables!
-	(lambda () (set! environment-variables '())))
-) ; End LET
+	(lambda () (set! environment-variables '()))))
+
+(define (initialize-system-primitives!)
+  (add-event-receiver! event:after-restart reset-environment-variables!))
 
 (define (user-home-directory user-name)
   (let ((directory ((ucode-primitive get-user-home-directory 1) user-name)))
@@ -330,102 +334,6 @@ Inc., 59 Temple Place - Suite 330, Boston, MA 02111-1307, USA.
 					    specifier)))
 		   (user-homedir-pathname)))
 
-;;; Queues after-restart daemon to clean up environment space
-
-(define (initialize-system-primitives!)
-  (add-event-receiver! event:after-restart reset-environment-variables!)
-  (discard-select-registry-result-vectors!)
-  (add-event-receiver! event:after-restart
-		       discard-select-registry-result-vectors!))
-
-(define (make-select-registry . descriptors)
-  (let ((registry (make-string ((ucode-primitive select-registry-size 0)))))
-    ((ucode-primitive select-registry-clear-all 1) registry)
-    (do ((descriptors descriptors (cdr descriptors)))
-	((not (pair? descriptors)))
-      ((ucode-primitive select-registry-set 2) registry (car descriptors)))
-    registry))
-
-(define (add-to-select-registry! registry descriptor)
-  ((ucode-primitive select-registry-set 2) registry descriptor))
-
-(define (remove-from-select-registry! registry descriptor)
-  ((ucode-primitive select-registry-clear 2) registry descriptor))
-
-(define (select-descriptor descriptor block?)
-  (let ((result ((ucode-primitive select-descriptor 2) descriptor block?)))
-    (case result
-      ((0)
-       #f)
-      ((1)
-       'INPUT-AVAILABLE)
-      ((-1)
-       (subprocess-global-status-tick)
-       'PROCESS-STATUS-CHANGE)
-      ((-2)
-       'INTERRUPT)
-      (else
-       (error "Illegal result from CHANNEL-SELECT:" result)))))
-
-(define (select-registry-test registry block?)
-  (let ((result-vector (allocate-select-registry-result-vector)))
-    (let ((result
-	   ((ucode-primitive select-registry-test 3) registry block?
-						     result-vector)))
-      (if (fix:> result 0)
-	  (let loop ((index (fix:- result 1)) (descriptors '()))
-	    (let ((descriptors
-		   (cons (vector-ref result-vector index) descriptors)))
-	      (if (fix:= 0 index)
-		  (begin
-		    (deallocate-select-registry-result-vector result-vector)
-		    descriptors)
-		  (loop (fix:- index 1) descriptors))))
-	  (begin
-	    (deallocate-select-registry-result-vector result-vector)
-	    (cond ((fix:= 0 result)
-		   #f)
-		  ((fix:= -1 result)
-		   (subprocess-global-status-tick)
-		   'PROCESS-STATUS-CHANGE)
-		  ((fix:= -2 result)
-		   'INTERRUPT)
-		  (else
-		   (error "Illegal result from SELECT-REGISTRY-TEST:"
-			  result))))))))
-
-(define select-registry-result-vectors)
-
-(define (discard-select-registry-result-vectors!)
-  (set! select-registry-result-vectors '())
-  unspecific)
-
-(define (allocate-select-registry-result-vector)
-  (let ((interrupt-mask (set-interrupt-enables! interrupt-mask/gc-ok)))
-    (let ((v
-	   (let loop ((rv select-registry-result-vectors))
-	     (if (pair? rv)
-		 (let ((v (car rv)))
-		   (if v
-		       (begin
-			 (set-car! rv #f)
-			 v)
-		       (loop (cdr rv))))
-		 (make-vector ((ucode-primitive select-registry-lub 0)) #f)))))
-      (set-interrupt-enables! interrupt-mask)
-      v)))
-
-(define (deallocate-select-registry-result-vector v)
-  (let ((interrupt-mask (set-interrupt-enables! interrupt-mask/gc-ok)))
-    (let loop ((rv select-registry-result-vectors))
-      (if (pair? rv)
-	  (if (car rv)
-	      (loop (cdr rv))
-	      (set-car! rv v))
-	  (set! select-registry-result-vectors
-		(cons v select-registry-result-vectors))))
-    (set-interrupt-enables! interrupt-mask)))
-
 ;;;; Subprocess/Shell Support
 
 (define (os/make-subprocess filename arguments environment working-directory
diff --git a/v7/src/runtime/version.scm b/v7/src/runtime/version.scm
index a3a2d66de..14ade2c51 100644
--- a/v7/src/runtime/version.scm
+++ b/v7/src/runtime/version.scm
@@ -1,8 +1,10 @@
 #| -*-Scheme-*-
 
-$Id: version.scm,v 14.210 2002/11/20 19:46:24 cph Exp $
+$Id: version.scm,v 14.211 2003/01/22 02:05:54 cph Exp $
 
-Copyright (c) 1988-2002 Massachusetts Institute of Technology
+Copyright 1988,1989,1990,1991,1992,1993 Massachusetts Institute of Technology
+Copyright 1995,1996,1997,1998,1999,2000 Massachusetts Institute of Technology
+Copyright 2001,2002,2003 Massachusetts Institute of Technology
 
 This file is part of MIT Scheme.
 
@@ -31,7 +33,7 @@ Inc., 59 Temple Place - Suite 330, Boston, MA 02111-1307, USA.
   (add-subsystem-identification! "Release" '(7 7 2 "pre"))
   (snarf-microcode-version!)
   (add-event-receiver! event:after-restore snarf-microcode-version!)
-  (add-subsystem-identification! "Runtime" '(15 2)))
+  (add-subsystem-identification! "Runtime" '(15 3)))
 
 (define (snarf-microcode-version!)
   (add-subsystem-identification! "Microcode"
diff --git a/v7/src/runtime/x11graph.scm b/v7/src/runtime/x11graph.scm
index aea6d7a1d..d3cb5a4f3 100644
--- a/v7/src/runtime/x11graph.scm
+++ b/v7/src/runtime/x11graph.scm
@@ -1,8 +1,10 @@
 #| -*-Scheme-*-
 
-$Id: x11graph.scm,v 1.53 2002/11/20 19:46:24 cph Exp $
+$Id: x11graph.scm,v 1.54 2003/01/22 02:06:00 cph Exp $
 
-Copyright (c) 1989-2002 Massachusetts Institute of Technology
+Copyright 1989,1990,1991,1992,1993,1995 Massachusetts Institute of Technology
+Copyright 1996,1997,1998,1999,2000,2001 Massachusetts Institute of Technology
+Copyright 2002,2003 Massachusetts Institute of Technology
 
 This file is part of MIT Scheme.
 
@@ -265,10 +267,12 @@ Inc., 59 Temple Place - Suite 330, Boston, MA 02111-1307, USA.
 (define (make-event-previewer display)
   (let ((registration))
     (set! registration
-	  (permanently-register-input-thread-event
+	  (permanently-register-io-thread-event
 	   (x-display-descriptor (x-display/xd display))
+	   'READ
 	   (current-thread)
-	   (lambda ()
+	   (lambda (mode)
+	     mode
 	     (call-with-current-continuation
 	      (lambda (continuation)
 		(bind-condition-handler
@@ -280,7 +284,7 @@ Inc., 59 Temple Place - Suite 330, Boston, MA 02111-1307, USA.
 		      ;; on its display argument, that means the
 		      ;; display has been closed.
 		      condition
-		      (deregister-input-thread-event registration)
+		      (deregister-io-thread-event registration)
 		      (continuation unspecific))
 		  (lambda ()
 		    (let ((event
@@ -303,10 +307,11 @@ Inc., 59 Temple Place - Suite 330, Boston, MA 02111-1307, USA.
 
 (define (%read-and-process-event display)
   (let ((event
-	 (and (eq? 'INPUT-AVAILABLE
-		   (test-for-input-on-descriptor
+	 (and (eq? 'READ
+		   (test-for-io-on-descriptor
 		    (x-display-descriptor (x-display/xd display))
-		    #t))
+		    #t
+		    'READ))
 	      (x-display-process-events (x-display/xd display) 1))))
     (if event
 	(process-event display event))))
diff --git a/v7/src/swat/scheme/mit-xhooks.scm b/v7/src/swat/scheme/mit-xhooks.scm
index e93c43443..e1b3b129d 100644
--- a/v7/src/swat/scheme/mit-xhooks.scm
+++ b/v7/src/swat/scheme/mit-xhooks.scm
@@ -317,9 +317,13 @@ end of debugging stuff
 	  (if (and code (not (scxl-destroyed? (weak-car wcdr))))
 	      (begin
 		;; Reinstall interrupt handler, then run user code
-		(register-input-thread-event
+		(register-io-thread-event
 		 (XConnectionNumber (weak-car wcdr))
-		 uitk-thread (weak-cdr wcdr))
+		 'READ
+		 uitk-thread
+		 (lambda (mode)
+		   mode
+		   ((weak-cdr wcdr))))
 		(code))))))
     (define (call-if-still-there weak)
       ;; WEAK is a weak-list:
@@ -346,15 +350,20 @@ end of debugging stuff
 	    (weak (weak-cons child-work-code (weak-cons display #F))))
 	(without-interrupts
 	 (lambda ()
-	   (register-input-thread-event
-	    file uitk-thread (call-if-still-there weak))))))))
+	   (register-io-thread-event
+	    file
+	    'READ
+	    uitk-thread
+	    (lambda (mode)
+	      mode
+	      (call-if-still-there weak)))))))))
 
 (define (destroy-registration registration)
-  (deregister-input-thread-event registration)
+  (deregister-io-thread-event registration)
   'OK)
 
 (define (shut-down-event-server display-number)
-  (deregister-input-descriptor-events (%XConnectionNumber display-number)))
+  (deregister-io-descriptor-events (%XConnectionNumber display-number) 'READ))
 
 
 ;;;Delayed events