From: Matt Birkholz <matt@birkholz.chandler.az.us>
Date: Fri, 7 Sep 2012 17:24:50 +0000 (-0700)
Subject: Merge branch 'master' into Gtk
X-Git-Tag: mit-scheme-pucked-9.2.12~555
X-Git-Url: https://birchwood-abbey.net/git?a=commitdiff_plain;h=84e840bdcb8dfa7b3d73403845e60c1ff06f199d;p=mit-scheme.git

Merge branch 'master' into Gtk
---

84e840bdcb8dfa7b3d73403845e60c1ff06f199d
diff --cc src/microcode/osio.h
index ee70c639e,73616c2e3..3265f7636
--- a/src/microcode/osio.h
+++ b/src/microcode/osio.h
@@@ -112,6 -109,6 +112,7 @@@ extern int OS_test_select_registr
    (select_registry_t registry, int blockp);
  extern int OS_test_select_descriptor
    (int fd, int blockp, unsigned int mode);
+ extern int OS_pause (void);
 +extern select_registry_t arg_select_registry (int arg_number);
  
  #endif /* SCM_OSIO_H */
diff --cc src/microcode/uxio.c
index d939e3a33,2781a0182..d8af4a2ad
--- a/src/microcode/uxio.c
+++ b/src/microcode/uxio.c
@@@ -566,13 -595,10 +606,10 @@@ OS_test_select_registry (select_registr
    struct select_registry_s * r = registry;
    while (1)
      {
-       int nfds
- 	= (poll ((SR_ENTRIES (r)),
- 		 (SR_N_FDS (r)),
- 		 (blockp ? INFTIM : 0)));
-       if (nfds > 0)
+       int nfds = (safe_poll ((SR_ENTRIES (r)), (SR_N_FDS (r)), blockp));
+       if (nfds >= 0)
  	return (nfds);
 -      if (errno != EINTR)
 +      if (nfds < 0 && errno != EINTR)
  	error_system_call (errno, syscall_select);
        if (OS_process_any_status_change ())
  	return (SELECT_PROCESS_STATUS_CHANGE);
@@@ -591,10 -615,12 +626,10 @@@ OS_test_select_descriptor (int fd, int 
    ((pfds [0]) . events) = (DECODE_MODE (mode));
    while (1)
      {
-       int nfds = (poll (pfds, 1, (blockp ? INFTIM : 0)));
+       int nfds = (safe_poll (pfds, 1, blockp));
        if (nfds > 0)
  	return (ENCODE_MODE ((pfds [0]) . revents));
 -      if (nfds == 0)
 -	return (0);
 -      if (errno != EINTR)
 +      if (nfds < 0 && errno != EINTR)
  	error_system_call (errno, syscall_select);
        if (OS_process_any_status_change ())
  	return (SELECT_PROCESS_STATUS_CHANGE);
@@@ -724,24 -789,18 +800,18 @@@ OS_test_select_registry (select_registr
  {
  #ifdef HAVE_SELECT
    struct select_registry_s * r = registry;
+ 
+   (* (SR_RREADERS (r))) = (* (SR_QREADERS (r)));
+   (* (SR_RWRITERS (r))) = (* (SR_QWRITERS (r)));
    while (1)
      {
-       int nfds;
- 
-       (* (SR_RREADERS (r))) = (* (SR_QREADERS (r)));
-       (* (SR_RWRITERS (r))) = (* (SR_QWRITERS (r)));
-       INTERRUPTABLE_EXTENT
- 	(nfds,
- 	 ((OS_process_any_status_change ())
- 	  ? ((errno = EINTR), (-1))
- 	  : (UX_select (FD_SETSIZE,
- 			(SR_RREADERS (r)),
- 			(SR_RWRITERS (r)),
- 			0,
- 			(blockp ? 0 : (&zero_timeout))))));
-       if (nfds > 0)
+       int nfds = (safe_select (FD_SETSIZE,
+ 			       (SR_RREADERS (r)),
+ 			       (SR_RWRITERS (r)),
+ 			       blockp));
+       if (nfds >= 0)
  	return (nfds);
 -      if (errno != EINTR)
 +      if (nfds < 0 && errno != EINTR)
  	error_system_call (errno, syscall_select);
        if (OS_process_any_status_change ())
  	return (SELECT_PROCESS_STATUS_CHANGE);
diff --cc src/runtime/thread.scm
index 4e41e456c,9f51e466a..2a99f9e04
--- a/src/runtime/thread.scm
+++ b/src/runtime/thread.scm
@@@ -475,35 -454,19 +475,26 @@@ USA
  			  condition
  			  (within-continuation k thunk))
  		      thunk))))))))
-     (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
- 	  ;; signal.
- 	  (catch-errors
- 	   (lambda ()
- 	     (set-interrupt-enables! interrupt-mask/all)
- 	     (do () (#f)))))
- 	(let ((result
- 	       (catch-errors
- 		(lambda ()
- 		  (%trace ";wait-for-io: blocking for i/o\n")
- 		  (set-interrupt-enables! interrupt-mask/all)
- 		  (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)
- 		    (begin
- 		      (%trace ";wait-for-io: running "thread"\n")
- 		      (run-thread thread))
- 		    (begin
- 		      (%trace ";wait-for-io: continuing "thread"\n")
- 		      (%maybe-toggle-thread-timer)))
+     (let ((result
+ 	   (catch-errors
+ 	    (lambda ()
++	      (%trace ";wait-for-io: blocking for i/o\n")
+ 	      (set-interrupt-enables! interrupt-mask/all)
+ 	      (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)
 -		(%maybe-toggle-thread-timer))
 -	    (wait-for-io))))))
++		(begin
++		  (%trace ";wait-for-io: running "thread"\n")
++		  (run-thread thread))
 +		(begin
- 		  (%trace ";wait-for-io: looping\n")
- 		  (wait-for-io))))))))
++		  (%trace ";wait-for-io: continuing "thread"\n")
++		  (%maybe-toggle-thread-timer)))
++	    (begin
++	      (%trace ";wait-for-io: looping\n")
++	      (wait-for-io)))))))
  
  (define (signal-select-result result)
    (cond ((vector? result)