From ea7f925de8c7bd879d20dcb9ce9dd8da9e6e8855 Mon Sep 17 00:00:00 2001 From: Simon Marlow Date: Wed, 9 Jul 2008 11:10:08 +0000 Subject: [PATCH] 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)"). --- Control/Concurrent.hs | 68 +++++++++++++++++++++++++++++++++++++++++++++++-- GHC/Handle.hs | 17 +++++-------- 2 files changed, 73 insertions(+), 12 deletions(-) diff --git a/Control/Concurrent.hs b/Control/Concurrent.hs index 632946d..aa40b81 100644 --- 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 --- 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.... */ -- 1.7.10.4