Make threadWaitRead/threadWaitWrite partially useable on Windows

They work with -threaded by calling fdReady() in a separate thread.

"threadWaitRead 0" also works without -threaded (because we happen to
know it's virtually equivalent to "hWaitForInput stdin (-1)").

diff --git a/Control/Concurrent.hs b/Control/Concurrent.hs
index 632946d..aa40b81 100644 (file)
--- a/Control/Concurrent.hs
+++ b/Control/Concurrent.hs
@@ -96,17 +96,24 @@ import Control.Exception as Exception
 
 #ifdef __GLASGOW_HASKELL__
 import GHC.Conc         ( ThreadId(..), myThreadId, killThread, yield,
-                          threadDelay, threadWaitRead, threadWaitWrite,
-                          forkIO, childHandler )
+                          threadDelay, forkIO, childHandler )
+import qualified GHC.Conc
 import GHC.TopHandler   ( reportStackOverflow, reportError )
 import GHC.IOBase       ( IO(..) )
 import GHC.IOBase       ( unsafeInterleaveIO )
 import GHC.IOBase       ( newIORef, readIORef, writeIORef )
 import GHC.Base
 
+import System.Posix.Types ( Fd )
 import Foreign.StablePtr
 import Foreign.C.Types  ( CInt )
 import Control.Monad    ( when )
+
+#ifdef mingw32_HOST_OS
+import Foreign.C
+import System.IO
+import GHC.Handle
+#endif
 #endif
 
 #ifdef __HUGS__
@@ -411,6 +418,63 @@ runInUnboundThread action = do
 #endif /* __GLASGOW_HASKELL__ */
 
 -- ---------------------------------------------------------------------------
