X-Git-Url: http://git.megacz.com/?a=blobdiff_plain;f=GHC%2FHandle.hs;h=37d78e6427dc54735d2d36c953ef79018d450db4;hb=cc4dd66d902a438d614f3031c89c7a5d5a555528;hp=16a9a2fc9f31e1ea5289d8c153eedbfe4a20feff;hpb=bdcf7efb348fab0c8d398f341d596aa024516a82;p=ghc-base.git diff --git a/GHC/Handle.hs b/GHC/Handle.hs index 16a9a2f..37d78e6 100644 --- a/GHC/Handle.hs +++ b/GHC/Handle.hs @@ -17,6 +17,7 @@ -- ----------------------------------------------------------------------------- +-- #hide module GHC.Handle ( withHandle, withHandle', withHandle_, wantWritableHandle, wantReadableHandle, wantSeekableHandle, @@ -27,14 +28,14 @@ module GHC.Handle ( readRawBuffer, readRawBufferPtr, writeRawBuffer, writeRawBufferPtr, -#ifndef mingw32_TARGET_OS +#ifndef mingw32_HOST_OS unlockFile, #endif ioe_closedHandle, ioe_EOF, ioe_notReadable, ioe_notWritable, stdin, stdout, stderr, - IOMode(..), openFile, openBinaryFile, openTempFile, openBinaryTempFile, openFd, fdToHandle, + IOMode(..), openFile, openBinaryFile, fdToHandle', fdToHandle, hFileSize, hSetFileSize, hIsEOF, isEOF, hLookAhead, hSetBuffering, hSetBinaryMode, hFlush, hDuplicate, hDuplicateTo, @@ -54,8 +55,6 @@ module GHC.Handle ( ) where -#include "ghcconfig.h" - import Control.Monad import Data.Bits import Data.Maybe @@ -63,7 +62,6 @@ import Foreign import Foreign.C import System.IO.Error import System.Posix.Internals -import System.FilePath import GHC.Real @@ -77,6 +75,9 @@ import GHC.Enum import GHC.Num ( Integer(..), Num(..) ) import GHC.Show import GHC.Real ( toInteger ) +#if defined(DEBUG_DUMP) +import GHC.Pack +#endif import GHC.Conc @@ -155,6 +156,7 @@ withHandle_ :: String -> Handle -> (Handle__ -> IO a) -> IO a withHandle_ fun h@(FileHandle _ m) act = withHandle_' fun h m act withHandle_ fun h@(DuplexHandle _ m _) act = withHandle_' fun h m act +withHandle_' :: String -> Handle -> MVar Handle__ -> (Handle__ -> IO a) -> IO a withHandle_' fun h m act = block $ do h_ <- takeMVar m @@ -374,15 +376,9 @@ newEmptyBuffer b state size allocateBuffer :: Int -> BufferState -> IO Buffer allocateBuffer sz@(I# size) state = IO $ \s -> -#ifdef mingw32_TARGET_OS - -- To implement asynchronous I/O under Win32, we have to pass - -- buffer references to external threads that handles the - -- filling/emptying of their contents. Hence, the buffer cannot - -- be moved around by the GC. + -- We sometimes need to pass the address of this buffer to + -- a "safe" foreign call, hence it must be immovable. case newPinnedByteArray# size s of { (# s, b #) -> -#else - case newByteArray# size s of { (# s, b #) -> -#endif (# s, newEmptyBuffer b state sz #) } writeCharIntoBuffer :: RawBuffer -> Int -> Char -> IO Int @@ -451,7 +447,7 @@ flushReadBuffer fd buf puts ("flushReadBuffer: new file offset = " ++ show off ++ "\n") # endif throwErrnoIfMinus1Retry "flushReadBuffer" - (c_lseek (fromIntegral fd) (fromIntegral off) sEEK_CUR) + (c_lseek fd (fromIntegral off) sEEK_CUR) return buf{ bufWPtr=0, bufRPtr=0 } flushWriteBuffer :: FD -> Bool -> Buffer -> IO Buffer @@ -464,7 +460,7 @@ flushWriteBuffer fd is_stream buf@Buffer{ bufBuf=b, bufRPtr=r, bufWPtr=w } = if bytes == 0 then return (buf{ bufRPtr=0, bufWPtr=0 }) else do - res <- writeRawBuffer "flushWriteBuffer" (fromIntegral fd) is_stream b + res <- writeRawBuffer "flushWriteBuffer" fd is_stream b (fromIntegral r) (fromIntegral bytes) let res' = fromIntegral res if res' < bytes @@ -513,7 +509,7 @@ fillReadBufferWithoutBlocking fd is_stream -- buffer better be empty: assert (r == 0 && w == 0) $ do #ifdef DEBUG_DUMP - puts ("fillReadBufferLoopNoBlock: bytes = " ++ show bytes ++ "\n") + puts ("fillReadBufferLoopNoBlock: bytes = " ++ show size ++ "\n") #endif res <- readRawBufferNoBlock "fillReadBuffer" fd is_stream b 0 (fromIntegral size) @@ -525,42 +521,105 @@ fillReadBufferWithoutBlocking fd is_stream -- 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 buf off len) - (threadWaitRead (fromIntegral fd)) +#ifndef mingw32_HOST_OS -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) +{- +NOTE [nonblock]: + +Unix has broken semantics when it comes to non-blocking I/O: you can +set the O_NONBLOCK flag on an FD, but it applies to the all other FDs +attached to the same underlying file, pipe or TTY; there's no way to +have private non-blocking behaviour for an FD. See bug #724. + +We fix this by only setting O_NONBLOCK on FDs that we create; FDs that +come from external sources or are exposed externally are left in +blocking mode. This solution has some problems though. We can't +completely simulate a non-blocking read without O_NONBLOCK: several +cases are wrong here. The cases that are wrong: + + * reading/writing to a blocking FD in non-threaded mode. + In threaded mode, we just make a safe call to read(). + In non-threaded mode we call select() before attempting to read, + but that leaves a small race window where the data can be read + from the file descriptor before we issue our blocking read(). + * readRawBufferNoBlock for a blocking FD +-} + +readRawBuffer :: String -> FD -> Bool -> RawBuffer -> Int -> CInt -> IO CInt +readRawBuffer loc fd is_nonblock buf off len + | is_nonblock = unsafe_read + | threaded = safe_read + | otherwise = do r <- throwErrnoIfMinus1 loc + (fdReady (fromIntegral fd) 0 0 False) + if r /= 0 + then unsafe_read + else do threadWaitRead (fromIntegral fd); unsafe_read + where + do_read call = throwErrnoIfMinus1RetryMayBlock loc call + (threadWaitRead (fromIntegral fd)) + unsafe_read = do_read (read_rawBuffer fd buf off len) + safe_read = do_read (safe_read_rawBuffer fd buf off len) readRawBufferPtr :: String -> FD -> Bool -> Ptr CChar -> Int -> CInt -> IO CInt -readRawBufferPtr loc fd is_stream buf off len = - throwErrnoIfMinus1RetryMayBlock loc - (read_off fd buf off len) - (threadWaitRead (fromIntegral fd)) +readRawBufferPtr loc fd is_nonblock buf off len + | is_nonblock = unsafe_read + | threaded = safe_read + | otherwise = do r <- throwErrnoIfMinus1 loc + (fdReady (fromIntegral fd) 0 0 False) + if r /= 0 + then unsafe_read + else do threadWaitRead (fromIntegral fd); unsafe_read + where + do_read call = throwErrnoIfMinus1RetryMayBlock loc call + (threadWaitRead (fromIntegral fd)) + unsafe_read = do_read (read_off fd buf off len) + safe_read = do_read (safe_read_off fd buf off len) + +readRawBufferNoBlock :: String -> FD -> Bool -> RawBuffer -> Int -> CInt -> IO CInt +readRawBufferNoBlock loc fd is_nonblock buf off len + | is_nonblock = unsafe_read + | otherwise = do r <- fdReady (fromIntegral fd) 0 0 False + if r /= 0 then safe_read + else return 0 + -- XXX see note [nonblock] + where + do_read call = throwErrnoIfMinus1RetryOnBlock loc call (return 0) + unsafe_read = do_read (read_rawBuffer fd buf off len) + safe_read = do_read (safe_read_rawBuffer fd buf off len) writeRawBuffer :: String -> FD -> Bool -> RawBuffer -> Int -> CInt -> IO CInt -writeRawBuffer loc fd is_stream buf off len = - throwErrnoIfMinus1RetryMayBlock loc - (write_rawBuffer (fromIntegral fd) buf off len) - (threadWaitWrite (fromIntegral fd)) +writeRawBuffer loc fd is_nonblock buf off len + | is_nonblock = unsafe_write + | threaded = safe_write + | otherwise = do r <- fdReady (fromIntegral fd) 1 0 False + if r /= 0 + then safe_write + else do threadWaitWrite (fromIntegral fd); unsafe_write + where + do_write call = throwErrnoIfMinus1RetryMayBlock loc call + (threadWaitWrite (fromIntegral fd)) + unsafe_write = do_write (write_rawBuffer fd buf off len) + safe_write = do_write (safe_write_rawBuffer (fromIntegral fd) buf off len) writeRawBufferPtr :: String -> FD -> Bool -> Ptr CChar -> Int -> CInt -> IO CInt -writeRawBufferPtr loc fd is_stream buf off len = - throwErrnoIfMinus1RetryMayBlock loc - (write_off (fromIntegral fd) buf off len) - (threadWaitWrite (fromIntegral fd)) +writeRawBufferPtr loc fd is_nonblock buf off len + | is_nonblock = unsafe_write + | threaded = safe_write + | otherwise = do r <- fdReady (fromIntegral fd) 1 0 False + if r /= 0 + then safe_write + else do threadWaitWrite (fromIntegral fd); unsafe_write + where + do_write call = throwErrnoIfMinus1RetryMayBlock loc call + (threadWaitWrite (fromIntegral fd)) + unsafe_write = do_write (write_off fd buf off len) + safe_write = do_write (safe_write_off (fromIntegral fd) buf off len) foreign import ccall unsafe "__hscore_PrelHandle_read" - read_rawBuffer :: FD -> RawBuffer -> Int -> CInt -> IO CInt + read_rawBuffer :: CInt -> RawBuffer -> Int -> CInt -> IO CInt foreign import ccall unsafe "__hscore_PrelHandle_read" - read_off :: FD -> Ptr CChar -> Int -> CInt -> IO CInt + read_off :: CInt -> Ptr CChar -> Int -> CInt -> IO CInt foreign import ccall unsafe "__hscore_PrelHandle_write" write_rawBuffer :: CInt -> RawBuffer -> Int -> CInt -> IO CInt @@ -568,7 +627,10 @@ foreign import ccall unsafe "__hscore_PrelHandle_write" foreign import ccall unsafe "__hscore_PrelHandle_write" write_off :: CInt -> Ptr CChar -> Int -> CInt -> IO CInt -#else /* mingw32_TARGET_OS.... */ +foreign import ccall safe "fdReady" + fdReady :: CInt -> CInt -> CInt -> Bool -> IO CInt + +#else /* mingw32_HOST_OS.... */ readRawBuffer :: String -> FD -> Bool -> RawBuffer -> Int -> CInt -> IO CInt readRawBuffer loc fd is_stream buf off len @@ -592,12 +654,12 @@ writeRawBufferPtr 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 +readRawBufferNoBlock = readRawBuffer -- 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) + (l, rc) <- asyncReadBA (fromIntegral fd) (if is_stream then 1 else 0) (fromIntegral len) off buf if l == (-1) then @@ -605,7 +667,7 @@ asyncReadRawBuffer loc fd is_stream buf off len = do else return (fromIntegral l) asyncReadRawBufferPtr loc fd is_stream buf off len = do - (l, rc) <- asyncRead fd (if is_stream then 1 else 0) + (l, rc) <- asyncRead (fromIntegral fd) (if is_stream then 1 else 0) (fromIntegral len) (buf `plusPtr` off) if l == (-1) then @@ -613,7 +675,7 @@ asyncReadRawBufferPtr loc fd is_stream buf off len = do else return (fromIntegral l) asyncWriteRawBuffer loc fd is_stream buf off len = do - (l, rc) <- asyncWriteBA fd (if is_stream then 1 else 0) + (l, rc) <- asyncWriteBA (fromIntegral fd) (if is_stream then 1 else 0) (fromIntegral len) off buf if l == (-1) then @@ -621,7 +683,7 @@ asyncWriteRawBuffer loc fd is_stream buf off len = do else return (fromIntegral l) asyncWriteRawBufferPtr loc fd is_stream buf off len = do - (l, rc) <- asyncWrite fd (if is_stream then 1 else 0) + (l, rc) <- asyncWrite (fromIntegral fd) (if is_stream then 1 else 0) (fromIntegral len) (buf `plusPtr` off) if l == (-1) then @@ -632,62 +694,63 @@ asyncWriteRawBufferPtr loc fd is_stream buf off len = do blockingReadRawBuffer loc fd True buf off len = throwErrnoIfMinus1Retry loc $ - recv_rawBuffer fd buf off len + safe_recv_rawBuffer fd buf off len blockingReadRawBuffer loc fd False buf off len = throwErrnoIfMinus1Retry loc $ - read_rawBuffer fd buf off len + safe_read_rawBuffer fd buf off len blockingReadRawBufferPtr loc fd True buf off len = throwErrnoIfMinus1Retry loc $ - recv_off fd buf off len + safe_recv_off fd buf off len blockingReadRawBufferPtr loc fd False buf off len = throwErrnoIfMinus1Retry loc $ - read_off fd buf off len + safe_read_off fd buf off len blockingWriteRawBuffer loc fd True buf off len = throwErrnoIfMinus1Retry loc $ - send_rawBuffer (fromIntegral fd) buf off len + safe_send_rawBuffer fd buf off len blockingWriteRawBuffer loc fd False buf off len = throwErrnoIfMinus1Retry loc $ - write_rawBuffer (fromIntegral fd) buf off len + safe_write_rawBuffer fd buf off len blockingWriteRawBufferPtr loc fd True buf off len = throwErrnoIfMinus1Retry loc $ - send_off (fromIntegral fd) buf off len + safe_send_off fd buf off len blockingWriteRawBufferPtr loc fd False buf off len = throwErrnoIfMinus1Retry loc $ - write_off (fromIntegral fd) buf off len + safe_write_off 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 + safe_recv_rawBuffer :: CInt -> RawBuffer -> Int -> CInt -> IO CInt foreign import ccall safe "__hscore_PrelHandle_recv" - recv_off :: FD -> Ptr CChar -> Int -> CInt -> IO CInt + safe_recv_off :: CInt -> Ptr CChar -> Int -> CInt -> IO CInt foreign import ccall safe "__hscore_PrelHandle_send" - send_rawBuffer :: CInt -> RawBuffer -> Int -> CInt -> IO CInt + safe_send_rawBuffer :: CInt -> RawBuffer -> Int -> CInt -> IO CInt foreign import ccall safe "__hscore_PrelHandle_send" - send_off :: CInt -> Ptr CChar -> Int -> CInt -> IO CInt + safe_send_off :: CInt -> Ptr CChar -> Int -> CInt -> IO CInt -foreign import ccall "rtsSupportsBoundThreads" threaded :: Bool #endif +foreign import ccall "rtsSupportsBoundThreads" threaded :: Bool + +foreign import ccall safe "__hscore_PrelHandle_read" + safe_read_rawBuffer :: FD -> RawBuffer -> Int -> CInt -> IO CInt + +foreign import ccall safe "__hscore_PrelHandle_read" + safe_read_off :: FD -> Ptr CChar -> Int -> CInt -> IO CInt + +foreign import ccall safe "__hscore_PrelHandle_write" + safe_write_rawBuffer :: CInt -> RawBuffer -> Int -> CInt -> IO CInt + +foreign import ccall safe "__hscore_PrelHandle_write" + safe_write_off :: CInt -> Ptr CChar -> Int -> CInt -> IO CInt + -- --------------------------------------------------------------------------- -- Standard Handles @@ -704,7 +767,9 @@ fd_stderr = 2 :: FD stdin :: Handle stdin = unsafePerformIO $ do -- ToDo: acquire lock - setNonBlockingFD fd_stdin + -- We don't set non-blocking mode on standard handles, because it may + -- confuse other applications attached to the same TTY/pipe + -- see Note [nonblock] (buf, bmode) <- getBuffer fd_stdin ReadBuffer mkStdHandle fd_stdin "" ReadHandle buf bmode @@ -712,9 +777,9 @@ stdin = unsafePerformIO $ do stdout :: Handle stdout = unsafePerformIO $ do -- ToDo: acquire lock - -- We don't set non-blocking mode on stdout or sterr, because - -- some shells don't recover properly. - -- setNonBlockingFD fd_stdout + -- We don't set non-blocking mode on standard handles, because it may + -- confuse other applications attached to the same TTY/pipe + -- see Note [nonblock] (buf, bmode) <- getBuffer fd_stdout WriteBuffer mkStdHandle fd_stdout "" WriteHandle buf bmode @@ -722,9 +787,9 @@ stdout = unsafePerformIO $ do stderr :: Handle stderr = unsafePerformIO $ do -- ToDo: acquire lock - -- We don't set non-blocking mode on stdout or sterr, because - -- some shells don't recover properly. - -- setNonBlockingFD fd_stderr + -- We don't set non-blocking mode on standard handles, because it may + -- confuse other applications attached to the same TTY/pipe + -- see Note [nonblock] buf <- mkUnBuffer mkStdHandle fd_stderr "" WriteHandle buf NoBuffering @@ -787,7 +852,7 @@ openFile' filepath mode binary = let oflags1 = case mode of ReadMode -> read_flags -#ifdef mingw32_TARGET_OS +#ifdef mingw32_HOST_OS WriteMode -> write_flags .|. o_TRUNC #else WriteMode -> write_flags @@ -807,72 +872,31 @@ openFile' filepath mode binary = -- directories. However, the man pages I've read say that open() -- always returns EISDIR if the file is a directory and was opened -- for writing, so I think we're ok with a single open() here... - fd <- fromIntegral `liftM` - throwErrnoIfMinus1Retry "openFile" + fd <- throwErrnoIfMinus1Retry "openFile" (c_open f (fromIntegral oflags) 0o666) - h <- openFd fd Nothing False filepath mode binary - `catchException` \e -> do c_close (fromIntegral fd); throw e - -- NB. don't forget to close the FD if openFd fails, otherwise + fd_type <- fdType fd + + h <- fdToHandle' fd (Just fd_type) False filepath mode binary + `catchException` \e -> do c_close fd; throw e + -- NB. don't forget to close the FD if fdToHandle' fails, otherwise -- this FD leaks. - -- ASSERT: if we just created the file, then openFd won't fail + -- ASSERT: if we just created the file, then fdToHandle' won't fail -- (so we don't need to worry about removing the newly created file -- in the event of an error). -#ifndef mingw32_TARGET_OS - if mode == WriteMode + +#ifndef mingw32_HOST_OS + -- we want to truncate() if this is an open in WriteMode, but only + -- if the target is a RegularFile. ftruncate() fails on special files + -- like /dev/null. + if mode == WriteMode && fd_type == RegularFile then throwErrnoIf (/=0) "openFile" - (c_ftruncate (fromIntegral fd) 0) + (c_ftruncate fd 0) else return 0 #endif return h --- | The function creates a temporary file in ReadWrite mode. --- The created file isn\'t deleted automatically, so you need to delete it manually. -openTempFile :: FilePath -- ^ Directory in which to create the file - -> String -- ^ File name template. If the template is \"foo.ext\" then - -- the create file will be \"fooXXX.ext\" where XXX is some - -- random number. - -> IO (FilePath, Handle) -openTempFile tmp_dir template = openTempFile' "openTempFile" tmp_dir template dEFAULT_OPEN_IN_BINARY_MODE - --- | Like 'openTempFile', but opens the file in binary mode. See 'openBinaryFile' for more comments. -openBinaryTempFile :: FilePath -> String -> IO (FilePath, Handle) -openBinaryTempFile tmp_dir template = openTempFile' "openBinaryTempFile" tmp_dir template True - -openTempFile' :: String -> FilePath -> String -> Bool -> IO (FilePath, Handle) -openTempFile' loc tmp_dir template binary = do - pid <- c_getpid - findTempName pid - where - (prefix,suffix) = break (=='.') template - - oflags1 = rw_flags .|. o_EXCL - - binary_flags - | binary = o_BINARY - | otherwise = 0 - - oflags = oflags1 .|. binary_flags - - findTempName x = do - fd <- withCString filepath $ \ f -> - c_open f oflags 0o666 - if fd < 0 - then do - errno <- getErrno - if errno == eEXIST - then findTempName (x+1) - else ioError (errnoToIOError loc errno Nothing (Just tmp_dir)) - else do - h <- openFd (fromIntegral fd) Nothing False filepath ReadWriteMode True - `catchException` \e -> do c_close (fromIntegral fd); throw e - return (filepath, h) - where - filename = prefix ++ show x ++ suffix - filepath = tmp_dir `joinFileName` filename - - std_flags = o_NONBLOCK .|. o_NOCTTY output_flags = std_flags .|. o_CREAT read_flags = std_flags .|. o_RDONLY @@ -881,13 +905,21 @@ rw_flags = output_flags .|. o_RDWR append_flags = write_flags .|. o_APPEND -- --------------------------------------------------------------------------- --- openFd +-- fdToHandle' -openFd :: FD -> Maybe FDType -> Bool -> FilePath -> IOMode -> Bool -> IO Handle -openFd fd mb_fd_type is_socket filepath mode binary = do +fdToHandle' :: FD -> Maybe FDType -> Bool -> FilePath -> IOMode -> Bool -> IO Handle +fdToHandle' fd mb_fd_type is_socket filepath mode binary = do -- turn on non-blocking mode setNonBlockingFD fd +#ifdef mingw32_HOST_OS + -- On Windows, the is_stream flag indicates that the Handle is a socket + let is_stream = is_socket +#else + -- On Unix, the is_stream flag indicates that the FD is non-blocking + let is_stream = True +#endif + let (ha_type, write) = case mode of ReadMode -> ( ReadHandle, False ) @@ -907,29 +939,35 @@ openFd fd mb_fd_type is_socket filepath mode binary = do ioException (IOError Nothing InappropriateType "openFile" "is a directory" Nothing) - Stream - | 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 -#ifndef mingw32_TARGET_OS - r <- lockFile (fromIntegral fd) (fromBool write) 1{-exclusive-} +#ifndef mingw32_HOST_OS + r <- lockFile fd (fromBool write) 1{-exclusive-} when (r == -1) $ ioException (IOError Nothing ResourceBusy "openFile" "file is locked" Nothing) #endif - mkFileHandle fd is_socket filepath ha_type binary + mkFileHandle fd is_stream filepath ha_type binary + + Stream + -- only *Streams* can be DuplexHandles. Other read/write + -- Handles must share a buffer. + | ReadWriteHandle <- ha_type -> + mkDuplexHandle fd is_stream filepath binary + | otherwise -> + mkFileHandle fd is_stream filepath ha_type binary + RawDevice -> + mkFileHandle fd is_stream filepath ha_type binary fdToHandle :: FD -> IO Handle fdToHandle fd = do mode <- fdGetMode fd let fd_str = "" - openFd fd Nothing False{-XXX!-} fd_str mode True{-bin mode-} + fdToHandle' fd Nothing False{-XXX!-} fd_str mode True{-bin mode-} -#ifndef mingw32_TARGET_OS +#ifndef mingw32_HOST_OS foreign import ccall unsafe "lockFile" lockFile :: CInt -> CInt -> CInt -> IO CInt @@ -945,7 +983,7 @@ mkStdHandle fd filepath ha_type buf bmode = do (Handle__ { haFD = fd, haType = ha_type, haIsBin = dEFAULT_OPEN_IN_BINARY_MODE, - haIsStream = False, + haIsStream = False, -- means FD is blocking on Unix haBufferMode = bmode, haBuffer = buf, haBuffers = spares, @@ -955,6 +993,17 @@ mkStdHandle fd filepath ha_type buf bmode = do mkFileHandle :: FD -> Bool -> FilePath -> HandleType -> Bool -> IO Handle mkFileHandle fd is_stream filepath ha_type binary = do (buf, bmode) <- getBuffer fd (initBufferState ha_type) + +#ifdef mingw32_HOST_OS + -- On Windows, if this is a read/write handle and we are in text mode, + -- turn off buffering. We don't correctly handle the case of switching + -- from read mode to write mode on a buffered text-mode handle, see bug + -- \#679. + bmode <- case ha_type of + ReadWriteHandle | not binary -> return NoBuffering + _other -> return bmode +#endif + spares <- newIORef BufferListNil newFileHandle filepath (handleFinalizer filepath) (Handle__ { haFD = fd, @@ -1036,26 +1085,26 @@ hClose_help handle_ = hClose_handle_ handle_ = do let fd = haFD handle_ - c_fd = fromIntegral fd -- close the file descriptor, but not when this is the read -- side of a duplex handle. case haOtherSide handle_ of - Nothing -> + Nothing -> throwErrnoIfMinus1Retry_ "hClose" -#ifdef mingw32_TARGET_OS - (closeFd (haIsStream handle_) c_fd) +#ifdef mingw32_HOST_OS + (closeFd (haIsStream handle_) fd) #else - (c_close c_fd) + (c_close fd) #endif Just _ -> return () -- free the spare buffers writeIORef (haBuffers handle_) BufferListNil + writeIORef (haBuffer handle_) noBuffer -#ifndef mingw32_TARGET_OS +#ifndef mingw32_HOST_OS -- unlock it - unlockFile c_fd + unlockFile fd #endif -- we must set the fd to -1, because the finalizer is going @@ -1064,6 +1113,9 @@ hClose_handle_ handle_ = do haType = ClosedHandle }) +{-# NOINLINE noBuffer #-} +noBuffer = unsafePerformIO $ allocateBuffer 1 ReadBuffer + ----------------------------------------------------------------------------- -- Detecting and changing the size of a file @@ -1094,7 +1146,7 @@ hSetFileSize handle size = SemiClosedHandle -> ioe_closedHandle _ -> do flushWriteBufferOnly handle_ throwErrnoIf (/=0) "hSetFileSize" - (c_ftruncate (fromIntegral (haFD handle_)) (fromIntegral size)) + (c_ftruncate (haFD handle_) (fromIntegral size)) return () -- --------------------------------------------------------------------------- @@ -1138,7 +1190,7 @@ hLookAhead handle = do -- fill up the read buffer if necessary new_buf <- if bufferEmpty buf - then fillReadBuffer fd is_line (haIsStream handle_) buf + then fillReadBuffer fd True (haIsStream handle_) buf else return buf writeIORef ref new_buf @@ -1205,10 +1257,12 @@ hSetBuffering handle mode = is_tty <- fdIsTTY (haFD handle_) when (is_tty && isReadableHandleType (haType handle_)) $ case mode of -#ifndef mingw32_TARGET_OS +#ifndef mingw32_HOST_OS -- 'raw' mode under win32 is a bit too specialised (and troublesome -- for most common uses), so simply disable its use here. NoBuffering -> setCooked (haFD handle_) False +#else + NoBuffering -> return () #endif _ -> setCooked (haFD handle_) True @@ -1331,7 +1385,7 @@ hSeek handle mode offset = let do_seek = throwErrnoIfMinus1Retry_ "hSeek" - (c_lseek (fromIntegral (haFD handle_)) (fromIntegral offset) whence) + (c_lseek (haFD handle_) (fromIntegral offset) whence) whence :: CInt whence = case mode of @@ -1358,13 +1412,13 @@ hTell :: Handle -> IO Integer hTell handle = wantSeekableHandle "hGetPosn" handle $ \ handle_ -> do -#if defined(mingw32_TARGET_OS) +#if defined(mingw32_HOST_OS) -- urgh, on Windows we have to worry about \n -> \r\n translation, -- so we can't easily calculate the file position using the -- current buffer size. Just flush instead. flushBuffer handle_ #endif - let fd = fromIntegral (haFD handle_) + let fd = haFD handle_ posn <- fromIntegral `liftM` throwErrnoIfMinus1Retry "hGetPosn" (c_lseek fd 0 sEEK_CUR) @@ -1452,9 +1506,8 @@ hIsSeekable handle = SemiClosedHandle -> ioe_closedHandle AppendHandle -> return False _ -> do t <- fdType (haFD handle_) - return (t == RegularFile - && (haIsBin handle_ - || tEXT_MODE_SEEK_ALLOWED)) + return ((t == RegularFile || t == RawDevice) + && (haIsBin handle_ || tEXT_MODE_SEEK_ALLOWED)) -- ----------------------------------------------------------------------------- -- Changing echo status (Non-standard GHC extensions) @@ -1504,7 +1557,7 @@ hSetBinaryMode :: Handle -> Bool -> IO () hSetBinaryMode handle bin = withAllHandles__ "hSetBinaryMode" handle $ \ handle_ -> do throwErrnoIfMinus1_ "hSetBinaryMode" - (setmode (fromIntegral (haFD handle_)) bin) + (setmode (haFD handle_) bin) return handle_{haIsBin=bin} foreign import ccall unsafe "__hscore_setmode" @@ -1513,31 +1566,48 @@ foreign import ccall unsafe "__hscore_setmode" -- ----------------------------------------------------------------------------- -- Duplicating a Handle --- |Returns a duplicate of the original handle, with its own buffer --- and file pointer. The original handle's buffer is flushed, including --- discarding any input data, before the handle is duplicated. +-- | Returns a duplicate of the original handle, with its own buffer. +-- The two Handles will share a file pointer, however. The original +-- handle's buffer is flushed, including discarding any input data, +-- before the handle is duplicated. hDuplicate :: Handle -> IO Handle hDuplicate h@(FileHandle path m) = do - new_h_ <- withHandle' "hDuplicate" h m (dupHandle_ Nothing) + new_h_ <- withHandle' "hDuplicate" h m (dupHandle h Nothing) newFileHandle path (handleFinalizer path) new_h_ hDuplicate h@(DuplexHandle path r w) = do - new_w_ <- withHandle' "hDuplicate" h w (dupHandle_ Nothing) + new_w_ <- withHandle' "hDuplicate" h w (dupHandle h Nothing) new_w <- newMVar new_w_ - new_r_ <- withHandle' "hDuplicate" h r (dupHandle_ (Just new_w)) + new_r_ <- withHandle' "hDuplicate" h r (dupHandle h (Just new_w)) new_r <- newMVar new_r_ addMVarFinalizer new_w (handleFinalizer path new_w) return (DuplexHandle path new_r new_w) -dupHandle_ other_side h_ = do +dupHandle :: Handle -> Maybe (MVar Handle__) -> Handle__ + -> IO (Handle__, Handle__) +dupHandle h other_side h_ = do -- flush the buffer first, so we don't have to copy its contents flushBuffer h_ - new_fd <- c_dup (fromIntegral (haFD h_)) + new_fd <- case other_side of + Nothing -> throwErrnoIfMinus1 "dupHandle" $ c_dup (haFD h_) + Just r -> withHandle_' "dupHandle" h r (return . haFD) + dupHandle_ other_side h_ new_fd + +dupHandleTo other_side hto_ h_ = do + flushBuffer h_ + -- Windows' dup2 does not return the new descriptor, unlike Unix + throwErrnoIfMinus1 "dupHandleTo" $ + c_dup2 (haFD h_) (haFD hto_) + dupHandle_ other_side h_ (haFD hto_) + +dupHandle_ :: Maybe (MVar Handle__) -> Handle__ -> FD + -> IO (Handle__, Handle__) +dupHandle_ other_side h_ new_fd = do buffer <- allocateBuffer dEFAULT_BUFFER_SIZE (initBufferState (haType h_)) ioref <- newIORef buffer ioref_buffers <- newIORef BufferListNil - let new_handle_ = h_{ haFD = fromIntegral new_fd, + let new_handle_ = h_{ haFD = new_fd, haBuffer = ioref, haBuffers = ioref_buffers, haOtherSide = other_side } @@ -1560,14 +1630,14 @@ hDuplicateTo :: Handle -> Handle -> IO () hDuplicateTo h1@(FileHandle _ m1) h2@(FileHandle _ m2) = do withHandle__' "hDuplicateTo" h2 m2 $ \h2_ -> do _ <- hClose_help h2_ - withHandle' "hDuplicateTo" h1 m1 (dupHandle_ Nothing) + withHandle' "hDuplicateTo" h1 m1 (dupHandleTo Nothing h2_) hDuplicateTo h1@(DuplexHandle _ r1 w1) h2@(DuplexHandle _ r2 w2) = do withHandle__' "hDuplicateTo" h2 w2 $ \w2_ -> do _ <- hClose_help w2_ - withHandle' "hDuplicateTo" h1 r1 (dupHandle_ Nothing) + withHandle' "hDuplicateTo" h1 r1 (dupHandleTo Nothing w2_) withHandle__' "hDuplicateTo" h2 r2 $ \r2_ -> do _ <- hClose_help r2_ - withHandle' "hDuplicateTo" h1 r1 (dupHandle_ (Just w1)) + withHandle' "hDuplicateTo" h1 r1 (dupHandleTo (Just w1) r2_) hDuplicateTo h1 _ = ioException (IOError (Just h1) IllegalOperation "hDuplicateTo" "handles are incompatible" Nothing) @@ -1618,10 +1688,10 @@ showHandle' filepath is_duplex h = -- --------------------------------------------------------------------------- -- debugging -#ifdef DEBUG_DUMP +#if defined(DEBUG_DUMP) puts :: String -> IO () -puts s = withCString s $ \cstr -> do write_rawBuffer 1 False cstr 0 (fromIntegral (length s)) - return () +puts s = do write_rawBuffer 1 (unsafeCoerce# (packCString# s)) 0 (fromIntegral (length s)) + return () #endif -- -----------------------------------------------------------------------------