X-Git-Url: http://git.megacz.com/?a=blobdiff_plain;f=GHC%2FIO%2FFD.hs;h=173088561f68e5841f57c7eae39e1f69708ed35b;hb=57b9366e5fd3db86719d12b45320e6145b040fa6;hp=32f4e9bb1957c7d12c52979c98367c67218d1a6f;hpb=d181127657f46b1d0acd3dc94ccce4c0e6241095;p=ghc-base.git diff --git a/GHC/IO/FD.hs b/GHC/IO/FD.hs index 32f4e9b..1730885 100644 --- a/GHC/IO/FD.hs +++ b/GHC/IO/FD.hs @@ -1,5 +1,13 @@ -{-# OPTIONS_GHC -XNoImplicitPrelude -XBangPatterns #-} +{-# LANGUAGE CPP + , NoImplicitPrelude + , BangPatterns + , ForeignFunctionInterface + , DeriveDataTypeable + #-} +{-# OPTIONS_GHC -fno-warn-identities #-} +-- Whether there are identities depends on the platform {-# OPTIONS_HADDOCK hide #-} + ----------------------------------------------------------------------------- -- | -- Module : GHC.IO.FD @@ -22,8 +30,6 @@ module GHC.IO.FD ( stdin, stdout, stderr ) where -#undef DEBUG_DUMP - import GHC.Base import GHC.Num import GHC.Real @@ -39,7 +45,7 @@ import GHC.IO.Buffer import GHC.IO.BufferedIO import qualified GHC.IO.Device import GHC.IO.Device (SeekMode(..), IODeviceType(..)) -import GHC.Conc +import GHC.Conc.IO import GHC.IO.Exception import Foreign @@ -47,7 +53,10 @@ import Foreign.C import qualified System.Posix.Internals import System.Posix.Internals hiding (FD, setEcho, getEcho) import System.Posix.Types -import GHC.Ptr +-- import GHC.Ptr + +c_DEBUG_DUMP :: Bool +c_DEBUG_DUMP = False -- ----------------------------------------------------------------------------- -- The file-descriptor IO device @@ -97,8 +106,15 @@ instance GHC.IO.Device.IODevice FD where dup = dup dup2 = dup2 +-- We used to use System.Posix.Internals.dEFAULT_BUFFER_SIZE, which is +-- taken from the value of BUFSIZ on the current platform. This value +-- varies too much though: it is 512 on Windows, 1024 on OS X and 8192 +-- on Linux. So let's just use a decent size on every platform: +dEFAULT_FD_BUFFER_SIZE :: Int +dEFAULT_FD_BUFFER_SIZE = 8096 + instance BufferedIO FD where - newBuffer _dev state = newByteBuffer dEFAULT_BUFFER_SIZE state + newBuffer _dev state = newByteBuffer dEFAULT_FD_BUFFER_SIZE state fillReadBuffer fd buf = readBuf' fd buf fillReadBuffer0 fd buf = readBufNonBlocking fd buf flushWriteBuffer fd buf = writeBuf' fd buf @@ -106,30 +122,31 @@ instance BufferedIO FD where readBuf' :: FD -> Buffer Word8 -> IO (Int, Buffer Word8) readBuf' fd buf = do -#ifdef DEBUG_DUMP - puts ("readBuf fd=" ++ show fd ++ " " ++ summaryBuffer buf ++ "\n") -#endif + when c_DEBUG_DUMP $ + puts ("readBuf fd=" ++ show fd ++ " " ++ summaryBuffer buf ++ "\n") (r,buf') <- readBuf fd buf -#ifdef DEBUG_DUMP - puts ("after: " ++ summaryBuffer buf' ++ "\n") -#endif + when c_DEBUG_DUMP $ + puts ("after: " ++ summaryBuffer buf' ++ "\n") return (r,buf') -writeBuf' :: FD -> Buffer Word8 -> IO () +writeBuf' :: FD -> Buffer Word8 -> IO (Buffer Word8) writeBuf' fd buf = do -#ifdef DEBUG_DUMP - puts ("writeBuf fd=" ++ show fd ++ " " ++ summaryBuffer buf ++ "\n") -#endif + when c_DEBUG_DUMP $ + puts ("writeBuf fd=" ++ show fd ++ " " ++ summaryBuffer buf ++ "\n") writeBuf fd buf -- ----------------------------------------------------------------------------- -- opening files -- | Open a file and make an 'FD' for it. Truncates the file to zero --- size when the `IOMode` is `WriteMode`. Puts the file descriptor --- into non-blocking mode on Unix systems. -openFile :: FilePath -> IOMode -> IO (FD,IODeviceType) -openFile filepath iomode = +-- size when the `IOMode` is `WriteMode`. +openFile + :: FilePath -- ^ file to open + -> IOMode -- ^ mode in which to open the file + -> Bool -- ^ open the file in non-blocking mode? + -> IO (FD,IODeviceType) + +openFile filepath iomode non_blocking = withFilePath filepath $ \ f -> let @@ -149,7 +166,10 @@ openFile filepath iomode = binary_flags = 0 #endif - oflags = oflags1 .|. binary_flags + oflags2 = oflags1 .|. binary_flags + + oflags | non_blocking = oflags2 .|. nonblock_flags + | otherwise = oflags2 in do -- the old implementation had a complicated series of three opens, @@ -158,12 +178,14 @@ openFile filepath iomode = -- 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 <- throwErrnoIfMinus1Retry "openFile" - (c_open f (fromIntegral oflags) 0o666) + (if non_blocking then c_open f oflags 0o666 + else c_safe_open f oflags 0o666) (fD,fd_type) <- mkFD fd iomode Nothing{-no stat-} False{-not a socket-} - True{-is non-blocking-} - `catchAny` \e -> do c_close fd; throwIO e + non_blocking + `catchAny` \e -> do _ <- c_close fd + throwIO e #ifndef mingw32_HOST_OS -- we want to truncate() if this is an open in WriteMode, but only @@ -177,13 +199,14 @@ openFile filepath iomode = return (fD,fd_type) std_flags, output_flags, read_flags, write_flags, rw_flags, - append_flags :: CInt -std_flags = o_NONBLOCK .|. o_NOCTTY + append_flags, nonblock_flags :: CInt +std_flags = o_NOCTTY output_flags = std_flags .|. o_CREAT read_flags = std_flags .|. o_RDONLY write_flags = output_flags .|. o_WRONLY rw_flags = output_flags .|. o_RDWR append_flags = write_flags .|. o_APPEND +nonblock_flags = o_NONBLOCK -- | Make a 'FD' from an existing file descriptor. Fails if the FD @@ -216,7 +239,7 @@ mkFD fd iomode mb_stat is_socket is_nonblock = do _ -> True #ifdef mingw32_HOST_OS - setmode fd True -- unconditionally set binary mode + _ <- setmode fd True -- unconditionally set binary mode let _ = (dev,ino,write) -- warning suppression #endif @@ -279,23 +302,25 @@ stderr = stdFD 2 close :: FD -> IO () close fd = #ifndef mingw32_HOST_OS - (flip finally) (release fd) $ do + (flip finally) (release fd) $ #endif - throwErrnoIfMinus1Retry_ "GHC.IO.FD.close" $ + do let closer realFd = + throwErrnoIfMinus1Retry_ "GHC.IO.FD.close" $ #ifdef mingw32_HOST_OS - if fdIsSocket fd then - c_closesocket (fdFD fd) - else + if fdIsSocket fd then + c_closesocket (fromIntegral realFd) + else #endif - c_close (fdFD fd) + c_close (fromIntegral realFd) + closeFdWith closer (fromIntegral (fdFD fd)) release :: FD -> IO () -release fd = do -#ifndef mingw32_HOST_OS - unlockFile (fdFD fd) +#ifdef mingw32_HOST_OS +release _ = return () +#else +release fd = do _ <- unlockFile (fdFD fd) + return () #endif - let _ = fd -- warning suppression - return () #ifdef mingw32_HOST_OS foreign import stdcall unsafe "HsBase.h closesocket" @@ -309,9 +334,8 @@ isSeekable fd = do seek :: FD -> SeekMode -> Integer -> IO () seek fd mode off = do - throwErrnoIfMinus1Retry "seek" $ + throwErrnoIfMinus1Retry_ "seek" $ c_lseek (fdFD fd) (fromIntegral off) seektype - return () where seektype :: CInt seektype = case mode of @@ -330,9 +354,8 @@ getSize fd = fdFileSize (fdFD fd) setSize :: FD -> Integer -> IO () setSize fd size = do - throwErrnoIf (/=0) "GHC.IO.FD.setSize" $ + throwErrnoIf_ (/=0) "GHC.IO.FD.setSize" $ c_ftruncate (fdFD fd) (fromIntegral size) - return () devType :: FD -> IO IODeviceType devType fd = do (ty,_,_) <- fdStat (fdFD fd); return ty @@ -345,7 +368,7 @@ dup fd = do dup2 :: FD -> FD -> IO FD dup2 fd fdto = do -- Windows' dup2 does not return the new descriptor, unlike Unix - throwErrnoIfMinus1 "GHC.IO.FD.dup2" $ + throwErrnoIfMinus1_ "GHC.IO.FD.dup2" $ c_dup2 (fdFD fd) (fdFD fdto) return fd{ fdFD = fdFD fdto } -- original FD, with the new fdFD @@ -377,7 +400,12 @@ foreign import ccall safe "fdReady" -- Terminal-related stuff isTerminal :: FD -> IO Bool -isTerminal fd = c_isatty (fdFD fd) >>= return.toBool +isTerminal fd = +#if defined(mingw32_HOST_OS) + is_console (fdFD fd) >>= return.toBool +#else + c_isatty (fdFD fd) >>= return.toBool +#endif setEcho :: FD -> Bool -> IO () setEcho fd on = System.Posix.Internals.setEcho (fdFD fd) on @@ -392,17 +420,17 @@ setRaw fd raw = System.Posix.Internals.setCooked (fdFD fd) (not raw) -- Reading and Writing fdRead :: FD -> Ptr Word8 -> Int -> IO Int -fdRead fd ptr bytes = do - r <- readRawBufferPtr "GHC.IO.FD.fdRead" fd ptr 0 (fromIntegral bytes) - return (fromIntegral r) +fdRead fd ptr bytes + = do { r <- readRawBufferPtr "GHC.IO.FD.fdRead" fd ptr 0 (fromIntegral bytes) + ; return (fromIntegral r) } fdReadNonBlocking :: FD -> Ptr Word8 -> Int -> IO (Maybe Int) fdReadNonBlocking fd ptr bytes = do r <- readRawBufferPtrNoBlock "GHC.IO.FD.fdReadNonBlocking" fd ptr 0 (fromIntegral bytes) - case r of + case fromIntegral r of (-1) -> return (Nothing) - n -> return (Just (fromIntegral n)) + n -> return (Just n) fdWrite :: FD -> Ptr Word8 -> Int -> IO () @@ -580,7 +608,19 @@ blockingWriteRawBufferPtr loc fd buf off len = fmap fromIntegral $ throwErrnoIfMinus1Retry loc $ if fdIsSocket fd then c_safe_send (fdFD fd) (buf `plusPtr` off) len 0 - else c_safe_write (fdFD fd) (buf `plusPtr` off) len + else do + r <- c_safe_write (fdFD fd) (buf `plusPtr` off) len + when (r == -1) c_maperrno + return r + -- we don't trust write() to give us the correct errno, and + -- instead do the errno conversion from GetLastError() + -- ourselves. The main reason is that we treat ERROR_NO_DATA + -- (pipe is closing) as EPIPE, whereas write() returns EINVAL + -- for this case. We need to detect EPIPE correctly, because it + -- shouldn't be reported as an error when it happens on stdout. + +foreign import ccall unsafe "maperrno" -- in Win32Utils.c + c_maperrno :: IO () -- NOTE: "safe" versions of the read/write calls for use by the threaded RTS. -- These calls may block, but that's ok. @@ -625,8 +665,7 @@ foreign import ccall unsafe "unlockFile" unlockFile :: CInt -> IO CInt #endif -#if defined(DEBUG_DUMP) puts :: String -> IO () -puts s = do withCStringLen s $ \(p,len) -> c_write 1 p (fromIntegral len) +puts s = do _ <- withCStringLen s $ \(p,len) -> + c_write 1 (castPtr p) (fromIntegral len) return () -#endif