X-Git-Url: http://git.megacz.com/?a=blobdiff_plain;f=GHC%2FHandle.hs;h=6bbc4397b6eec9e33f8d1841716f4933de1767d0;hb=5cb296ddc74173237af7d6f813211a9b0ecc7d16;hp=64fab41919c3eb62cd4623f661ad2c5ad1088d37;hpb=729ce757c6ffee2366734df16ef34eac2fcd868f;p=ghc-base.git diff --git a/GHC/Handle.hs b/GHC/Handle.hs index 64fab41..6bbc439 100644 --- a/GHC/Handle.hs +++ b/GHC/Handle.hs @@ -26,11 +26,10 @@ module GHC.Handle ( fillReadBuffer, fillReadBufferWithoutBlocking, readRawBuffer, readRawBufferPtr, writeRawBuffer, writeRawBufferPtr, + +#ifndef mingw32_TARGET_OS unlockFile, - - {- ought to be unnecessary, but just in case.. -} - write_off, write_rawBuffer, - read_off, read_rawBuffer, +#endif ioe_closedHandle, ioe_EOF, ioe_notReadable, ioe_notWritable, @@ -55,7 +54,7 @@ module GHC.Handle ( ) where -#include "config.h" +#include "ghcconfig.h" import Control.Monad import Data.Bits @@ -303,6 +302,10 @@ ioe_notSeekable_notBin = ioException "seek operations on text-mode handles are not allowed on this platform" Nothing) +ioe_finalizedHandle fp = throw (IOException + (IOError Nothing IllegalOperation "" + "handle is finalized" (Just fp))) + ioe_bufsiz :: Int -> IO a ioe_bufsiz n = ioException (IOError Nothing InvalidArgument "hSetBuffering" @@ -318,13 +321,21 @@ ioe_bufsiz n = ioException -- The finalizer is then placed on the write side, and the handle only gets -- finalized once, when both sides are no longer required. -stdHandleFinalizer :: MVar Handle__ -> IO () -stdHandleFinalizer m = do +-- NOTE about finalized handles: It's possible that a handle can be +-- finalized and then we try to use it later, for example if the +-- handle is referenced from another finalizer, or from a thread that +-- has become unreferenced and then resurrected (arguably in the +-- latter case we shouldn't finalize the Handle...). Anyway, +-- we try to emit a helpful message which is better than nothing. + +stdHandleFinalizer :: FilePath -> MVar Handle__ -> IO () +stdHandleFinalizer fp m = do h_ <- takeMVar m flushWriteBufferOnly h_ + putMVar m (ioe_finalizedHandle fp) -handleFinalizer :: MVar Handle__ -> IO () -handleFinalizer m = do +handleFinalizer :: FilePath -> MVar Handle__ -> IO () +handleFinalizer fp m = do handle_ <- takeMVar m case haType handle_ of ClosedHandle -> return () @@ -333,6 +344,7 @@ handleFinalizer m = do -- descriptor anyway... hClose_handle_ handle_ return () + putMVar m (ioe_finalizedHandle fp) -- --------------------------------------------------------------------------- -- Grimy buffer operations @@ -516,90 +528,163 @@ fillReadBufferWithoutBlocking fd is_stream 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) - (threadWaitRead fd) + (read_rawBuffer fd buf off len) + (threadWaitRead (fromIntegral fd)) readRawBufferNoBlock :: String -> FD -> Bool -> RawBuffer -> Int -> CInt -> IO CInt readRawBufferNoBlock loc fd is_stream buf off len = throwErrnoIfMinus1RetryOnBlock loc - (read_rawBuffer fd is_stream buf off len) + (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) - (threadWaitRead fd) + (read_off fd buf off len) + (threadWaitRead (fromIntegral 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) - (threadWaitWrite fd) + (write_rawBuffer (fromIntegral fd) buf off len) + (threadWaitWrite (fromIntegral 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) - (threadWaitWrite fd) + (write_off (fromIntegral fd) buf off len) + (threadWaitWrite (fromIntegral 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 -- --------------------------------------------------------------------------- @@ -671,7 +756,9 @@ addFilePathToIOError fun fp (IOError h iot _ str _) -- * 'isDoesNotExistError' if the file does not exist; or -- -- * 'isPermissionError' if the user does not have permission to open the file. - +-- +-- Note: if you will be working with files containing binary data, you'll want to +-- be using 'openBinaryFile'. openFile :: FilePath -> IOMode -> IO Handle openFile fp im = catch @@ -703,9 +790,6 @@ openFile' filepath mode binary = ReadWriteMode -> rw_flags AppendMode -> append_flags - truncate | WriteMode <- mode = True - | otherwise = False - binary_flags | binary = o_BINARY | otherwise = 0 @@ -722,7 +806,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 + `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). @@ -731,15 +818,15 @@ openFile' filepath mode binary = std_flags = o_NONBLOCK .|. o_NOCTTY output_flags = std_flags .|. o_CREAT read_flags = std_flags .|. o_RDONLY -write_flags = output_flags .|. o_WRONLY +write_flags = output_flags .|. o_WRONLY .|. o_TRUNC rw_flags = output_flags .|. o_RDWR 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 -> IO Handle +openFd fd mb_fd_type is_socket filepath mode binary = do -- turn on non-blocking mode setNonBlockingFD fd @@ -756,46 +843,47 @@ 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 +#ifndef mingw32_TARGET_OS r <- lockFile (fromIntegral fd) (fromBool write) 1{-exclusive-} when (r == -1) $ ioException (IOError Nothing ResourceBusy "openFile" "file is locked" Nothing) - - -- truncate the file if necessary - when truncate (fileTruncate filepath) - - mkFileHandle fd is_stream filepath ha_type binary +#endif + 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-} + +#ifndef mingw32_TARGET_OS foreign import ccall unsafe "lockFile" lockFile :: CInt -> CInt -> CInt -> IO CInt foreign import ccall unsafe "unlockFile" unlockFile :: CInt -> IO CInt +#endif mkStdHandle :: FD -> FilePath -> HandleType -> IORef Buffer -> BufferMode -> IO Handle mkStdHandle fd filepath ha_type buf bmode = do spares <- newIORef BufferListNil - newFileHandle filepath stdHandleFinalizer + newFileHandle filepath (stdHandleFinalizer filepath) (Handle__ { haFD = fd, haType = ha_type, haIsBin = dEFAULT_OPEN_IN_BINARY_MODE, @@ -810,7 +898,7 @@ mkFileHandle :: FD -> Bool -> FilePath -> HandleType -> Bool -> IO Handle mkFileHandle fd is_stream filepath ha_type binary = do (buf, bmode) <- getBuffer fd (initBufferState ha_type) spares <- newIORef BufferListNil - newFileHandle filepath handleFinalizer + newFileHandle filepath (handleFinalizer filepath) (Handle__ { haFD = fd, haType = ha_type, haIsBin = binary, @@ -851,7 +939,7 @@ mkDuplexHandle fd is_stream filepath binary = do } read_side <- newMVar r_handle_ - addMVarFinalizer write_side (handleFinalizer write_side) + addMVarFinalizer write_side (handleFinalizer filepath write_side) return (DuplexHandle filepath read_side write_side) @@ -909,9 +997,11 @@ hClose_handle_ handle_ = do -- free the spare buffers writeIORef (haBuffers handle_) BufferListNil +#ifndef mingw32_TARGET_OS -- unlock it unlockFile c_fd - +#endif + -- we must set the fd to -1, because the finalizer is going -- to run eventually and try to close/unlock it. return (handle_{ haFD = -1, @@ -1299,7 +1389,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 @@ -1312,7 +1402,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 @@ -1325,7 +1415,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 @@ -1338,7 +1428,7 @@ hIsTerminalDevice handle = do -- hSetBinaryMode -- | Select binary mode ('True') or text mode ('False') on a open handle. --- (GHC only; see also 'openBinaryFile'.) +-- (See also 'openBinaryFile'.) hSetBinaryMode :: Handle -> Bool -> IO () hSetBinaryMode handle bin = @@ -1360,13 +1450,13 @@ foreign import ccall unsafe "__hscore_setmode" hDuplicate :: Handle -> IO Handle hDuplicate h@(FileHandle path m) = do new_h_ <- withHandle' "hDuplicate" h m (dupHandle_ Nothing) - new_m <- newMVar new_h_ - return (FileHandle path new_m) + newFileHandle path (handleFinalizer path) new_h_ hDuplicate h@(DuplexHandle path r w) = do new_w_ <- withHandle' "hDuplicate" h w (dupHandle_ Nothing) new_w <- newMVar new_w_ new_r_ <- withHandle' "hDuplicate" h r (dupHandle_ (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