X-Git-Url: http://git.megacz.com/?a=blobdiff_plain;ds=sidebyside;f=GHC%2FHandle.hs;h=acc8418ec0162863b519b0a5e67975bc19e8e493;hb=e2f774794106aa61cffb56eec802f0eeddc52635;hp=d1f026c378c6ea8a335199db11874dd576b6835d;hpb=252df78b35918b7ac6113949c864a4668d951f6e;p=ghc-base.git diff --git a/GHC/Handle.hs b/GHC/Handle.hs index d1f026c..acc8418 100644 --- a/GHC/Handle.hs +++ b/GHC/Handle.hs @@ -22,15 +22,12 @@ module GHC.Handle ( wantWritableHandle, wantReadableHandle, wantSeekableHandle, newEmptyBuffer, allocateBuffer, readCharFromBuffer, writeCharIntoBuffer, - flushWriteBufferOnly, flushWriteBuffer, flushReadBuffer, fillReadBuffer, + flushWriteBufferOnly, flushWriteBuffer, flushReadBuffer, + fillReadBuffer, fillReadBufferWithoutBlocking, readRawBuffer, readRawBufferPtr, writeRawBuffer, writeRawBufferPtr, unlockFile, - {- ought to be unnecessary, but just in case.. -} - write_off, write_rawBuffer, - read_off, read_rawBuffer, - ioe_closedHandle, ioe_EOF, ioe_notReadable, ioe_notWritable, stdin, stdout, stderr, @@ -493,90 +490,185 @@ fillReadBufferLoop fd is_line is_stream buf b w size = do else return buf{ bufRPtr=0, bufWPtr=w+res' } +fillReadBufferWithoutBlocking :: FD -> Bool -> Buffer -> IO Buffer +fillReadBufferWithoutBlocking fd is_stream + buf@Buffer{ bufBuf=b, bufRPtr=r, bufWPtr=w, bufSize=size } = + -- buffer better be empty: + assert (r == 0 && w == 0) $ do +#ifdef DEBUG_DUMP + puts ("fillReadBufferLoopNoBlock: bytes = " ++ show bytes ++ "\n") +#endif + res <- readRawBufferNoBlock "fillReadBuffer" fd is_stream b + 0 (fromIntegral size) + let res' = fromIntegral res +#ifdef DEBUG_DUMP + puts ("fillReadBufferLoopNoBlock: res' = " ++ show res' ++ "\n") +#endif + return buf{ bufRPtr=0, bufWPtr=res' } + -- Low level routines for reading/writing to (raw)buffers: #ifndef mingw32_TARGET_OS readRawBuffer :: String -> FD -> Bool -> RawBuffer -> Int -> CInt -> IO CInt readRawBuffer loc fd is_stream buf off len = throwErrnoIfMinus1RetryMayBlock loc - (read_rawBuffer fd is_stream buf off len) + (read_rawBuffer fd buf off len) (threadWaitRead fd) +readRawBufferNoBlock :: String -> FD -> Bool -> RawBuffer -> Int -> CInt -> IO CInt +readRawBufferNoBlock loc fd is_stream buf off len = + throwErrnoIfMinus1RetryOnBlock loc + (read_rawBuffer fd buf off len) + (return 0) + readRawBufferPtr :: String -> FD -> Bool -> Ptr CChar -> Int -> CInt -> IO CInt readRawBufferPtr loc fd is_stream buf off len = throwErrnoIfMinus1RetryMayBlock loc - (read_off fd is_stream buf off len) + (read_off fd buf off len) (threadWaitRead fd) writeRawBuffer :: String -> FD -> Bool -> RawBuffer -> Int -> CInt -> IO CInt writeRawBuffer loc fd is_stream buf off len = throwErrnoIfMinus1RetryMayBlock loc - (write_rawBuffer (fromIntegral fd) is_stream buf off len) + (write_rawBuffer (fromIntegral fd) buf off len) (threadWaitWrite fd) writeRawBufferPtr :: String -> FD -> Bool -> Ptr CChar -> Int -> CInt -> IO CInt writeRawBufferPtr loc fd is_stream buf off len = throwErrnoIfMinus1RetryMayBlock loc - (write_off (fromIntegral fd) is_stream buf off len) + (write_off (fromIntegral fd) buf off len) (threadWaitWrite fd) foreign import ccall unsafe "__hscore_PrelHandle_read" - read_rawBuffer :: FD -> Bool -> RawBuffer -> Int -> CInt -> IO CInt + read_rawBuffer :: FD -> RawBuffer -> Int -> CInt -> IO CInt foreign import ccall unsafe "__hscore_PrelHandle_read" - read_off :: FD -> Bool -> Ptr CChar -> Int -> CInt -> IO CInt + read_off :: FD -> Ptr CChar -> Int -> CInt -> IO CInt foreign import ccall unsafe "__hscore_PrelHandle_write" - write_rawBuffer :: CInt -> Bool -> RawBuffer -> Int -> CInt -> IO CInt + write_rawBuffer :: CInt -> RawBuffer -> Int -> CInt -> IO CInt foreign import ccall unsafe "__hscore_PrelHandle_write" - write_off :: CInt -> Bool -> Ptr CChar -> Int -> CInt -> IO CInt + write_off :: CInt -> Ptr CChar -> Int -> CInt -> IO CInt + +#else /* mingw32_TARGET_OS.... */ -#else readRawBuffer :: String -> FD -> Bool -> RawBuffer -> Int -> CInt -> IO CInt -readRawBuffer loc fd is_stream buf off len = do - (l, rc) <- asyncReadBA fd (if is_stream then 1 else 0) (fromIntegral len) off buf - if l == (-1) - then - ioError (errnoToIOError loc (Errno (fromIntegral rc)) Nothing Nothing) - else return (fromIntegral l) +readRawBuffer loc fd is_stream buf off len + | threaded = blockingReadRawBuffer loc fd is_stream buf off len + | otherwise = asyncReadRawBuffer loc fd is_stream buf off len readRawBufferPtr :: String -> FD -> Bool -> Ptr CChar -> Int -> CInt -> IO CInt -readRawBufferPtr loc fd is_stream buf off len = do - (l, rc) <- asyncRead fd (if is_stream then 1 else 0) (fromIntegral len) (buf `plusPtr` off) - if l == (-1) - then - ioError (errnoToIOError loc (Errno (fromIntegral rc)) Nothing Nothing) - else return (fromIntegral l) +readRawBufferPtr loc fd is_stream buf off len + | threaded = blockingReadRawBufferPtr loc fd is_stream buf off len + | otherwise = asyncReadRawBufferPtr loc fd is_stream buf off len writeRawBuffer :: String -> FD -> Bool -> RawBuffer -> Int -> CInt -> IO CInt -writeRawBuffer loc fd is_stream buf off len = do - (l, rc) <- asyncWriteBA fd (if is_stream then 1 else 0) (fromIntegral len) off buf - if l == (-1) - then - ioError (errnoToIOError loc (Errno (fromIntegral rc)) Nothing Nothing) - else return (fromIntegral l) +writeRawBuffer loc fd is_stream buf off len + | threaded = blockingWriteRawBuffer loc fd is_stream buf off len + | otherwise = asyncWriteRawBuffer loc fd is_stream buf off len writeRawBufferPtr :: String -> FD -> Bool -> Ptr CChar -> Int -> CInt -> IO CInt -writeRawBufferPtr loc fd is_stream buf off len = do - (l, rc) <- asyncWrite fd (if is_stream then 1 else 0) (fromIntegral len) (buf `plusPtr` off) - if l == (-1) - then - ioError (errnoToIOError loc (Errno (fromIntegral rc)) Nothing Nothing) - else return (fromIntegral l) - -foreign import ccall unsafe "__hscore_PrelHandle_read" - read_rawBuffer :: FD -> Bool -> RawBuffer -> Int -> CInt -> IO CInt - -foreign import ccall unsafe "__hscore_PrelHandle_read" - read_off :: FD -> Bool -> Ptr CChar -> Int -> CInt -> IO CInt - -foreign import ccall unsafe "__hscore_PrelHandle_write" - write_rawBuffer :: CInt -> Bool -> RawBuffer -> Int -> CInt -> IO CInt - -foreign import ccall unsafe "__hscore_PrelHandle_write" - write_off :: CInt -> Bool -> Ptr CChar -> Int -> CInt -> IO CInt - +writeRawBufferPtr loc fd is_stream buf off len + | threaded = blockingWriteRawBufferPtr loc fd is_stream buf off len + | otherwise = asyncWriteRawBufferPtr loc fd is_stream buf off len + +-- ToDo: we don't have a non-blocking primitve read on Win32 +readRawBufferNoBlock :: String -> FD -> Bool -> RawBuffer -> Int -> CInt -> IO CInt +readRawBufferNoBlock = readRawBufferNoBlock + +-- Async versions of the read/write primitives, for the non-threaded RTS + +asyncReadRawBuffer loc fd is_stream buf off len = do + (l, rc) <- asyncReadBA fd (if is_stream then 1 else 0) + (fromIntegral len) off buf + if l == (-1) + then + ioError (errnoToIOError loc (Errno (fromIntegral rc)) Nothing Nothing) + else return (fromIntegral l) + +asyncReadRawBufferPtr loc fd is_stream buf off len = do + (l, rc) <- asyncRead fd (if is_stream then 1 else 0) + (fromIntegral len) (buf `plusPtr` off) + if l == (-1) + then + ioError (errnoToIOError loc (Errno (fromIntegral rc)) Nothing Nothing) + else return (fromIntegral l) + +asyncWriteRawBuffer loc fd is_stream buf off len = do + (l, rc) <- asyncWriteBA fd (if is_stream then 1 else 0) + (fromIntegral len) off buf + if l == (-1) + then + ioError (errnoToIOError loc (Errno (fromIntegral rc)) Nothing Nothing) + else return (fromIntegral l) + +asyncWriteRawBufferPtr loc fd is_stream buf off len = do + (l, rc) <- asyncWrite fd (if is_stream then 1 else 0) + (fromIntegral len) (buf `plusPtr` off) + if l == (-1) + then + ioError (errnoToIOError loc (Errno (fromIntegral rc)) Nothing Nothing) + else return (fromIntegral l) + +-- Blocking versions of the read/write primitives, for the threaded RTS + +blockingReadRawBuffer loc fd True buf off len = + throwErrnoIfMinus1Retry loc $ + recv_rawBuffer fd buf off len +blockingReadRawBuffer loc fd False buf off len = + throwErrnoIfMinus1Retry loc $ + read_rawBuffer fd buf off len + +blockingReadRawBufferPtr loc fd True buf off len = + throwErrnoIfMinus1Retry loc $ + recv_off fd buf off len +blockingReadRawBufferPtr loc fd False buf off len = + throwErrnoIfMinus1Retry loc $ + read_off fd buf off len + +blockingWriteRawBuffer loc fd True buf off len = + throwErrnoIfMinus1Retry loc $ + send_rawBuffer (fromIntegral fd) buf off len +blockingWriteRawBuffer loc fd False buf off len = + throwErrnoIfMinus1Retry loc $ + write_rawBuffer (fromIntegral fd) buf off len + +blockingWriteRawBufferPtr loc fd True buf off len = + throwErrnoIfMinus1Retry loc $ + send_off (fromIntegral fd) buf off len +blockingWriteRawBufferPtr loc fd False buf off len = + throwErrnoIfMinus1Retry loc $ + write_off (fromIntegral fd) buf off len + +-- NOTE: "safe" versions of the read/write calls for use by the threaded RTS. +-- These calls may block, but that's ok. + +foreign import ccall safe "__hscore_PrelHandle_read" + read_rawBuffer :: FD -> RawBuffer -> Int -> CInt -> IO CInt + +foreign import ccall safe "__hscore_PrelHandle_read" + read_off :: FD -> Ptr CChar -> Int -> CInt -> IO CInt + +foreign import ccall safe "__hscore_PrelHandle_write" + write_rawBuffer :: CInt -> RawBuffer -> Int -> CInt -> IO CInt + +foreign import ccall safe "__hscore_PrelHandle_write" + write_off :: CInt -> Ptr CChar -> Int -> CInt -> IO CInt + +foreign import ccall safe "__hscore_PrelHandle_recv" + recv_rawBuffer :: FD -> RawBuffer -> Int -> CInt -> IO CInt + +foreign import ccall safe "__hscore_PrelHandle_recv" + recv_off :: FD -> Ptr CChar -> Int -> CInt -> IO CInt + +foreign import ccall safe "__hscore_PrelHandle_send" + send_rawBuffer :: CInt -> RawBuffer -> Int -> CInt -> IO CInt + +foreign import ccall safe "__hscore_PrelHandle_send" + send_off :: CInt -> Ptr CChar -> Int -> CInt -> IO CInt + +foreign import ccall "rtsSupportsBoundThreads" threaded :: Bool #endif -- --------------------------------------------------------------------------- @@ -699,7 +791,10 @@ openFile' filepath mode binary = throwErrnoIfMinus1Retry "openFile" (c_open f (fromIntegral oflags) 0o666) - openFd fd Nothing filepath mode binary truncate + openFd fd Nothing False filepath mode binary truncate + `catchException` \e -> do c_close (fromIntegral fd); throw e + -- NB. don't forget to close the FD if openFd fails, otherwise + -- this FD leaks. -- ASSERT: if we just created the file, then openFd won't fail -- (so we don't need to worry about removing the newly created file -- in the event of an error). @@ -715,8 +810,8 @@ append_flags = write_flags .|. o_APPEND -- --------------------------------------------------------------------------- -- openFd -openFd :: FD -> Maybe FDType -> FilePath -> IOMode -> Bool -> Bool -> IO Handle -openFd fd mb_fd_type filepath mode binary truncate = do +openFd :: FD -> Maybe FDType -> Bool -> FilePath -> IOMode -> Bool -> Bool -> IO Handle +openFd fd mb_fd_type is_socket filepath mode binary truncate = do -- turn on non-blocking mode setNonBlockingFD fd @@ -733,15 +828,15 @@ openFd fd mb_fd_type filepath mode binary truncate = do case mb_fd_type of Just x -> return x Nothing -> fdType fd - let is_stream = fd_type == Stream + case fd_type of Directory -> ioException (IOError Nothing InappropriateType "openFile" "is a directory" Nothing) Stream - | ReadWriteHandle <- ha_type -> mkDuplexHandle fd is_stream filepath binary - | otherwise -> mkFileHandle fd is_stream filepath ha_type binary + | ReadWriteHandle <- ha_type -> mkDuplexHandle fd is_socket filepath binary + | otherwise -> mkFileHandle fd is_socket filepath ha_type binary -- regular files need to be locked RegularFile -> do @@ -753,14 +848,14 @@ openFd fd mb_fd_type filepath mode binary truncate = do -- truncate the file if necessary when truncate (fileTruncate filepath) - mkFileHandle fd is_stream filepath ha_type binary + mkFileHandle fd is_socket filepath ha_type binary fdToHandle :: FD -> IO Handle fdToHandle fd = do mode <- fdGetMode fd let fd_str = "" - openFd fd Nothing fd_str mode True{-bin mode-} False{-no truncate-} + openFd fd Nothing False{-XXX!-} fd_str mode True{-bin mode-} False{-no truncate-} foreign import ccall unsafe "lockFile" lockFile :: CInt -> CInt -> CInt -> IO CInt @@ -1276,7 +1371,7 @@ hIsSeekable handle = -- ----------------------------------------------------------------------------- -- Changing echo status (Non-standard GHC extensions) --- | Set the echoing status of a handle connected to a terminal (GHC only). +-- | Set the echoing status of a handle connected to a terminal. hSetEcho :: Handle -> Bool -> IO () hSetEcho handle on = do @@ -1289,7 +1384,7 @@ hSetEcho handle on = do ClosedHandle -> ioe_closedHandle _ -> setEcho (haFD handle_) on --- | Get the echoing status of a handle connected to a terminal (GHC only). +-- | Get the echoing status of a handle connected to a terminal. hGetEcho :: Handle -> IO Bool hGetEcho handle = do @@ -1302,7 +1397,7 @@ hGetEcho handle = do ClosedHandle -> ioe_closedHandle _ -> getEcho (haFD handle_) --- | Is the handle connected to a terminal? (GHC only) +-- | Is the handle connected to a terminal? hIsTerminalDevice :: Handle -> IO Bool hIsTerminalDevice handle = do @@ -1442,6 +1537,23 @@ puts s = withCString s $ \cstr -> do write_rawBuffer 1 False cstr 0 (fromIntegra #endif -- ----------------------------------------------------------------------------- +-- utils + +throwErrnoIfMinus1RetryOnBlock :: String -> IO CInt -> IO CInt -> IO CInt +throwErrnoIfMinus1RetryOnBlock loc f on_block = + do + res <- f + if (res :: CInt) == -1 + then do + err <- getErrno + if err == eINTR + then throwErrnoIfMinus1RetryOnBlock loc f on_block + else if err == eWOULDBLOCK || err == eAGAIN + then do on_block + else throwErrno loc + else return res + +-- ----------------------------------------------------------------------------- -- wrappers to platform-specific constants: foreign import ccall unsafe "__hscore_supportsTextMode"