update to current master againwip/T13904

4 files changed, 137 insertions, 21 deletions

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.