base: Split up file locking implementation

This makes the CPP significantly easier to follow.

8 files changed, 352 insertions, 284 deletions

diff --git a/libraries/base/GHC/IO/Handle/Lock.hs b/libraries/base/GHC/IO/Handle/Lock.hs
new file mode 100644
index 0000000000..09df4a24ae
--- /dev/null
+++ b/libraries/base/GHC/IO/Handle/Lock.hs
@@ -0,0 +1,68 @@
+{-# LANGUAGE CPP #-}
+{-# LANGUAGE InterruptibleFFI #-}
+{-# LANGUAGE LambdaCase #-}
+{-# LANGUAGE MultiWayIf #-}
+{-# LANGUAGE NoImplicitPrelude #-}
+
+module GHC.IO.Handle.Lock (
+    FileLockingNotSupported(..)
+  , LockMode(..)
+  , hLock
+  , hTryLock
+  , hUnlock
+  ) where
+
+
+#include "HsBaseConfig.h"
+
+import Data.Functor (void)
+import GHC.Base
+import GHC.IO.Handle.Lock.Common (LockMode(..), FileLockingNotSupported(..))
+import GHC.IO.Handle.Types (Handle)
+
+#if defined(mingw32_HOST_OS)
+import GHC.IO.Handle.Lock.Windows
+#elif HAVE_OFD_LOCKING
+import GHC.IO.Handle.Lock.LinuxOFD
+#elif HAVE_FLOCK
+import GHC.IO.Handle.Lock.Flock
+#else
+import GHC.IO.Handle.Lock.NoOp
+#endif
+
+-- | If a 'Handle' references a file descriptor, attempt to lock contents of the
+-- underlying file in appropriate mode. If the file is already locked in
+-- incompatible mode, this function blocks until the lock is established. The
+-- lock is automatically released upon closing a 'Handle'.
+--
+-- Things to be aware of:
+--
+-- 1) This function may block inside a C call. If it does, in order to be able
+-- to interrupt it with asynchronous exceptions and/or for other threads to
+-- continue working, you MUST use threaded version of the runtime system.
+--
+-- 2) The implementation uses 'LockFileEx' on Windows and 'flock' otherwise,
+-- hence all of their caveats also apply here.
+--
+-- 3) On non-Windows plaftorms that don't support 'flock' (e.g. Solaris) this
+-- function throws 'FileLockingNotImplemented'. We deliberately choose to not
+-- provide fcntl based locking instead because of its broken semantics.
+--
+-- @since 4.10.0.0
+hLock :: Handle -> LockMode -> IO ()
+hLock h mode = void $ lockImpl h "hLock" mode True
+
+-- | Non-blocking version of 'hLock'.
+--
+-- @since 4.10.0.0
+hTryLock :: Handle -> LockMode -> IO Bool
+hTryLock h mode = lockImpl h "hTryLock" mode False
+
+-- | Release a lock taken with 'hLock' or 'hTryLock'.
+--
+-- @since 4.11.0.0
+hUnlock :: Handle -> IO ()
+hUnlock = unlockImpl
+
+----------------------------------------
+
diff --git a/libraries/base/GHC/IO/Handle/Lock.hsc b/libraries/base/GHC/IO/Handle/Lock.hsc
deleted file mode 100644
index d75fbcf5a6..0000000000
--- a/libraries/base/GHC/IO/Handle/Lock.hsc
+++ /dev/null
@@ -1,284 +0,0 @@
-{-# LANGUAGE CPP #-}
-{-# LANGUAGE InterruptibleFFI #-}
-{-# LANGUAGE LambdaCase #-}
-{-# LANGUAGE MultiWayIf #-}
-{-# LANGUAGE NoImplicitPrelude #-}
-module GHC.IO.Handle.Lock (
-    FileLockingNotSupported(..)
-  , LockMode(..)
-  , hLock
-  , hTryLock
-  , hUnlock
-  ) where
-
-#include "HsBaseConfig.h"
-
-#if HAVE_OFD_LOCKING
-
-#include <sys/unistd.h>
-#include <sys/fcntl.h>
-
-import Data.Function
-import Foreign.C.Error
-import Foreign.C.Types
-import Foreign.Marshal.Utils
-import Foreign.Storable
-import GHC.Ptr
-import GHC.IO.Exception
-import GHC.IO.FD
-import GHC.IO.Handle.FD
-import System.Posix.Types (COff, CPid)
-
-#elif HAVE_FLOCK
-
-#include <sys/file.h>
-
-import Data.Bits
-import Data.Function
-import Foreign.C.Error
-import Foreign.C.Types
-import GHC.IO.Exception
-import GHC.IO.FD
-import GHC.IO.Handle.FD
-
-#elif defined(mingw32_HOST_OS)
-
-#if defined(i386_HOST_ARCH)
-## define WINDOWS_CCONV stdcall
-#elif defined(x86_64_HOST_ARCH)
-## define WINDOWS_CCONV ccall
-#else
-# error Unknown mingw32 arch
-#endif
-
-#include <windows.h>
-
-import Data.Bits
-import Data.Function
-import Foreign.C.Error
-import Foreign.C.Types
-import Foreign.Marshal.Alloc
-import Foreign.Marshal.Utils
-import GHC.IO.FD
-import GHC.IO.Handle.FD
-import GHC.Ptr
-import GHC.Windows
-
-#else
-
-import GHC.IO (throwIO)
-
-#endif
-
-import Data.Functor
-import GHC.Base
-import GHC.Exception
-import GHC.IO.Handle.Types
-import GHC.Show
-
--- | Exception thrown by 'hLock' on non-Windows platforms that don't support
--- 'flock'.
-data FileLockingNotSupported = FileLockingNotSupported
-  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.
-data LockMode = SharedLock | ExclusiveLock
-
--- | If a 'Handle' references a file descriptor, attempt to lock contents of the
--- underlying file in appropriate mode. If the file is already locked in
--- incompatible mode, this function blocks until the lock is established. The
--- lock is automatically released upon closing a 'Handle'.
---
--- Things to be aware of:
---
--- 1) This function may block inside a C call. If it does, in order to be able
--- to interrupt it with asynchronous exceptions and/or for other threads to
--- continue working, you MUST use threaded version of the runtime system.
---
--- 2) The implementation uses 'LockFileEx' on Windows and 'flock' otherwise,
--- hence all of their caveats also apply here.
---
--- 3) On non-Windows plaftorms that don't support 'flock' (e.g. Solaris) this
--- function throws 'FileLockingNotImplemented'. We deliberately choose to not
--- provide fcntl based locking instead because of its broken semantics.
---
--- @since 4.10.0.0
-hLock :: Handle -> LockMode -> IO ()
-hLock h mode = void $ lockImpl h "hLock" mode True
-
--- | Non-blocking version of 'hLock'.
---
--- @since 4.10.0.0
-hTryLock :: Handle -> LockMode -> IO Bool
-hTryLock h mode = lockImpl h "hTryLock" mode False
-
--- | Release a lock taken with 'hLock' or 'hTryLock'.
---
--- @since 4.11.0.0
-hUnlock :: Handle -> IO ()
-hUnlock = unlockImpl
-
-----------------------------------------
-
-#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 FLock -> 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 struct flock}
-    alignment _ = #{alignment struct flock}
-    poke ptr x = do
-        fillBytes ptr 0 (sizeOf x)
-        #{poke struct flock, l_type}   ptr (l_type x)
-        #{poke struct flock, l_whence} ptr (l_whence x)
-        #{poke struct flock, l_start}  ptr (l_start x)
-        #{poke struct flock, l_len}    ptr (l_len x)
-        #{poke struct flock, l_pid}    ptr (l_pid x)
-    peek ptr = do
-        FLock <$> #{peek struct flock, l_type}   ptr
-              <*> #{peek struct flock, l_whence} ptr
-              <*> #{peek struct flock, l_start}  ptr
-              <*> #{peek struct flock, l_len}    ptr
-              <*> #{peek struct 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 <- c_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
-                  , l_pid = 0
-                  }
-    mode'
-      | block     = #{const F_OFD_SETLKW}
-      | otherwise = #{const F_OFD_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
-                    , l_pid = 0
-                    }
-  throwErrnoIfMinus1_ "hUnlock"
-      $ with flock $ c_fcntl fd #{const F_OFD_SETLK}
-
-#elif HAVE_FLOCK
-
-lockImpl :: Handle -> String -> LockMode -> Bool -> IO Bool
-lockImpl h ctx mode block = do
-  FD{fdFD = fd} <- handleToFd h
-  let flags = cmode .|. (if block then 0 else #{const LOCK_NB})
-  fix $ \retry -> c_flock fd flags >>= \case
-    0 -> return True
-    _ -> getErrno >>= \errno -> if
-      | not block
-      , errno == eAGAIN || errno == eACCES -> return False
-      | errno == eINTR -> retry
-      | otherwise -> ioException $ errnoToIOError ctx errno (Just h) Nothing
-  where
-    cmode = case mode of
-      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
-
-#elif defined(mingw32_HOST_OS)
-
-lockImpl :: Handle -> String -> LockMode -> Bool -> IO Bool
-lockImpl h ctx mode block = do
-  FD{fdFD = fd} <- handleToFd h
-  wh <- throwErrnoIf (== iNVALID_HANDLE_VALUE) ctx $ c_get_osfhandle fd
-  allocaBytes sizeof_OVERLAPPED $ \ovrlpd -> do
-    fillBytes ovrlpd 0 sizeof_OVERLAPPED
-    let flags = cmode .|. (if block then 0 else #{const LOCKFILE_FAIL_IMMEDIATELY})
-    -- We want to lock the whole file without looking up its size to be
-    -- consistent with what flock does. According to documentation of LockFileEx
-    -- "locking a region that goes beyond the current end-of-file position is
-    -- not an error", hence we pass maximum value as the number of bytes to
-    -- lock.
-    fix $ \retry -> c_LockFileEx wh flags 0 0xffffffff 0xffffffff ovrlpd >>= \case
-      True  -> return True
-      False -> getLastError >>= \err -> if
-        | not block && err == #{const ERROR_LOCK_VIOLATION} -> return False
-        | err == #{const ERROR_OPERATION_ABORTED} -> retry
-        | otherwise -> failWith ctx err
-  where
-    sizeof_OVERLAPPED = #{size OVERLAPPED}
-
-    cmode = case mode of
-      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
-
--- https://msdn.microsoft.com/en-us/library/windows/desktop/aa365203.aspx
-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/Lock/Common.hs b/libraries/base/GHC/IO/Handle/Lock/Common.hs
new file mode 100644
index 0000000000..b85e0916ab
--- /dev/null
+++ b/libraries/base/GHC/IO/Handle/Lock/Common.hs
@@ -0,0 +1,21 @@
+{-# LANGUAGE NoImplicitPrelude #-}
+
+-- | Things common to all file locking implementations.
+module GHC.IO.Handle.Lock.Common
+  ( FileLockingNotSupported(..)
+  , LockMode(..)
+  ) where
+
+import GHC.Exception
+import GHC.Show
+
+-- | Exception thrown by 'hLock' on non-Windows platforms that don't support
+-- 'flock'.
+data FileLockingNotSupported = FileLockingNotSupported
+  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.
+data LockMode = SharedLock | ExclusiveLock
diff --git a/libraries/base/GHC/IO/Handle/Lock/Flock.hsc b/libraries/base/GHC/IO/Handle/Lock/Flock.hsc
new file mode 100644
index 0000000000..c7e6704ebf
--- /dev/null
+++ b/libraries/base/GHC/IO/Handle/Lock/Flock.hsc
@@ -0,0 +1,53 @@
+{-# LANGUAGE CPP #-}
+{-# LANGUAGE InterruptibleFFI #-}
+{-# LANGUAGE LambdaCase #-}
+{-# LANGUAGE MultiWayIf #-}
+{-# LANGUAGE NoImplicitPrelude #-}
+
+-- | File locking via POSIX @flock@.
+module GHC.IO.Handle.Lock.Flock where
+
+#include "HsBaseConfig.h"
+
+#if !HAVE_FLOCK
+import GHC.Base () -- Make implicit dependency known to build system
+#else
+
+#include <sys/file.h>
+
+import Data.Bits
+import Data.Function
+import Foreign.C.Error
+import Foreign.C.Types
+import GHC.Base
+import GHC.IO.Exception
+import GHC.IO.FD
+import GHC.IO.Handle.FD
+import GHC.IO.Handle.Lock.Common
+import GHC.IO.Handle.Types (Handle)
+
+lockImpl :: Handle -> String -> LockMode -> Bool -> IO Bool
+lockImpl h ctx mode block = do
+  FD{fdFD = fd} <- handleToFd h
+  let flags = cmode .|. (if block then 0 else #{const LOCK_NB})
+  fix $ \retry -> c_flock fd flags >>= \case
+    0 -> return True
+    _ -> getErrno >>= \errno -> if
+      | not block
+      , errno == eAGAIN || errno == eACCES -> return False
+      | errno == eINTR -> retry
+      | otherwise -> ioException $ errnoToIOError ctx errno (Just h) Nothing
+  where
+    cmode = case mode of
+      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
+
+#endif
diff --git a/libraries/base/GHC/IO/Handle/Lock/LinuxOFD.hsc b/libraries/base/GHC/IO/Handle/Lock/LinuxOFD.hsc
new file mode 100644
index 0000000000..1046fa9351
--- /dev/null
+++ b/libraries/base/GHC/IO/Handle/Lock/LinuxOFD.hsc
@@ -0,0 +1,103 @@
+{-# LANGUAGE CPP #-}
+{-# LANGUAGE InterruptibleFFI #-}
+{-# LANGUAGE MultiWayIf #-}
+{-# LANGUAGE NoImplicitPrelude #-}
+
+-- | File locking via the Linux open-fd locking mechanism.
+module GHC.IO.Handle.Lock.LinuxOFD where
+
+#include "HsBaseConfig.h"
+
+#if !HAVE_OFD_LOCKING
+import GHC.Base () -- Make implicit dependency known to build system
+#else
+
+#include <sys/unistd.h>
+#include <sys/fcntl.h>
+
+import Data.Function
+import Data.Functor
+import Foreign.C.Error
+import Foreign.C.Types
+import Foreign.Marshal.Utils
+import Foreign.Storable
+import GHC.Base
+import GHC.IO.Exception
+import GHC.IO.FD
+import GHC.IO.Handle.FD
+import GHC.IO.Handle.Lock.Common
+import GHC.IO.Handle.Types (Handle)
+import GHC.Ptr
+import System.Posix.Types (COff, CPid)
+
+-- 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 FLock -> 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 struct flock}
+    alignment _ = #{alignment struct flock}
+    poke ptr x = do
+        fillBytes ptr 0 (sizeOf x)
+        #{poke struct flock, l_type}   ptr (l_type x)
+        #{poke struct flock, l_whence} ptr (l_whence x)
+        #{poke struct flock, l_start}  ptr (l_start x)
+        #{poke struct flock, l_len}    ptr (l_len x)
+        #{poke struct flock, l_pid}    ptr (l_pid x)
+    peek ptr = do
+        FLock <$> #{peek struct flock, l_type}   ptr
+              <*> #{peek struct flock, l_whence} ptr
+              <*> #{peek struct flock, l_start}  ptr
+              <*> #{peek struct flock, l_len}    ptr
+              <*> #{peek struct 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 <- c_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
+                  , l_pid = 0
+                  }
+    mode'
+      | block     = #{const F_OFD_SETLKW}
+      | otherwise = #{const F_OFD_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
+                    , l_pid = 0
+                    }
+  throwErrnoIfMinus1_ "hUnlock"
+      $ with flock $ c_fcntl fd #{const F_OFD_SETLK}
+
+#endif
diff --git a/libraries/base/GHC/IO/Handle/Lock/NoOp.hs b/libraries/base/GHC/IO/Handle/Lock/NoOp.hs
new file mode 100644
index 0000000000..b910c6811a
--- /dev/null
+++ b/libraries/base/GHC/IO/Handle/Lock/NoOp.hs
@@ -0,0 +1,16 @@
+{-# LANGUAGE NoImplicitPrelude #-}
+
+module GHC.IO.Handle.Lock.NoOp where
+
+import GHC.Base
+import GHC.IO (throwIO)
+import GHC.IO.Handle.Lock.Common
+import GHC.IO.Handle.Types (Handle)
+
+-- | No-op implementation.
+lockImpl :: Handle -> String -> LockMode -> Bool -> IO Bool
+lockImpl _ _ _ _ = throwIO FileLockingNotSupported
+
+-- | No-op implementation.
+unlockImpl :: Handle -> IO ()
+unlockImpl _ = throwIO FileLockingNotSupported
diff --git a/libraries/base/GHC/IO/Handle/Lock/Windows.hsc b/libraries/base/GHC/IO/Handle/Lock/Windows.hsc
new file mode 100644
index 0000000000..45c060f901
--- /dev/null
+++ b/libraries/base/GHC/IO/Handle/Lock/Windows.hsc
@@ -0,0 +1,86 @@
+{-# LANGUAGE CPP #-}
+{-# LANGUAGE InterruptibleFFI #-}
+{-# LANGUAGE LambdaCase #-}
+{-# LANGUAGE MultiWayIf #-}
+{-# LANGUAGE NoImplicitPrelude #-}
+
+-- | File locking for Windows.
+module GHC.IO.Handle.Lock.Windows where
+
+#include "HsBaseConfig.h"
+
+#if !defined(mingw32_HOST_OS)
+import GHC.Base () -- Make implicit dependency known to build system
+#else
+
+#if defined(i386_HOST_ARCH)
+## define WINDOWS_CCONV stdcall
+#elif defined(x86_64_HOST_ARCH)
+## define WINDOWS_CCONV ccall
+#else
+# error Unknown mingw32 arch
+#endif
+
+#include <windows.h>
+
+import Data.Bits
+import Data.Function
+import Foreign.C.Error
+import Foreign.C.Types
+import Foreign.Marshal.Alloc
+import Foreign.Marshal.Utils
+import GHC.IO.FD
+import GHC.IO.Handle.FD
+import GHC.Ptr
+import GHC.Windows
+
+lockImpl :: Handle -> String -> LockMode -> Bool -> IO Bool
+lockImpl h ctx mode block = do
+  FD{fdFD = fd} <- handleToFd h
+  wh <- throwErrnoIf (== iNVALID_HANDLE_VALUE) ctx $ c_get_osfhandle fd
+  allocaBytes sizeof_OVERLAPPED $ \ovrlpd -> do
+    fillBytes ovrlpd 0 sizeof_OVERLAPPED
+    let flags = cmode .|. (if block then 0 else #{const LOCKFILE_FAIL_IMMEDIATELY})
+    -- We want to lock the whole file without looking up its size to be
+    -- consistent with what flock does. According to documentation of LockFileEx
+    -- "locking a region that goes beyond the current end-of-file position is
+    -- not an error", hence we pass maximum value as the number of bytes to
+    -- lock.
+    fix $ \retry -> c_LockFileEx wh flags 0 0xffffffff 0xffffffff ovrlpd >>= \case
+      True  -> return True
+      False -> getLastError >>= \err -> if
+        | not block && err == #{const ERROR_LOCK_VIOLATION} -> return False
+        | err == #{const ERROR_OPERATION_ABORTED} -> retry
+        | otherwise -> failWith ctx err
+  where
+    sizeof_OVERLAPPED = #{size OVERLAPPED}
+
+    cmode = case mode of
+      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
+
+-- https://msdn.microsoft.com/en-us/library/windows/desktop/aa365203.aspx
+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
+
+#endif
diff --git a/libraries/base/base.cabal b/libraries/base/base.cabal
index 8819757f20..b978e3fdbf 100644
--- a/libraries/base/base.cabal
+++ b/libraries/base/base.cabal
@@ -328,6 +328,11 @@ Library
         Data.Semigroup.Internal
         Data.Typeable.Internal
         Foreign.ForeignPtr.Imp
+        GHC.IO.Handle.Lock.Common
+        GHC.IO.Handle.Lock.Flock
+        GHC.IO.Handle.Lock.LinuxOFD
+        GHC.IO.Handle.Lock.NoOp
+        GHC.IO.Handle.Lock.Windows
         GHC.StaticPtr.Internal
         System.Environment.ExecutablePath
         System.CPUTime.Utils