-{-# 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
stdin, stdout, stderr
) where
-#undef DEBUG_DUMP
-
import GHC.Base
import GHC.Num
import GHC.Real
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
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
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
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
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,
-- 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
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
_ -> 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
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"
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
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
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
-- 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
-- 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 ()
= 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.
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
projects / ghc-base.git / blobdiff