+-- threadWaitRead/threadWaitWrite
+
+-- | Block the current thread until data is available to read on the
+-- given file descriptor (GHC only).
+threadWaitRead :: Fd -> IO ()
+threadWaitRead fd
+#ifdef mingw32_HOST_OS
+  -- we have no IO manager implementing threadWaitRead on Windows.
+  -- fdReady does the right thing, but we have to call it in a
+  -- separate thread, otherwise threadWaitRead won't be interruptible,
+  -- and this only works with -threaded.
+  | threaded  = withThread (waitFd fd 0)
+  | otherwise = case fd of
+                  0 -> do hWaitForInput stdin (-1); return ()
+                        -- hWaitForInput does work properly, but we can only
+                        -- do this for stdin since we know its FD.
+                  _ -> error "threadWaitRead requires -threaded on Windows, or use System.IO.hWaitForInput"
+#else
+  = GHC.Conc.threadWaitRead fd
+#endif
+
+-- | Block the current thread until data can be written to the
+-- given file descriptor (GHC only).
+threadWaitWrite :: Fd -> IO ()
+threadWaitWrite fd
+#ifdef mingw32_HOST_OS
+  | threaded  = withThread (waitFd fd 1)
+  | otherwise = error "threadWaitWrite requires -threaded on Windows"
+#else
+  = GHC.Conc.threadWaitWrite fd
+#endif
+
+#ifdef mingw32_HOST_OS
+foreign import ccall unsafe "rtsSupportsBoundThreads" threaded :: Bool
+
+withThread :: IO a -> IO a
+withThread io = do
+  m <- newEmptyMVar
+  forkIO $ try io >>= putMVar m
+  x <- takeMVar m
+  case x of
+    Right a -> return a
+    Left e  -> throwIO e
+
+waitFd :: Fd -> CInt -> IO ()
+waitFd fd write = do
+   throwErrnoIfMinus1 "fdReady" $
+        fdReady (fromIntegral fd) write (fromIntegral iNFINITE) 0
+   return ()
+
+iNFINITE = 0xFFFFFFFF :: CInt -- urgh
+
+foreign import ccall safe "fdReady"
+  fdReady :: CInt -> CInt -> CInt -> CInt -> IO CInt
+#endif
+
+-- ---------------------------------------------------------------------------
 -- More docs
 
 {- $osthreads

diff --git a/GHC/Handle.hs b/GHC/Handle.hs
index bbab74d..a5ab3c9 100644 (file)
--- a/GHC/Handle.hs
+++ b/GHC/Handle.hs
@@ -562,7 +562,7 @@ readRawBuffer :: String -> FD -> Bool -> RawBuffer -> Int -> CInt -> IO CInt
 readRawBuffer loc fd is_nonblock buf off len
   | is_nonblock  = unsafe_read -- unsafe is ok, it can't block
   | otherwise    = do r <- throwErrnoIfMinus1 loc 
-                                (unsafe_fdReady (fromIntegral fd) 0 0 False)
+                                (unsafe_fdReady (fromIntegral fd) 0 0 0)
                       if r /= 0
                         then read
                         else do threadWaitRead (fromIntegral fd); read
@@ -577,7 +577,7 @@ readRawBufferPtr :: String -> FD -> Bool -> Ptr CChar -> Int -> CInt -> IO CInt
 readRawBufferPtr loc fd is_nonblock buf off len
   | is_nonblock  = unsafe_read -- unsafe is ok, it can't block
   | otherwise    = do r <- throwErrnoIfMinus1 loc 
-                                (unsafe_fdReady (fromIntegral fd) 0 0 False)
+                                (unsafe_fdReady (fromIntegral fd) 0 0 0)
                       if r /= 0 
                         then read
                         else do threadWaitRead (fromIntegral fd); read
@@ -591,7 +591,7 @@ readRawBufferPtr loc fd is_nonblock buf off len
 readRawBufferNoBlock :: String -> FD -> Bool -> RawBuffer -> Int -> CInt -> IO CInt
 readRawBufferNoBlock loc fd is_nonblock buf off len
   | is_nonblock  = unsafe_read -- unsafe is ok, it can't block
-  | otherwise    = do r <- unsafe_fdReady (fromIntegral fd) 0 0 False
+  | otherwise    = do r <- unsafe_fdReady (fromIntegral fd) 0 0 0
                       if r /= 0 then safe_read
                                 else return 0
        -- XXX see note [nonblock]
@@ -603,7 +603,7 @@ readRawBufferNoBlock loc fd is_nonblock buf off len
 readRawBufferPtrNoBlock :: String -> FD -> Bool -> Ptr CChar -> Int -> CInt -> IO CInt
 readRawBufferPtrNoBlock loc fd is_nonblock buf off len
   | is_nonblock  = unsafe_read -- unsafe is ok, it can't block
-  | otherwise    = do r <- unsafe_fdReady (fromIntegral fd) 0 0 False
+  | otherwise    = do r <- unsafe_fdReady (fromIntegral fd) 0 0 0
                       if r /= 0 then safe_read
                                 else return 0
        -- XXX see note [nonblock]
@@ -615,7 +615,7 @@ readRawBufferPtrNoBlock loc fd is_nonblock buf off len
 writeRawBuffer :: String -> FD -> Bool -> RawBuffer -> Int -> CInt -> IO CInt
 writeRawBuffer loc fd is_nonblock buf off len
   | is_nonblock = unsafe_write -- unsafe is ok, it can't block
-  | otherwise   = do r <- unsafe_fdReady (fromIntegral fd) 1 0 False
+  | otherwise   = do r <- unsafe_fdReady (fromIntegral fd) 1 0 0
                      if r /= 0 
                         then write
                         else do threadWaitWrite (fromIntegral fd); write
@@ -629,7 +629,7 @@ writeRawBuffer loc fd is_nonblock buf off len
 writeRawBufferPtr :: String -> FD -> Bool -> Ptr CChar -> Int -> CInt -> IO CInt
 writeRawBufferPtr loc fd is_nonblock buf off len
   | is_nonblock = unsafe_write -- unsafe is ok, it can't block
-  | otherwise   = do r <- unsafe_fdReady (fromIntegral fd) 1 0 False
+  | otherwise   = do r <- unsafe_fdReady (fromIntegral fd) 1 0 0
                      if r /= 0 
                         then write
                         else do threadWaitWrite (fromIntegral fd); write
@@ -652,11 +652,8 @@ foreign import ccall unsafe "__hscore_PrelHandle_write"
 foreign import ccall unsafe "__hscore_PrelHandle_write"
    write_off :: CInt -> Ptr CChar -> Int -> CInt -> IO CInt
 
-foreign import ccall safe "fdReady"
-  fdReady :: CInt -> CInt -> CInt -> Bool -> IO CInt
-
 foreign import ccall unsafe "fdReady"
-  unsafe_fdReady :: CInt -> CInt -> CInt -> Bool -> IO CInt
+  unsafe_fdReady :: CInt -> CInt -> CInt -> CInt -> IO CInt
 
 #else /* mingw32_HOST_OS.... */