base: Fix fdReady() returning immediately for pipes on Windows.

See https://ghc.haskell.org/trac/ghc/ticket/13497#comment:17

Until now, the program

  import System.IO
  main = hWaitForInput stdin (5 * 1000)

didn't wait 5 seconds for input on Winodws, it terminated immediately.

This was because the `PeekNamedPipe()` function introduced in commit
94fee9e7 really only peeks, it doesn't block.  So if there's no data,
`fdReady(fd, msec)` would return immediately even when the given `msec`
timeout is not zero.

This commit fixes it by looping around `PeekNamedPipe()` with a `sleep(1
ms)`.

Apparently there's no better way to do this on Windows without switching
to IOCP.

In any case, this change should be strictly better than what was there
before.

Reviewers: bgamari, austin, hvr

Reviewed By: bgamari

Subscribers: Phyx, rwbarton, thomie

Differential Revision: https://phabricator.haskell.org/D3956

1 files changed, 30 insertions, 16 deletions

diff --git a/libraries/base/cbits/inputReady.c b/libraries/base/cbits/inputReady.c
index ab2a1c2197..ddeee664d6 100644
--- a/libraries/base/cbits/inputReady.c
+++ b/libraries/base/cbits/inputReady.c
@@ -17,6 +17,9 @@
  * descriptor 'fd' within 'msecs' milliseconds (or indefinitely if 'msecs' is
  * negative). "Input is available" is defined as 'can I safely read at least a
  * *character* from this file object without blocking?'
+ *
+ * This function blocks until either `msecs` have passed, or input is
+ * available.
  */
 int
 fdReady(int fd, int write, int msecs, int isSock)
@@ -100,7 +103,7 @@ fdReady(int fd, int write, int msecs, int isSock)
     } else {
         DWORD rc;
         HANDLE hFile = (HANDLE)_get_osfhandle(fd);
-        DWORD avail;
+        DWORD avail = 0;
 
         Time remaining = MSToTime(msecs);
 
@@ -187,23 +190,34 @@ fdReady(int fd, int write, int msecs, int isSock)
                 // WaitForMultipleObjects() doesn't work for pipes (it
                 // always returns WAIT_OBJECT_0 even when no data is
                 // available).  If the HANDLE is a pipe, therefore, we try
-                // PeekNamedPipe:
+                // PeekNamedPipe():
                 //
-                rc = PeekNamedPipe( hFile, NULL, 0, NULL, &avail, NULL );
-                if (rc != 0) {
-                    if (avail != 0) {
-                        return 1;
+                // PeekNamedPipe() does not block, so if it returns that
+                // there is no new data, we have to sleep and try again.
+                while (avail == 0) {
+                    rc = PeekNamedPipe( hFile, NULL, 0, NULL, &avail, NULL );
+                    if (rc != 0) {
+                        if (avail != 0) {
+                            return 1;
+                        } else { // no new data
+                            if (msecs > 0) {
+                                Time now = getProcessElapsedTime();
+                                if (now >= endTime) return 0;
+                                Sleep(1); // 1 millisecond (smallest possible time on Windows)
+                                continue;
+                            } else {
+                                return 0;
+                            }
+                        }
                     } else {
-                        return 0;
-                    }
-                } else {
-                    rc = GetLastError();
-                    if (rc == ERROR_BROKEN_PIPE) {
-                        return 1; // this is probably what we want
-                    }
-                    if (rc != ERROR_INVALID_HANDLE && rc != ERROR_INVALID_FUNCTION) {
-                        maperrno();
-                        return -1;
+                        rc = GetLastError();
+                        if (rc == ERROR_BROKEN_PIPE) {
+                            return 1; // this is probably what we want
+                        }
+                        if (rc != ERROR_INVALID_HANDLE && rc != ERROR_INVALID_FUNCTION) {
+                            maperrno();
+                            return -1;
+                        }
                     }
                 }
                 /* PeekNamedPipe didn't work - fall through to the general case */