summaryrefslogtreecommitdiff
path: root/libraries/base/GHC/IO
diff options
context:
space:
mode:
authorKavon Farvardin <kavon@farvard.in>2018-09-23 15:29:37 -0500
committerKavon Farvardin <kavon@farvard.in>2018-09-23 15:29:37 -0500
commit84c2ad99582391005b5e873198b15e9e9eb4f78d (patch)
treecaa8c2f2ec7e97fbb4977263c6817c9af5025cf4 /libraries/base/GHC/IO
parent8ddb47cfcf5776e9a3c55fd37947c8a95e00fa12 (diff)
parente68b439fe5de61b9a2ca51af472185c62ccb8b46 (diff)
downloadhaskell-wip/T13904.tar.gz
update to current master againwip/T13904
Diffstat (limited to 'libraries/base/GHC/IO')
-rw-r--r--libraries/base/GHC/IO/Buffer.hs8
-rw-r--r--libraries/base/GHC/IO/BufferedIO.hs4
-rw-r--r--libraries/base/GHC/IO/Device.hs15
-rw-r--r--libraries/base/GHC/IO/Encoding.hs19
-rw-r--r--libraries/base/GHC/IO/Encoding/CodePage/API.hs4
-rw-r--r--libraries/base/GHC/IO/Encoding/Failure.hs7
-rw-r--r--libraries/base/GHC/IO/Encoding/Types.hs8
-rw-r--r--libraries/base/GHC/IO/Exception.hs22
-rw-r--r--libraries/base/GHC/IO/FD.hs67
-rw-r--r--libraries/base/GHC/IO/Handle.hs44
-rw-r--r--libraries/base/GHC/IO/Handle/FD.hs10
-rw-r--r--libraries/base/GHC/IO/Handle/Lock.hsc107
-rw-r--r--libraries/base/GHC/IO/Handle/Text.hs23
-rw-r--r--libraries/base/GHC/IO/Handle/Types.hs18
-rw-r--r--libraries/base/GHC/IO/IOMode.hs8
-rw-r--r--libraries/base/GHC/IO/Unsafe.hs3
16 files changed, 273 insertions, 94 deletions
diff --git a/libraries/base/GHC/IO/Buffer.hs b/libraries/base/GHC/IO/Buffer.hs
index 33eee6363d..447c574e2b 100644
--- a/libraries/base/GHC/IO/Buffer.hs
+++ b/libraries/base/GHC/IO/Buffer.hs
@@ -1,4 +1,4 @@
-{-# LANGUAGE Trustworthy #-}
+{-# LANGUAGE Trustworthy, BangPatterns #-}
{-# LANGUAGE CPP, NoImplicitPrelude #-}
{-# OPTIONS_GHC -funbox-strict-fields #-}
@@ -192,7 +192,8 @@ type CharBuffer = Buffer Word16
type CharBuffer = Buffer Char
#endif
-data BufferState = ReadBuffer | WriteBuffer deriving (Eq)
+data BufferState = ReadBuffer | WriteBuffer
+ deriving Eq -- ^ @since 4.2.0.0
withBuffer :: Buffer e -> (Ptr e -> IO a) -> IO a
withBuffer Buffer{ bufRaw=raw } f = withForeignPtr (castForeignPtr raw) f
@@ -264,7 +265,8 @@ foreign import ccall unsafe "memmove"
memmove :: Ptr a -> Ptr a -> CSize -> IO (Ptr a)
summaryBuffer :: Buffer a -> String
-summaryBuffer buf = "buf" ++ show (bufSize buf) ++ "(" ++ show (bufL buf) ++ "-" ++ show (bufR buf) ++ ")"
+summaryBuffer !buf -- Strict => slightly better code
+ = "buf" ++ show (bufSize buf) ++ "(" ++ show (bufL buf) ++ "-" ++ show (bufR buf) ++ ")"
-- INVARIANTS on Buffers:
-- * r <= w
diff --git a/libraries/base/GHC/IO/BufferedIO.hs b/libraries/base/GHC/IO/BufferedIO.hs
index 4c81d9a4ec..cd38cefe07 100644
--- a/libraries/base/GHC/IO/BufferedIO.hs
+++ b/libraries/base/GHC/IO/BufferedIO.hs
@@ -32,8 +32,8 @@ import GHC.IO.Buffer
-- | The purpose of 'BufferedIO' is to provide a common interface for I/O
-- devices that can read and write data through a buffer. Devices that
-- implement 'BufferedIO' include ordinary files, memory-mapped files,
--- and bytestrings. The underlying device implementing a 'Handle' must
--- provide 'BufferedIO'.
+-- and bytestrings. The underlying device implementing a 'System.IO.Handle'
+-- must provide 'BufferedIO'.
--
class BufferedIO dev where
-- | allocate a new buffer. The size of the buffer is at the
diff --git a/libraries/base/GHC/IO/Device.hs b/libraries/base/GHC/IO/Device.hs
index ddeb861eca..e33dcd02b1 100644
--- a/libraries/base/GHC/IO/Device.hs
+++ b/libraries/base/GHC/IO/Device.hs
@@ -56,7 +56,7 @@ class RawIO a where
writeNonBlocking :: a -> Ptr Word8 -> Int -> IO Int
--- | I/O operations required for implementing a 'Handle'.
+-- | I/O operations required for implementing a 'System.IO.Handle'.
class IODevice a where
-- | @ready dev write msecs@ returns 'True' if the device has data
-- to read (if @write@ is 'False') or space to write new data (if
@@ -154,17 +154,24 @@ data IODeviceType
-- read and write operations and may be seekable only
-- to positions of certain granularity (block-
-- aligned).
- deriving (Eq)
+ deriving ( Eq -- ^ @since 4.2.0.0
+ )
-- -----------------------------------------------------------------------------
-- SeekMode type
--- | A mode that determines the effect of 'hSeek' @hdl mode i@.
+-- | A mode that determines the effect of 'System.IO.hSeek' @hdl mode i@.
data SeekMode
= AbsoluteSeek -- ^ the position of @hdl@ is set to @i@.
| RelativeSeek -- ^ the position of @hdl@ is set to offset @i@
-- from the current position.
| SeekFromEnd -- ^ the position of @hdl@ is set to offset @i@
-- from the end of the file.
- deriving (Eq, Ord, Ix, Enum, Read, Show)
+ deriving ( Eq -- ^ @since 4.2.0.0
+ , Ord -- ^ @since 4.2.0.0
+ , Ix -- ^ @since 4.2.0.0
+ , Enum -- ^ @since 4.2.0.0
+ , Read -- ^ @since 4.2.0.0
+ , Show -- ^ @since 4.2.0.0
+ )
diff --git a/libraries/base/GHC/IO/Encoding.hs b/libraries/base/GHC/IO/Encoding.hs
index 578a420faf..b734f00f5b 100644
--- a/libraries/base/GHC/IO/Encoding.hs
+++ b/libraries/base/GHC/IO/Encoding.hs
@@ -27,6 +27,7 @@ module GHC.IO.Encoding (
setLocaleEncoding, setFileSystemEncoding, setForeignEncoding,
char8,
mkTextEncoding,
+ argvEncoding
) where
import GHC.Base
@@ -56,7 +57,8 @@ import System.IO.Unsafe (unsafePerformIO)
-- | The Latin1 (ISO8859-1) encoding. This encoding maps bytes
-- directly to the first 256 Unicode code points, and is thus not a
-- complete Unicode encoding. An attempt to write a character greater than
--- '\255' to a 'Handle' using the 'latin1' encoding will result in an error.
+-- '\255' to a 'System.IO.Handle' using the 'latin1' encoding will result in an
+-- error.
latin1 :: TextEncoding
latin1 = Latin1.latin1_checked
@@ -121,7 +123,7 @@ getFileSystemEncoding :: IO TextEncoding
-- | The Unicode encoding of the current locale, but where undecodable
-- bytes are replaced with their closest visual match. Used for
--- the 'CString' marshalling functions in "Foreign.C.String"
+-- the 'Foreign.C.String.CString' marshalling functions in "Foreign.C.String"
--
-- @since 4.5.0.0
getForeignEncoding :: IO TextEncoding
@@ -161,6 +163,17 @@ initFileSystemEncoding = CodePage.mkLocaleEncoding RoundtripFailure
initForeignEncoding = CodePage.mkLocaleEncoding IgnoreCodingFailure
#endif
+-- See Note [Windows Unicode Arguments] in rts/RtsFlags.c
+-- On Windows we assume hs_init argv is in utf8 encoding.
+
+-- | Internal encoding of argv
+argvEncoding :: IO TextEncoding
+#if defined(mingw32_HOST_OS)
+argvEncoding = return utf8
+#else
+argvEncoding = getFileSystemEncoding
+#endif
+
-- | An encoding in which Unicode code points are translated to bytes
-- by taking the code point modulo 256. When decoding, bytes are
-- translated directly into the equivalent code point.
@@ -175,7 +188,7 @@ char8 = Latin1.latin1
-- | Look up the named Unicode encoding. May fail with
--
--- * 'isDoesNotExistError' if the encoding is unknown
+-- * 'System.IO.Error.isDoesNotExistError' if the encoding is unknown
--
-- The set of known encodings is system-dependent, but includes at least:
--
diff --git a/libraries/base/GHC/IO/Encoding/CodePage/API.hs b/libraries/base/GHC/IO/Encoding/CodePage/API.hs
index f1d9d93e8f..b31ebe96f5 100644
--- a/libraries/base/GHC/IO/Encoding/CodePage/API.hs
+++ b/libraries/base/GHC/IO/Encoding/CodePage/API.hs
@@ -285,7 +285,7 @@ cpEncode cp _max_char_size = \ibuf obuf -> do
return (why2, mbuf', obuf)
#else
case why2 of
- -- If we succesfully translate all of the UTF-16 buffer, we need to know why
+ -- If we successfully translate all of the UTF-16 buffer, we need to know why
-- we weren't able to get any more UTF-16 out of the UTF-32 buffer
InputUnderflow | isEmptyBuffer mbuf' -> return (why1, ibuf', obuf)
| otherwise -> errorWithoutStackTrace "cpEncode: impossible underflown UTF-16 buffer"
@@ -361,7 +361,7 @@ bSearch msg code ibuf mbuf target_to_elems = go
--
-- Luckily if we have InvalidSequence/OutputUnderflow and we do not appear to have reached
-- the target, what we should do is the same as normal because the fraction of ibuf that our
- -- first "code" coded succesfully must be invalid-sequence-free, and ibuf will always
+ -- first "code" coded successfully must be invalid-sequence-free, and ibuf will always
-- have been decoded as far as the first invalid sequence in it.
case bufferElems mbuf `compare` target_to_elems of
-- Coding n "from" chars from the input yields exactly as many "to" chars
diff --git a/libraries/base/GHC/IO/Encoding/Failure.hs b/libraries/base/GHC/IO/Encoding/Failure.hs
index 3f9360d731..c8d29f4d50 100644
--- a/libraries/base/GHC/IO/Encoding/Failure.hs
+++ b/libraries/base/GHC/IO/Encoding/Failure.hs
@@ -34,8 +34,8 @@ import GHC.Real ( fromIntegral )
--import System.Posix.Internals
--- | The 'CodingFailureMode' is used to construct 'TextEncoding's, and
--- specifies how they handle illegal sequences.
+-- | The 'CodingFailureMode' is used to construct 'System.IO.TextEncoding's,
+-- and specifies how they handle illegal sequences.
data CodingFailureMode
= ErrorOnCodingFailure
-- ^ Throw an error when an illegal sequence is encountered
@@ -48,7 +48,8 @@ data CodingFailureMode
| RoundtripFailure
-- ^ Use the private-use escape mechanism to attempt to allow
-- illegal sequences to be roundtripped.
- deriving (Show)
+ deriving ( Show -- ^ @since 4.4.0.0
+ )
-- This will only work properly for those encodings which are
-- strict supersets of ASCII in the sense that valid ASCII data
-- is also valid in that encoding. This is not true for
diff --git a/libraries/base/GHC/IO/Encoding/Types.hs b/libraries/base/GHC/IO/Encoding/Types.hs
index daab9d5157..2f8ffd5e59 100644
--- a/libraries/base/GHC/IO/Encoding/Types.hs
+++ b/libraries/base/GHC/IO/Encoding/Types.hs
@@ -103,11 +103,11 @@ type TextEncoder state = BufferCodec CharBufElem Word8 state
-- between sequences of bytes and sequences of Unicode characters.
--
-- For example, UTF-8 is an encoding of Unicode characters into a sequence
--- of bytes. The 'TextEncoding' for UTF-8 is 'utf8'.
+-- of bytes. The 'TextEncoding' for UTF-8 is 'System.IO.utf8'.
data TextEncoding
= forall dstate estate . TextEncoding {
textEncodingName :: String,
- -- ^ a string that can be passed to 'mkTextEncoding' to
+ -- ^ a string that can be passed to 'System.IO.mkTextEncoding' to
-- create an equivalent 'TextEncoding'.
mkTextDecoder :: IO (TextDecoder dstate),
-- ^ Creates a means of decoding bytes into characters: the result must not
@@ -129,5 +129,7 @@ data CodingProgress = InputUnderflow -- ^ Stopped because the input contains in
| InvalidSequence -- ^ Stopped because there are sufficient free elements in the output
-- to output at least one encoded ASCII character, but the input contains
-- an invalid or unrepresentable sequence
- deriving (Eq, Show)
+ deriving ( Eq -- ^ @since 4.4.0.0
+ , Show -- ^ @since 4.4.0.0
+ )
diff --git a/libraries/base/GHC/IO/Exception.hs b/libraries/base/GHC/IO/Exception.hs
index 9203f46828..bd9a15216d 100644
--- a/libraries/base/GHC/IO/Exception.hs
+++ b/libraries/base/GHC/IO/Exception.hs
@@ -33,6 +33,7 @@ module GHC.IO.Exception (
ArrayException(..),
ExitCode(..),
+ FixIOException (..),
ioException,
ioError,
@@ -225,7 +226,9 @@ data AsyncException
-- ^This exception is raised by default in the main thread of
-- the program when the user requests to terminate the program
-- via the usual mechanism(s) (e.g. Control-C in the console).
- deriving (Eq, Ord)
+ deriving ( Eq -- ^ @since 4.2.0.0
+ , Ord -- ^ @since 4.2.0.0
+ )
-- | @since 4.7.0.0
instance Exception AsyncException where
@@ -240,7 +243,9 @@ data ArrayException
| UndefinedElement String
-- ^An attempt was made to evaluate an element of an
-- array that had not been initialized.
- deriving (Eq, Ord)
+ deriving ( Eq -- ^ @since 4.2.0.0
+ , Ord -- ^ @since 4.2.0.0
+ )
-- | @since 4.1.0.0
instance Exception ArrayException
@@ -268,6 +273,19 @@ instance Show ArrayException where
. (if not (null s) then showString ": " . showString s
else id)
+-- | The exception thrown when an infinite cycle is detected in
+-- 'System.IO.fixIO'.
+--
+-- @since 4.11.0.0
+data FixIOException = FixIOException
+
+-- | @since 4.11.0.0
+instance Exception FixIOException
+
+-- | @since 4.11.0.0
+instance Show FixIOException where
+ showsPrec _ FixIOException = showString "cyclic evaluation in fixIO"
+
-- -----------------------------------------------------------------------------
-- The ExitCode type
diff --git a/libraries/base/GHC/IO/FD.hs b/libraries/base/GHC/IO/FD.hs
index 8eafe08fdc..d5567f0838 100644
--- a/libraries/base/GHC/IO/FD.hs
+++ b/libraries/base/GHC/IO/FD.hs
@@ -45,6 +45,7 @@ import GHC.Conc.IO
import GHC.IO.Exception
#if defined(mingw32_HOST_OS)
import GHC.Windows
+import Data.Bool
#endif
import Foreign
@@ -179,14 +180,10 @@ openFile filepath iomode non_blocking =
| otherwise = oflags2
in do
- -- the old implementation had a complicated series of three opens,
- -- which is perhaps because we have to be careful not to open
- -- 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 <- throwErrnoIfMinus1Retry "openFile"
- (if non_blocking then c_open f oflags 0o666
- else c_safe_open f oflags 0o666)
+ -- NB. always use a safe open(), because we don't know whether open()
+ -- will be fast or not. It can be slow on NFS and FUSE filesystems,
+ -- for example.
+ fd <- throwErrnoIfMinus1Retry "openFile" $ c_safe_open f oflags 0o666
(fD,fd_type) <- mkFD fd iomode Nothing{-no stat-}
False{-not a socket-}
@@ -405,7 +402,7 @@ ready fd write msecs = do
return (toEnum (fromIntegral r))
foreign import ccall safe "fdReady"
- fdReady :: CInt -> CInt -> CInt -> CInt -> IO CInt
+ fdReady :: CInt -> CBool -> Int64 -> CBool -> IO CInt
-- ---------------------------------------------------------------------------
-- Terminal-related stuff
@@ -566,7 +563,7 @@ isNonBlocking :: FD -> Bool
isNonBlocking fd = fdIsNonBlocking fd /= 0
foreign import ccall unsafe "fdReady"
- unsafe_fdReady :: CInt -> CInt -> CInt -> CInt -> IO CInt
+ unsafe_fdReady :: CInt -> CBool -> Int64 -> CBool -> IO CInt
#else /* mingw32_HOST_OS.... */
@@ -593,8 +590,10 @@ asyncReadRawBufferPtr loc !fd !buf !off !len = do
(l, rc) <- asyncRead (fromIntegral (fdFD fd)) (fdIsSocket_ fd)
(fromIntegral len) (buf `plusPtr` off)
if l == (-1)
- then
- ioError (errnoToIOError loc (Errno (fromIntegral rc)) Nothing Nothing)
+ then let sock_errno = c_maperrno_func (fromIntegral rc)
+ non_sock_errno = Errno (fromIntegral rc)
+ errno = bool non_sock_errno sock_errno (fdIsSocket fd)
+ in ioError (errnoToIOError loc errno Nothing Nothing)
else return (fromIntegral l)
asyncWriteRawBufferPtr :: String -> FD -> Ptr Word8 -> Int -> CSize -> IO CInt
@@ -602,34 +601,46 @@ asyncWriteRawBufferPtr loc !fd !buf !off !len = do
(l, rc) <- asyncWrite (fromIntegral (fdFD fd)) (fdIsSocket_ fd)
(fromIntegral len) (buf `plusPtr` off)
if l == (-1)
- then
- ioError (errnoToIOError loc (Errno (fromIntegral rc)) Nothing Nothing)
+ then let sock_errno = c_maperrno_func (fromIntegral rc)
+ non_sock_errno = Errno (fromIntegral rc)
+ errno = bool non_sock_errno sock_errno (fdIsSocket fd)
+ in ioError (errnoToIOError loc errno Nothing Nothing)
else return (fromIntegral l)
-- Blocking versions of the read/write primitives, for the threaded RTS
blockingReadRawBufferPtr :: String -> FD -> Ptr Word8 -> Int -> CSize -> IO CInt
blockingReadRawBufferPtr loc !fd !buf !off !len
- = throwErrnoIfMinus1Retry loc $
- if fdIsSocket fd
- then c_safe_recv (fdFD fd) (buf `plusPtr` off) (fromIntegral len) 0
- else c_safe_read (fdFD fd) (buf `plusPtr` off) (fromIntegral len)
+ = throwErrnoIfMinus1Retry loc $ do
+ let start_ptr = buf `plusPtr` off
+ recv_ret = c_safe_recv (fdFD fd) start_ptr (fromIntegral len) 0
+ read_ret = c_safe_read (fdFD fd) start_ptr (fromIntegral len)
+ r <- bool read_ret recv_ret (fdIsSocket fd)
+ when ((fdIsSocket fd) && (r == -1)) c_maperrno
+ return r
+ -- We trust read() to give us the correct errno but recv(), as a
+ -- Winsock function, doesn't do the errno conversion so if the fd
+ -- is for a socket, we do it from GetLastError() ourselves.
blockingWriteRawBufferPtr :: String -> FD -> Ptr Word8-> Int -> CSize -> IO CInt
blockingWriteRawBufferPtr loc !fd !buf !off !len
- = throwErrnoIfMinus1Retry loc $
- if fdIsSocket fd
- then c_safe_send (fdFD fd) (buf `plusPtr` off) (fromIntegral len) 0
- else do
- r <- c_safe_write (fdFD fd) (buf `plusPtr` off) (fromIntegral len)
- when (r == -1) c_maperrno
- return r
- -- we don't trust write() to give us the correct errno, and
+ = throwErrnoIfMinus1Retry loc $ do
+ let start_ptr = buf `plusPtr` off
+ send_ret = c_safe_send (fdFD fd) start_ptr (fromIntegral len) 0
+ write_ret = c_safe_write (fdFD fd) start_ptr (fromIntegral len)
+ r <- bool write_ret send_ret (fdIsSocket fd)
+ 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
+ -- 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
+ -- for this case. We need to detect EPIPE correctly, because it
-- shouldn't be reported as an error when it happens on stdout.
+ -- As for send()'s case, Winsock functions don't do errno
+ -- conversion in any case so we have to do it ourselves.
+ -- That means we're doing the errno conversion no matter if the
+ -- fd is from a socket or not.
-- NOTE: "safe" versions of the read/write calls for use by the threaded RTS.
-- These calls may block, but that's ok.
diff --git a/libraries/base/GHC/IO/Handle.hs b/libraries/base/GHC/IO/Handle.hs
index 648523a11f..01c226dfbd 100644
--- a/libraries/base/GHC/IO/Handle.hs
+++ b/libraries/base/GHC/IO/Handle.hs
@@ -183,7 +183,7 @@ isEOF = hIsEOF stdin
--
-- This operation may fail with:
--
--- * 'isEOFError' if the end of file has been reached.
+-- * 'System.IO.Error.isEOFError' if the end of file has been reached.
hLookAhead :: Handle -> IO Char
hLookAhead handle =
@@ -208,9 +208,9 @@ hLookAhead handle =
--
-- This operation may fail with:
--
--- * 'isPermissionError' if the handle has already been used for reading
--- or writing and the implementation does not allow the buffering mode
--- to be changed.
+-- * 'System.IO.Error.isPermissionError' if the handle has already been used
+-- for reading or writing and the implementation does not allow the
+-- buffering mode to be changed.
hSetBuffering :: Handle -> BufferMode -> IO ()
hSetBuffering handle mode =
@@ -251,8 +251,8 @@ hSetBuffering handle mode =
-- | The action 'hSetEncoding' @hdl@ @encoding@ changes the text encoding
-- for the handle @hdl@ to @encoding@. The default encoding when a 'Handle' is
--- created is 'localeEncoding', namely the default encoding for the current
--- locale.
+-- created is 'System.IO.localeEncoding', namely the default encoding for the
+-- current locale.
--
-- To create a 'Handle' with no encoding at all, use 'openBinaryFile'. To
-- stop further encoding or decoding on an existing 'Handle', use
@@ -295,11 +295,11 @@ hGetEncoding hdl =
--
-- This operation may fail with:
--
--- * 'isFullError' if the device is full;
+-- * 'System.IO.Error.isFullError' if the device is full;
--
--- * 'isPermissionError' if a system resource limit would be exceeded.
--- It is unspecified whether the characters in the buffer are discarded
--- or retained under these circumstances.
+-- * 'System.IO.Error.isPermissionError' if a system resource limit would be
+-- exceeded. It is unspecified whether the characters in the buffer are
+-- discarded or retained under these circumstances.
hFlush :: Handle -> IO ()
hFlush handle = wantWritableHandle "hFlush" handle flushWriteBuffer
@@ -312,14 +312,14 @@ hFlush handle = wantWritableHandle "hFlush" handle flushWriteBuffer
--
-- This operation may fail with:
--
--- * 'isFullError' if the device is full;
+-- * 'System.IO.Error.isFullError' if the device is full;
--
--- * 'isPermissionError' if a system resource limit would be exceeded.
--- It is unspecified whether the characters in the buffer are discarded
--- or retained under these circumstances;
+-- * 'System.IO.Error.isPermissionError' if a system resource limit would be
+-- exceeded. It is unspecified whether the characters in the buffer are
+-- discarded or retained under these circumstances;
--
--- * 'isIllegalOperation' if @hdl@ has buffered read data, and is not
--- seekable.
+-- * 'System.IO.Error.isIllegalOperation' if @hdl@ has buffered read data, and
+-- is not seekable.
hFlushAll :: Handle -> IO ()
hFlushAll handle = withHandle_ "hFlushAll" handle flushBuffer
@@ -358,7 +358,8 @@ hGetPosn handle = do
--
-- This operation may fail with:
--
--- * 'isPermissionError' if a system resource limit would be exceeded.
+-- * 'System.IO.Error.isPermissionError' if a system resource limit would be
+-- exceeded.
hSetPosn :: HandlePosn -> IO ()
hSetPosn (HandlePosn h i) = hSeek h AbsoluteSeek i
@@ -391,10 +392,11 @@ hSetPosn (HandlePosn h i) = hSeek h AbsoluteSeek i
--
-- This operation may fail with:
--
--- * 'isIllegalOperationError' if the Handle is not seekable, or does
--- not support the requested seek mode.
+-- * 'System.IO.Error.isIllegalOperationError' if the Handle is not seekable,
+-- or does not support the requested seek mode.
--
--- * 'isPermissionError' if a system resource limit would be exceeded.
+-- * 'System.IO.Error.isPermissionError' if a system resource limit would be
+-- exceeded.
hSeek :: Handle -> SeekMode -> Integer -> IO ()
hSeek handle mode offset =
@@ -425,7 +427,7 @@ hSeek handle mode offset =
--
-- This operation may fail with:
--
--- * 'isIllegalOperationError' if the Handle is not seekable.
+-- * 'System.IO.Error.isIllegalOperationError' if the Handle is not seekable.
--
hTell :: Handle -> IO Integer
hTell handle =
diff --git a/libraries/base/GHC/IO/Handle/FD.hs b/libraries/base/GHC/IO/Handle/FD.hs
index 786fccc4f1..883bc5fe59 100644
--- a/libraries/base/GHC/IO/Handle/FD.hs
+++ b/libraries/base/GHC/IO/Handle/FD.hs
@@ -128,11 +128,13 @@ addFilePathToIOError fun fp ioe
--
-- This operation may fail with:
--
--- * 'isAlreadyInUseError' if the file is already open and cannot be reopened;
+-- * 'System.IO.Error.isAlreadyInUseError' if the file is already open and
+-- cannot be reopened;
--
--- * 'isDoesNotExistError' if the file does not exist; or
+-- * 'System.IO.Error.isDoesNotExistError' if the file does not exist; or
--
--- * 'isPermissionError' if the user does not have permission to open the file.
+-- * 'System.IO.Error.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'.
@@ -161,7 +163,7 @@ openFileBlocking fp im =
-- this is undesirable; also, as usual under Microsoft operating systems,
-- text mode treats control-Z as EOF. Binary mode turns off all special
-- treatment of end-of-line and end-of-file characters.
--- (See also 'hSetBinaryMode'.)
+-- (See also 'System.IO.hSetBinaryMode'.)
openBinaryFile :: FilePath -> IOMode -> IO Handle
openBinaryFile fp m =
diff --git a/libraries/base/GHC/IO/Handle/Lock.hsc b/libraries/base/GHC/IO/Handle/Lock.hsc
index ec62f86cc9..ec85ffd25e 100644
--- a/libraries/base/GHC/IO/Handle/Lock.hsc
+++ b/libraries/base/GHC/IO/Handle/Lock.hsc
@@ -8,6 +8,7 @@ module GHC.IO.Handle.Lock (
, LockMode(..)
, hLock
, hTryLock
+ , hUnlock
) where
#include "HsBaseConfig.h"
@@ -62,8 +63,9 @@ import GHC.Show
-- | Exception thrown by 'hLock' on non-Windows platforms that don't support
-- 'flock'.
data FileLockingNotSupported = FileLockingNotSupported
- deriving Show
+ deriving Show -- ^ @since 4.10.0.0
+-- ^ @since 4.10.0.0
instance Exception FileLockingNotSupported
-- | Indicates a mode in which a file should be locked.
@@ -97,9 +99,82 @@ hLock h mode = void $ lockImpl h "hLock" mode True
hTryLock :: Handle -> LockMode -> IO Bool
hTryLock h mode = lockImpl h "hTryLock" mode False
+-- | Release a lock taken with 'hLock' or 'hTryLock'.
+hUnlock :: Handle -> IO ()
+hUnlock = unlockImpl
+
----------------------------------------
-#if HAVE_FLOCK
+#if HAVE_OFD_LOCKING
+-- Linux open file descriptor locking.
+--
+-- We prefer this over BSD locking (e.g. flock) since the latter appears to
+-- break in some NFS configurations. Note that we intentionally do not try to
+-- use ordinary POSIX file locking due to its peculiar semantics under
+-- multi-threaded environments.
+
+foreign import ccall interruptible "fcntl"
+ c_fcntl :: CInt -> CInt -> Ptr () -> IO CInt
+
+data FLock = FLock { l_type :: CShort
+ , l_whence :: CShort
+ , l_start :: COff
+ , l_len :: COff
+ , l_pid :: CPid
+ }
+
+instance Storable FLock where
+ sizeOf _ = #{size flock}
+ alignment _ = #{alignment flock}
+ poke ptr x = do
+ fillBytes ptr 0 (sizeOf x)
+ #{poke flock, l_type} ptr (l_type x)
+ #{poke flock, l_whence} ptr (l_whence x)
+ #{poke flock, l_start} ptr (l_start x)
+ #{poke flock, l_len} ptr (l_len x)
+ #{poke flock, l_pid} ptr (l_pid x)
+ peek ptr = do
+ FLock <$> #{peek flock, l_type} ptr
+ <*> #{peek flock, l_whence} ptr
+ <*> #{peek flock, l_start} ptr
+ <*> #{peek flock, l_len} ptr
+ <*> #{peek flock, l_pid} ptr
+
+lockImpl :: Handle -> String -> LockMode -> Bool -> IO Bool
+lockImpl h ctx mode block = do
+ FD{fdFD = fd} <- handleToFd h
+ with flock $ \flock_ptr -> fix $ \retry -> do
+ ret <- with flock $ fcntl fd mode flock_ptr
+ case ret of
+ 0 -> return True
+ _ -> getErrno >>= \errno -> if
+ | not block && errno == eWOULDBLOCK -> return False
+ | errno == eINTR -> retry
+ | otherwise -> ioException $ errnoToIOError ctx errno (Just h) Nothing
+ where
+ flock = FLock { l_type = case mode of
+ SharedLock -> #{const F_RDLCK}
+ ExclusiveLock -> #{const F_WRLCK}
+ , l_whence = #{const SEEK_SET}
+ , l_start = 0
+ , l_len = 0
+ }
+ mode
+ | block = #{const F_SETLKW}
+ | otherwise = #{const F_SETLK}
+
+unlockImpl :: Handle -> IO ()
+unlockImpl h = do
+ FD{fdFD = fd} <- handleToFd h
+ let flock = FLock { l_type = #{const F_UNLCK}
+ , l_whence = #{const SEEK_SET}
+ , l_start = 0
+ , l_len = 0
+ }
+ throwErrnoIfMinus1_ "hUnlock"
+ $ with flock $ c_fcntl fd #{const F_SETLK}
+
+#elif HAVE_FLOCK
lockImpl :: Handle -> String -> LockMode -> Bool -> IO Bool
lockImpl h ctx mode block = do
@@ -108,7 +183,8 @@ lockImpl h ctx mode block = do
fix $ \retry -> c_flock fd flags >>= \case
0 -> return True
_ -> getErrno >>= \errno -> if
- | not block && errno == eWOULDBLOCK -> return False
+ | not block
+ , errno == eAGAIN || errno == eACCES -> return False
| errno == eINTR -> retry
| otherwise -> ioException $ errnoToIOError ctx errno (Just h) Nothing
where
@@ -116,6 +192,11 @@ lockImpl h ctx mode block = do
SharedLock -> #{const LOCK_SH}
ExclusiveLock -> #{const LOCK_EX}
+unlockImpl :: Handle -> IO ()
+unlockImpl h = do
+ FD{fdFD = fd} <- handleToFd h
+ throwErrnoIfMinus1_ "flock" $ c_flock fd #{const LOCK_UN}
+
foreign import ccall interruptible "flock"
c_flock :: CInt -> CInt -> IO CInt
@@ -146,6 +227,18 @@ lockImpl h ctx mode block = do
SharedLock -> 0
ExclusiveLock -> #{const LOCKFILE_EXCLUSIVE_LOCK}
+unlockImpl :: Handle -> IO ()
+unlockImpl h = do
+ FD{fdFD = fd} <- handleToFd h
+ wh <- throwErrnoIf (== iNVALID_HANDLE_VALUE) "hUnlock" $ c_get_osfhandle fd
+ allocaBytes sizeof_OVERLAPPED $ \ovrlpd -> do
+ fillBytes ovrlpd 0 sizeof_OVERLAPPED
+ c_UnlockFileEx wh 0 0xffffffff 0xffffffff ovrlpd >>= \case
+ True -> return ()
+ False -> getLastError >>= failWith "hUnlock"
+ where
+ sizeof_OVERLAPPED = #{size OVERLAPPED}
+
-- https://msdn.microsoft.com/en-us/library/aa297958.aspx
foreign import ccall unsafe "_get_osfhandle"
c_get_osfhandle :: CInt -> IO HANDLE
@@ -154,10 +247,18 @@ foreign import ccall unsafe "_get_osfhandle"
foreign import WINDOWS_CCONV interruptible "LockFileEx"
c_LockFileEx :: HANDLE -> DWORD -> DWORD -> DWORD -> DWORD -> Ptr () -> IO BOOL
+-- https://msdn.microsoft.com/en-us/library/windows/desktop/aa365716.aspx
+foreign import WINDOWS_CCONV interruptible "UnlockFileEx"
+ c_UnlockFileEx :: HANDLE -> DWORD -> DWORD -> DWORD -> Ptr () -> IO BOOL
+
#else
-- | No-op implementation.
lockImpl :: Handle -> String -> LockMode -> Bool -> IO Bool
lockImpl _ _ _ _ = throwIO FileLockingNotSupported
+-- | No-op implementation.
+unlockImpl :: Handle -> IO ()
+unlockImpl _ = throwIO FileLockingNotSupported
+
#endif
diff --git a/libraries/base/GHC/IO/Handle/Text.hs b/libraries/base/GHC/IO/Handle/Text.hs
index 57b9534976..dcf4b7c174 100644
--- a/libraries/base/GHC/IO/Handle/Text.hs
+++ b/libraries/base/GHC/IO/Handle/Text.hs
@@ -353,10 +353,10 @@ unpack_nl !buf !r !w acc0
-- list returned by 'hGetContents' @hdl@.
--
-- Any operation that fails because a handle is closed,
--- also fails if a handle is semi-closed. The only exception is 'hClose'.
--- A semi-closed handle becomes closed:
+-- also fails if a handle is semi-closed. The only exception is
+-- 'System.IO.hClose'. A semi-closed handle becomes closed:
--
--- * if 'hClose' is applied to it;
+-- * if 'System.IO.hClose' is applied to it;
--
-- * if an I\/O error occurs when reading an item from the handle;
--
@@ -537,6 +537,7 @@ hPutStrLn handle str = hPutStr' handle str True
-- overhead of a single putChar '\n', which is quite high now that we
-- have to encode eagerly.
+{-# NOINLINE hPutStr' #-}
hPutStr' :: Handle -> String -> Bool -> IO ()
hPutStr' handle str add_nl =
do
@@ -683,7 +684,7 @@ commitBuffer' raw sz@(I# _) count@(I# _) flush release h_@Handle__{..}
-- 'hPutBuf' ignores any text encoding that applies to the 'Handle',
-- writing the bytes directly to the underlying file or device.
--
--- 'hPutBuf' ignores the prevailing 'TextEncoding' and
+-- 'hPutBuf' ignores the prevailing 'System.IO.TextEncoding' and
-- 'NewlineMode' on the 'Handle', and writes bytes directly.
--
-- This operation may fail with:
@@ -803,11 +804,11 @@ writeChunkNonBlocking h_@Handle__{..} ptr bytes
-- If the handle is a pipe or socket, and the writing end
-- is closed, 'hGetBuf' will behave as if EOF was reached.
--
--- 'hGetBuf' ignores the prevailing 'TextEncoding' and 'NewlineMode'
+-- 'hGetBuf' ignores the prevailing 'System.IO.TextEncoding' and 'NewlineMode'
-- on the 'Handle', and reads bytes directly.
hGetBuf :: Handle -> Ptr a -> Int -> IO Int
-hGetBuf h ptr count
+hGetBuf h !ptr count
| count == 0 = return 0
| count < 0 = illegalBufferSize h "hGetBuf" count
| otherwise =
@@ -885,11 +886,11 @@ bufReadEmpty h_@Handle__{..}
-- If the handle is a pipe or socket, and the writing end
-- is closed, 'hGetBufSome' will behave as if EOF was reached.
--
--- 'hGetBufSome' ignores the prevailing 'TextEncoding' and 'NewlineMode'
--- on the 'Handle', and reads bytes directly.
+-- 'hGetBufSome' ignores the prevailing 'System.IO.TextEncoding' and
+-- 'NewlineMode' on the 'Handle', and reads bytes directly.
hGetBufSome :: Handle -> Ptr a -> Int -> IO Int
-hGetBufSome h ptr count
+hGetBufSome h !ptr count
| count == 0 = return 0
| count < 0 = illegalBufferSize h "hGetBufSome" count
| otherwise =
@@ -927,14 +928,14 @@ haFD h_@Handle__{..} = cast haDevice
-- If the handle is a pipe or socket, and the writing end
-- is closed, 'hGetBufNonBlocking' will behave as if EOF was reached.
--
--- 'hGetBufNonBlocking' ignores the prevailing 'TextEncoding' and
+-- 'hGetBufNonBlocking' ignores the prevailing 'System.IO.TextEncoding' and
-- 'NewlineMode' on the 'Handle', and reads bytes directly.
--
-- NOTE: on Windows, this function does not work correctly; it
-- behaves identically to 'hGetBuf'.
hGetBufNonBlocking :: Handle -> Ptr a -> Int -> IO Int
-hGetBufNonBlocking h ptr count
+hGetBufNonBlocking h !ptr count
| count == 0 = return 0
| count < 0 = illegalBufferSize h "hGetBufNonBlocking" count
| otherwise =
diff --git a/libraries/base/GHC/IO/Handle/Types.hs b/libraries/base/GHC/IO/Handle/Types.hs
index c58a9fb1b0..d38962e77e 100644
--- a/libraries/base/GHC/IO/Handle/Types.hs
+++ b/libraries/base/GHC/IO/Handle/Types.hs
@@ -247,7 +247,11 @@ data BufferMode
-- ^ block-buffering should be enabled if possible.
-- The size of the buffer is @n@ items if the argument
-- is 'Just' @n@ and is otherwise implementation-dependent.
- deriving (Eq, Ord, Read, Show)
+ deriving ( Eq -- ^ @since 4.2.0.0
+ , Ord -- ^ @since 4.2.0.0
+ , Read -- ^ @since 4.2.0.0
+ , Show -- ^ @since 4.2.0.0
+ )
{-
[note Buffering Implementation]
@@ -349,7 +353,11 @@ and hence it is only possible on a seekable Handle.
-- | The representation of a newline in the external file or stream.
data Newline = LF -- ^ '\n'
| CRLF -- ^ '\r\n'
- deriving (Eq, Ord, Read, Show)
+ deriving ( Eq -- ^ @since 4.2.0.0
+ , Ord -- ^ @since 4.3.0.0
+ , Read -- ^ @since 4.3.0.0
+ , Show -- ^ @since 4.3.0.0
+ )
-- | Specifies the translation, if any, of newline characters between
-- internal Strings and the external file or stream. Haskell Strings
@@ -362,7 +370,11 @@ data NewlineMode
outputNL :: Newline
-- ^ the representation of newlines on output
}
- deriving (Eq, Ord, Read, Show)
+ deriving ( Eq -- ^ @since 4.2.0.0
+ , Ord -- ^ @since 4.3.0.0
+ , Read -- ^ @since 4.3.0.0
+ , Show -- ^ @since 4.3.0.0
+ )
-- | The native newline representation for the current platform: 'LF'
-- on Unix systems, 'CRLF' on Windows.
diff --git a/libraries/base/GHC/IO/IOMode.hs b/libraries/base/GHC/IO/IOMode.hs
index 42cc9f31b1..7eb848f50a 100644
--- a/libraries/base/GHC/IO/IOMode.hs
+++ b/libraries/base/GHC/IO/IOMode.hs
@@ -26,5 +26,11 @@ import GHC.Enum
-- | See 'System.IO.openFile'
data IOMode = ReadMode | WriteMode | AppendMode | ReadWriteMode
- deriving (Eq, Ord, Ix, Enum, Read, Show)
+ deriving ( Eq -- ^ @since 4.2.0.0
+ , Ord -- ^ @since 4.2.0.0
+ , Ix -- ^ @since 4.2.0.0
+ , Enum -- ^ @since 4.2.0.0
+ , Read -- ^ @since 4.2.0.0
+ , Show -- ^ @since 4.2.0.0
+ )
diff --git a/libraries/base/GHC/IO/Unsafe.hs b/libraries/base/GHC/IO/Unsafe.hs
index c1c07ae2df..039acfe85b 100644
--- a/libraries/base/GHC/IO/Unsafe.hs
+++ b/libraries/base/GHC/IO/Unsafe.hs
@@ -96,7 +96,8 @@ times (on a multiprocessor), and you should therefore ensure that
it gives the same results each time. It may even happen that one
of the duplicated IO actions is only run partially, and then interrupted
in the middle without an exception being raised. Therefore, functions
-like 'bracket' cannot be used safely within 'unsafeDupablePerformIO'.
+like 'Control.Exception.bracket' cannot be used safely within
+'unsafeDupablePerformIO'.
@since 4.4.0.0
-}