winio: Multiple refactorings and support changes.

17 files changed, 325 insertions, 521 deletions

diff --git a/libraries/base/Control/Concurrent.hs-boot b/libraries/base/Control/Concurrent.hs-boot
new file mode 100644
index 0000000000..213340432e
--- /dev/null
+++ b/libraries/base/Control/Concurrent.hs-boot
@@ -0,0 +1,30 @@
+{-# LANGUAGE Trustworthy #-}
+{-# LANGUAGE NoImplicitPrelude #-}
+
+-----------------------------------------------------------------------------
+-- |
+-- Module      :  Control.Concurrent
+-- Copyright   :  (c) The University of Glasgow 2018-2019
+-- License     :  BSD-style (see the file libraries/base/LICENSE)
+--
+-- Maintainer  :  libraries@haskell.org
+-- Stability   :  experimental
+-- Portability :  non-portable (concurrency)
+--
+-- A common interface to a collection of useful concurrency
+-- abstractions.
+--
+-----------------------------------------------------------------------------
+module Control.Concurrent (
+        -- * Bound Threads
+        rtsSupportsBoundThreads,
+        forkOS
+    ) where
+
+import Data.Bool
+
+import GHC.IO
+import GHC.Conc.Sync
+
+rtsSupportsBoundThreads :: Bool
+forkOS :: IO () -> IO ThreadId
diff --git a/libraries/base/GHC/Conc.hs b/libraries/base/GHC/Conc.hs
index 15397422a5..962b29a4df 100644
--- a/libraries/base/GHC/Conc.hs
+++ b/libraries/base/GHC/Conc.hs
@@ -59,7 +59,7 @@ module GHC.Conc
         , threadWaitWrite
         , threadWaitReadSTM
         , threadWaitWriteSTM
-        , closeFdWith
+        , closeWith
 
         -- * Allocation counter and limit
         , setAllocationCounter
diff --git a/libraries/base/GHC/Conc/IO.hs b/libraries/base/GHC/Conc/IO.hs
index 7b87adc7ea..4c1d8c6d23 100644
--- a/libraries/base/GHC/Conc/IO.hs
+++ b/libraries/base/GHC/Conc/IO.hs
@@ -29,6 +29,7 @@
 module GHC.Conc.IO
         ( ensureIOManagerIsRunning
         , ioManagerCapabilitiesChanged
+        , interruptIOManager
 
         -- * Waiting
         , threadDelay
@@ -37,7 +38,7 @@ module GHC.Conc.IO
         , threadWaitWrite
         , threadWaitReadSTM
         , threadWaitWriteSTM
-        , closeFdWith
+        , closeWith
 
 #if defined(mingw32_HOST_OS)
         , asyncRead
@@ -57,16 +58,18 @@ import Foreign
 import GHC.Base
 import GHC.Conc.Sync as Sync
 import GHC.Real ( fromIntegral )
-import System.Posix.Types
 
 #if defined(mingw32_HOST_OS)
 import qualified GHC.Conc.Windows as Windows
+import GHC.IO.SubSystem
 import GHC.Conc.Windows (asyncRead, asyncWrite, asyncDoProc, asyncReadBA,
                          asyncWriteBA, ConsoleEvent(..), win32ConsoleHandler,
                          toWin32ConsoleEvent)
 #else
 import qualified GHC.Event.Thread as Event
 #endif
+import GHC.IO.Types (BHandle)
+import qualified GHC.IO.Types as Types
 
 ensureIOManagerIsRunning :: IO ()
 #if !defined(mingw32_HOST_OS)
@@ -75,6 +78,17 @@ ensureIOManagerIsRunning = Event.ensureIOManagerIsRunning
 ensureIOManagerIsRunning = Windows.ensureIOManagerIsRunning
 #endif
 
+-- | Interrupts the current wait of the I/O manager if it is currently blocked.
+-- This instructs it to re-read how much it should wait and to process any
+-- pending events.
+-- @since <basever>
+interruptIOManager :: IO ()
+#if !defined(mingw32_HOST_OS)
+interruptIOManager = return ()
+#else
+interruptIOManager = Windows.interruptIOManager
+#endif
+
 ioManagerCapabilitiesChanged :: IO ()
 #if !defined(mingw32_HOST_OS)
 ioManagerCapabilitiesChanged = Event.ioManagerCapabilitiesChanged
@@ -83,50 +97,56 @@ ioManagerCapabilitiesChanged = return ()
 #endif
 
 -- | Block the current thread until data is available to read on the
--- given file descriptor (GHC only).
+-- given handle or file descriptor (GHC only).
 --
--- This will throw an 'Prelude.IOError' if the file descriptor was closed
--- while this thread was blocked.  To safely close a file descriptor
+-- This will throw an 'Prelude.IOError' if the handle or file descriptor was closed
+-- while this thread was blocked.  To safely close a handle or file descriptor
 -- that has been used with 'threadWaitRead', use 'closeFdWith'.
-threadWaitRead :: Fd -> IO ()
-threadWaitRead fd
+{-# SPECIALIZE threadWaitRead :: Types.IntPtr -> IO () #-}
+{-# SPECIALIZE threadWaitRead :: Types.Fd -> IO () #-}
+threadWaitRead :: BHandle a => a -> IO ()
+threadWaitRead bh
 #if !defined(mingw32_HOST_OS)
-  | threaded  = Event.threadWaitRead fd
+  | threaded  = Event.threadWaitRead (toFD bh)
 #endif
   | otherwise = IO $ \s ->
-        case fromIntegral fd of { I# fd# ->
-        case waitRead# fd# s of { s' -> (# s', () #)
+        case fromIntegral bh of { I# bh# ->
+        case waitRead# bh# s of { s' -> (# s', () #)
         }}
 
 -- | Block the current thread until data can be written to the
--- given file descriptor (GHC only).
+-- given handle or file descriptor (GHC only).
 --
--- This will throw an 'Prelude.IOError' if the file descriptor was closed
--- while this thread was blocked.  To safely close a file descriptor
+-- This will throw an 'Prelude.IOError' if the handle or file descriptor was closed
+-- while this thread was blocked.  To safely close a handle or file descriptor
 -- that has been used with 'threadWaitWrite', use 'closeFdWith'.
-threadWaitWrite :: Fd -> IO ()
-threadWaitWrite fd
+{-# SPECIALIZE threadWaitWrite :: Types.IntPtr -> IO () #-}
+{-# SPECIALIZE threadWaitWrite :: Types.Fd -> IO () #-}
+threadWaitWrite :: BHandle a => a -> IO ()
+threadWaitWrite bh
 #if !defined(mingw32_HOST_OS)
-  | threaded  = Event.threadWaitWrite fd
+  | threaded  = Event.threadWaitWrite (toFD bh)
 #endif
   | otherwise = IO $ \s ->
-        case fromIntegral fd of { I# fd# ->
-        case waitWrite# fd# s of { s' -> (# s', () #)
+        case fromIntegral bh of { I# bh# ->
+        case waitWrite# bh# s of { s' -> (# s', () #)
         }}
 
 -- | Returns an STM action that can be used to wait for data
--- to read from a file descriptor. The second returned value
+-- to read from a handle or file descriptor. The second returned value
 -- is an IO action that can be used to deregister interest
--- in the file descriptor.
-threadWaitReadSTM :: Fd -> IO (Sync.STM (), IO ())
-threadWaitReadSTM fd
+-- in the handle or file descriptor.
+{-# SPECIALIZE threadWaitReadSTM :: Types.IntPtr -> IO (Sync.STM (), IO ()) #-}
+{-# SPECIALIZE threadWaitReadSTM :: Types.Fd -> IO (Sync.STM (), IO ()) #-}
+threadWaitReadSTM :: BHandle a => a -> IO (Sync.STM (), IO ())
+threadWaitReadSTM bh
 #if !defined(mingw32_HOST_OS)
-  | threaded  = Event.threadWaitReadSTM fd
+  | threaded  = Event.threadWaitReadSTM (toFD bh)
 #endif
   | otherwise = do
       m <- Sync.newTVarIO False
       t <- Sync.forkIO $ do
-        threadWaitRead fd
+        threadWaitRead bh
         Sync.atomically $ Sync.writeTVar m True
       let waitAction = do b <- Sync.readTVar m
                           if b then return () else retry
@@ -134,40 +154,44 @@ threadWaitReadSTM fd
       return (waitAction, killAction)
 
 -- | Returns an STM action that can be used to wait until data
--- can be written to a file descriptor. The second returned value
+-- can be written to a handle or file descriptor. The second returned value
 -- is an IO action that can be used to deregister interest
--- in the file descriptor.
-threadWaitWriteSTM :: Fd -> IO (Sync.STM (), IO ())
-threadWaitWriteSTM fd
+-- in the handle or file descriptor.
+{-# SPECIALIZE threadWaitWriteSTM :: Types.IntPtr -> IO (Sync.STM (), IO ()) #-}
+{-# SPECIALIZE threadWaitWriteSTM :: Types.Fd -> IO (Sync.STM (), IO ()) #-}
+threadWaitWriteSTM :: BHandle a => a -> IO (Sync.STM (), IO ())
+threadWaitWriteSTM bh
 #if !defined(mingw32_HOST_OS)
-  | threaded  = Event.threadWaitWriteSTM fd
+  | threaded  = Event.threadWaitWriteSTM (toFD bh)
 #endif
   | otherwise = do
       m <- Sync.newTVarIO False
       t <- Sync.forkIO $ do
-        threadWaitWrite fd
+        threadWaitWrite bh
         Sync.atomically $ Sync.writeTVar m True
       let waitAction = do b <- Sync.readTVar m
                           if b then return () else retry
       let killAction = Sync.killThread t
       return (waitAction, killAction)
 
--- | Close a file descriptor in a concurrency-safe way (GHC only).  If
+-- | Close a handle or file descriptor in a concurrency-safe way (GHC only).  If
 -- you are using 'threadWaitRead' or 'threadWaitWrite' to perform
 -- blocking I\/O, you /must/ use this function to close file
 -- descriptors, or blocked threads may not be woken.
 --
--- Any threads that are blocked on the file descriptor via
+-- Any threads that are blocked on the handle or file descriptor via
 -- 'threadWaitRead' or 'threadWaitWrite' will be unblocked by having
 -- IO exceptions thrown.
-closeFdWith :: (Fd -> IO ()) -- ^ Low-level action that performs the real close.
-            -> Fd            -- ^ File descriptor to close.
-            -> IO ()
-closeFdWith close fd
+{-# SPECIALIZE closeWith :: (Types.IntPtr ->IO ()) -> Types.IntPtr -> IO () #-}
+{-# SPECIALIZE closeWith :: (Types.Fd ->IO ()) -> Types.Fd -> IO () #-}
+closeWith :: BHandle a => (a -> IO ()) -- ^ Low-level action that performs the real close.
+          -> a            -- ^ handle or file descriptor to close.
+          -> IO ()
+closeWith close bh
 #if !defined(mingw32_HOST_OS)
-  | threaded  = Event.closeFdWith close fd
+  | threaded  = Event.closeFdWith close (toFD bh)
 #endif
-  | otherwise = close fd
+  | otherwise = close bh
 
 -- | Suspends the current thread for a given number of microseconds
 -- (GHC only).
@@ -179,11 +203,12 @@ closeFdWith close fd
 threadDelay :: Int -> IO ()
 threadDelay time
 #if defined(mingw32_HOST_OS)
-  | threaded  = Windows.threadDelay time
+  | isWindowsNativeIO = Windows.threadDelay time
+  | threaded          = Windows.threadDelay time
 #else
-  | threaded  = Event.threadDelay time
+  | threaded          = Event.threadDelay time
 #endif
-  | otherwise = IO $ \s ->
+  | otherwise         = IO $ \s ->
         case time of { I# time# ->
         case delay# time# s of { s' -> (# s', () #)
         }}
@@ -195,10 +220,11 @@ threadDelay time
 registerDelay :: Int -> IO (TVar Bool)
 registerDelay usecs
 #if defined(mingw32_HOST_OS)
-  | threaded = Windows.registerDelay usecs
+  | isWindowsNativeIO = Windows.registerDelay usecs
+  | threaded          = Windows.registerDelay usecs
 #else
-  | threaded = Event.registerDelay usecs
+  | threaded          = Event.registerDelay usecs
 #endif
-  | otherwise = errorWithoutStackTrace "registerDelay: requires -threaded"
+  | otherwise         = errorWithoutStackTrace "registerDelay: requires -threaded"
 
 foreign import ccall unsafe "rtsSupportsBoundThreads" threaded :: Bool
diff --git a/libraries/base/GHC/Conc/Sync.hs b/libraries/base/GHC/Conc/Sync.hs
index 80287c56c4..e7ad6026da 100644
--- a/libraries/base/GHC/Conc/Sync.hs
+++ b/libraries/base/GHC/Conc/Sync.hs
@@ -33,6 +33,7 @@
 -- #not-home
 module GHC.Conc.Sync
         ( ThreadId(..)
+        , showThreadId
 
         -- * Forking and suchlike
         , forkIO
@@ -102,7 +103,7 @@ import Data.Maybe
 
 import GHC.Base
 import {-# SOURCE #-} GHC.IO.Handle ( hFlush )
-import {-# SOURCE #-} GHC.IO.Handle.FD ( stdout )
+import {-# SOURCE #-} GHC.IO.SmartHandles ( stdout )
 import GHC.Int
 import GHC.IO
 import GHC.IO.Encoding.UTF8
@@ -151,6 +152,9 @@ instance Show ThreadId where
         showString "ThreadId " .
         showsPrec d (getThreadId (id2TSO t))
 
+showThreadId :: ThreadId -> String
+showThreadId = show
+
 foreign import ccall unsafe "rts_getThreadId" getThreadId :: ThreadId# -> CInt
 
 id2TSO :: ThreadId -> ThreadId#
diff --git a/libraries/base/GHC/Conc/Sync.hs-boot b/libraries/base/GHC/Conc/Sync.hs-boot
new file mode 100644
index 0000000000..39648e597c
--- /dev/null
+++ b/libraries/base/GHC/Conc/Sync.hs-boot
@@ -0,0 +1,73 @@
+{-# LANGUAGE MagicHash, NoImplicitPrelude #-}
+{-# OPTIONS_GHC -Wno-missing-signatures #-}
+{-# OPTIONS_HADDOCK not-home #-}
+
+-----------------------------------------------------------------------------
+-- |
+-- Module      :  GHC.Conc.Sync [boot]
+-- Copyright   :  (c) The University of Glasgow, 1994-2002
+-- License     :  see libraries/base/LICENSE
+--
+-- Maintainer  :  cvs-ghc@haskell.org
+-- Stability   :  internal
+-- Portability :  non-portable (GHC extensions)
+--
+-- Basic concurrency stuff.
+--
+-----------------------------------------------------------------------------
+
+module GHC.Conc.Sync
+        ( forkIO,
+          TVar(..),
+          ThreadId(..),
+          myThreadId,
+          showThreadId,
+          ThreadStatus(..),
+          threadStatus,
+          sharedCAF
+        ) where
+
+import GHC.Base
+import GHC.Ptr
+
+forkIO :: IO () -> IO ThreadId
+
+data ThreadId = ThreadId ThreadId#
+data TVar a = TVar (TVar# RealWorld a)
+
+data BlockReason
+        = BlockedOnMVar
+              -- ^blocked on 'MVar'
+        {- possibly (see 'threadstatus' below):
+        | BlockedOnMVarRead
+              -- ^blocked on reading an empty 'MVar'
+        -}
+        | BlockedOnBlackHole
+              -- ^blocked on a computation in progress by another thread
+        | BlockedOnException
+              -- ^blocked in 'throwTo'
+        | BlockedOnSTM
+              -- ^blocked in 'retry' in an STM transaction
+        | BlockedOnForeignCall
+              -- ^currently in a foreign call
+        | BlockedOnIOCompletion
+              -- ^currently blocked on an I/O Completion port
+        | BlockedOnOther
+              -- ^blocked on some other resource.  Without @-threaded@,
+              -- I\/O and 'threadDelay' show up as 'BlockedOnOther', with @-threaded@
+              -- they show up as 'BlockedOnMVar'.
+
+data ThreadStatus
+        = ThreadRunning
+              -- ^the thread is currently runnable or running
+        | ThreadFinished
+              -- ^the thread has finished
+        | ThreadBlocked  BlockReason
+              -- ^the thread is blocked on some resource
+        | ThreadDied
+        -- ^the thread received an uncaught exception
+
+myThreadId :: IO ThreadId
+showThreadId :: ThreadId -> String
+threadStatus :: ThreadId -> IO ThreadStatus
+sharedCAF :: a -> (Ptr a -> IO (Ptr a)) -> IO a
diff --git a/libraries/base/GHC/Conc/Windows.hs b/libraries/base/GHC/Conc/Windows.hs
index 53f22d6d50..800fc57cdd 100644
--- a/libraries/base/GHC/Conc/Windows.hs
+++ b/libraries/base/GHC/Conc/Windows.hs
@@ -13,13 +13,15 @@
 -- Stability   :  internal
 -- Portability :  non-portable (GHC extensions)
 --
--- Windows I/O manager
+-- Windows I/O manager interfaces. Depending on which I/O Subsystem is used
+-- requests will be routed to different places.
 --
 -----------------------------------------------------------------------------
 
 -- #not-home
 module GHC.Conc.Windows
        ( ensureIOManagerIsRunning
+       , interruptIOManager
 
        -- * Waiting
        , threadDelay
@@ -33,19 +35,19 @@ module GHC.Conc.Windows
        , asyncReadBA
        , asyncWriteBA
 
-       , ConsoleEvent(..)
-       , win32ConsoleHandler
-       , toWin32ConsoleEvent
+       -- * Console event handler
+       , module GHC.Event.Windows.ConsoleEvent
        ) where
 
-import Data.Bits (shiftR)
+
+#include "windows_cconv.h"
+
 import GHC.Base
 import GHC.Conc.Sync
-import GHC.Enum (Enum)
-import GHC.IO (unsafePerformIO)
-import GHC.IORef
-import GHC.MVar
-import GHC.Num (Num(..))
+import qualified GHC.Conc.POSIX as POSIX
+import qualified GHC.Conc.IOCP as WINIO
+import GHC.Event.Windows.ConsoleEvent
+import GHC.IO.SubSystem ((<!>))
 import GHC.Ptr
 import GHC.Read (Read)
 import GHC.Real (div, fromIntegral)
@@ -54,16 +56,6 @@ import GHC.Word (Word32, Word64)
 import GHC.Windows
 import Unsafe.Coerce ( unsafeCoerceUnlifted )
 
-#if 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
-#endif
-
 -- ----------------------------------------------------------------------------
 -- Thread waiting
 
@@ -111,232 +103,19 @@ asyncWriteBA fd isSock len off bufB =
 -- run /earlier/ than specified.
 --
 threadDelay :: Int -> IO ()
-threadDelay time
-  | threaded  = waitForDelayEvent time
-  | otherwise = IO $ \s ->
-        case time of { I# time# ->
-        case delay# time# s of { s' -> (# s', () #)
-        }}
+threadDelay = POSIX.threadDelay <!> WINIO.threadDelay
 
 -- | Set the value of returned TVar to True after a given number of
 -- microseconds. The caveats associated with threadDelay also apply.
 --
 registerDelay :: Int -> IO (TVar Bool)
-registerDelay usecs
-  | threaded = waitForDelayEventSTM usecs
-  | otherwise = errorWithoutStackTrace "registerDelay: requires -threaded"
-
-foreign import ccall unsafe "rtsSupportsBoundThreads" threaded :: Bool
-
-waitForDelayEvent :: Int -> IO ()
-waitForDelayEvent usecs = do
-  m <- newEmptyMVar
-  target <- calculateTarget usecs
-  _ <- atomicModifyIORef'_ pendingDelays (\xs -> Delay target m : xs)
-  prodServiceThread
-  takeMVar m
-
--- Delays for use in STM
-waitForDelayEventSTM :: Int -> IO (TVar Bool)
-waitForDelayEventSTM usecs = do
-   t <- atomically $ newTVar False
-   target <- calculateTarget usecs
-   _ <- atomicModifyIORef'_ pendingDelays (\xs -> DelaySTM target t : xs)
-   prodServiceThread
-   return t
-
-calculateTarget :: Int -> IO USecs
-calculateTarget usecs = do
-    now <- getMonotonicUSec
-    return $ now + (fromIntegral usecs)
-
-data DelayReq
-  = Delay    {-# UNPACK #-} !USecs {-# UNPACK #-} !(MVar ())
-  | DelaySTM {-# UNPACK #-} !USecs {-# UNPACK #-} !(TVar Bool)
-
-{-# NOINLINE pendingDelays #-}
-pendingDelays :: IORef [DelayReq]
-pendingDelays = unsafePerformIO $ do
-   m <- newIORef []
-   sharedCAF m getOrSetGHCConcWindowsPendingDelaysStore
-
-foreign import ccall unsafe "getOrSetGHCConcWindowsPendingDelaysStore"
-    getOrSetGHCConcWindowsPendingDelaysStore :: Ptr a -> IO (Ptr a)
-
-{-# NOINLINE ioManagerThread #-}
-ioManagerThread :: MVar (Maybe ThreadId)
-ioManagerThread = unsafePerformIO $ do
-   m <- newMVar Nothing
-   sharedCAF m getOrSetGHCConcWindowsIOManagerThreadStore
-
-foreign import ccall unsafe "getOrSetGHCConcWindowsIOManagerThreadStore"
-    getOrSetGHCConcWindowsIOManagerThreadStore :: Ptr a -> IO (Ptr a)
+registerDelay = POSIX.registerDelay <!> WINIO.registerDelay
 
 ensureIOManagerIsRunning :: IO ()
-ensureIOManagerIsRunning
-  | threaded  = startIOManagerThread
-  | otherwise = return ()
-
-startIOManagerThread :: IO ()
-startIOManagerThread = do
-  modifyMVar_ ioManagerThread $ \old -> do
-    let create = do t <- forkIO ioManager; return (Just t)
-    case old of
-      Nothing -> create
-      Just t  -> do
-        s <- threadStatus t
-        case s of
-          ThreadFinished -> create
-          ThreadDied     -> create
-          _other         -> return (Just t)
-
-insertDelay :: DelayReq -> [DelayReq] -> [DelayReq]
-insertDelay d [] = [d]
-insertDelay d1 ds@(d2 : rest)
-  | delayTime d1 <= delayTime d2 = d1 : ds
-  | otherwise                    = d2 : insertDelay d1 rest
-
-delayTime :: DelayReq -> USecs
-delayTime (Delay t _) = t
-delayTime (DelaySTM t _) = t
-
-type USecs = Word64
-type NSecs = Word64
-
-foreign import ccall unsafe "getMonotonicNSec"
-  getMonotonicNSec :: IO NSecs
-
-getMonotonicUSec :: IO USecs
-getMonotonicUSec = fmap (`div` 1000) getMonotonicNSec
-
-{-# NOINLINE prodding #-}
-prodding :: IORef Bool
-prodding = unsafePerformIO $ do
-   r <- newIORef False
-   sharedCAF r getOrSetGHCConcWindowsProddingStore
-
-foreign import ccall unsafe "getOrSetGHCConcWindowsProddingStore"
-    getOrSetGHCConcWindowsProddingStore :: Ptr a -> IO (Ptr a)
-
-prodServiceThread :: IO ()
-prodServiceThread = do
-  -- NB. use atomicSwapIORef here, otherwise there are race
-  -- conditions in which prodding is left at True but the server is
-  -- blocked in select().
-  was_set <- atomicSwapIORef prodding True
-  when (not was_set) wakeupIOManager
-
--- ----------------------------------------------------------------------------
--- Windows IO manager thread
-
-ioManager :: IO ()
-ioManager = do
-  wakeup <- c_getIOManagerEvent
-  service_loop wakeup []
-
-service_loop :: HANDLE          -- read end of pipe
-             -> [DelayReq]      -- current delay requests
-             -> IO ()
-
-service_loop wakeup old_delays = do
-  -- pick up new delay requests
-  new_delays <- atomicSwapIORef pendingDelays []
-  let  delays = foldr insertDelay old_delays new_delays
-
-  now <- getMonotonicUSec
-  (delays', timeout) <- getDelay now delays
-
-  r <- c_WaitForSingleObject wakeup timeout
-  case r of
-    0xffffffff -> do throwGetLastError "service_loop"
-    0 -> do
-        r2 <- c_readIOManagerEvent
-        exit <-
-              case r2 of
-                _ | r2 == io_MANAGER_WAKEUP -> return False
-                _ | r2 == io_MANAGER_DIE    -> return True
-                0 -> return False -- spurious wakeup
-                _ -> do start_console_handler (r2 `shiftR` 1); return False
-        when (not exit) $ service_cont wakeup delays'
-
-    _other -> service_cont wakeup delays' -- probably timeout
-
-service_cont :: HANDLE -> [DelayReq] -> IO ()
-service_cont wakeup delays = do
-  _ <- atomicSwapIORef prodding False
-  service_loop wakeup delays
-
--- must agree with rts/win32/ThrIOManager.c
-io_MANAGER_WAKEUP, io_MANAGER_DIE :: Word32
-io_MANAGER_WAKEUP = 0xffffffff
-io_MANAGER_DIE    = 0xfffffffe
-
-data ConsoleEvent
- = ControlC
- | Break
- | Close
-    -- these are sent to Services only.
- | Logoff
- | Shutdown
- deriving ( Eq   -- ^ @since 4.3.0.0
-          , Ord  -- ^ @since 4.3.0.0
-          , Enum -- ^ @since 4.3.0.0
-          , Show -- ^ @since 4.3.0.0
-          , Read -- ^ @since 4.3.0.0
-          )
-
-start_console_handler :: Word32 -> IO ()
-start_console_handler r =
-  case toWin32ConsoleEvent r of
-     Just x  -> withMVar win32ConsoleHandler $ \handler -> do
-                    _ <- forkIO (handler x)
-                    return ()
-     Nothing -> return ()
-
-toWin32ConsoleEvent :: (Eq a, Num a) => a -> Maybe ConsoleEvent
-toWin32ConsoleEvent ev =
-   case ev of
-       0 {- CTRL_C_EVENT-}        -> Just ControlC
-       1 {- CTRL_BREAK_EVENT-}    -> Just Break
-       2 {- CTRL_CLOSE_EVENT-}    -> Just Close
-       5 {- CTRL_LOGOFF_EVENT-}   -> Just Logoff
-       6 {- CTRL_SHUTDOWN_EVENT-} -> Just Shutdown
-       _ -> Nothing
-
-win32ConsoleHandler :: MVar (ConsoleEvent -> IO ())
-win32ConsoleHandler = unsafePerformIO (newMVar (errorWithoutStackTrace "win32ConsoleHandler"))
-
-wakeupIOManager :: IO ()
-wakeupIOManager = c_sendIOManagerEvent io_MANAGER_WAKEUP
-
--- Walk the queue of pending delays, waking up any that have passed
--- and return the smallest delay to wait for.  The queue of pending
--- delays is kept ordered.
-getDelay :: USecs -> [DelayReq] -> IO ([DelayReq], DWORD)
-getDelay _   [] = return ([], iNFINITE)
-getDelay now all@(d : rest)
-  = case d of
-     Delay time m | now >= time -> do
-        putMVar m ()
-        getDelay now rest
-     DelaySTM time t | now >= time -> do
-        atomically $ writeTVar t True
-        getDelay now rest
-     _otherwise ->
-        -- delay is in millisecs for WaitForSingleObject
-        let micro_seconds = delayTime d - now
-            milli_seconds = (micro_seconds + 999) `div` 1000
-        in return (all, fromIntegral milli_seconds)
-
-foreign import ccall unsafe "getIOManagerEvent" -- in the RTS (ThrIOManager.c)
-  c_getIOManagerEvent :: IO HANDLE
-
-foreign import ccall unsafe "readIOManagerEvent" -- in the RTS (ThrIOManager.c)
-  c_readIOManagerEvent :: IO Word32
+ensureIOManagerIsRunning =  POSIX.ensureIOManagerIsRunning
+                        <!> WINIO.ensureIOManagerIsRunning
 
-foreign import ccall unsafe "sendIOManagerEvent" -- in the RTS (ThrIOManager.c)
-  c_sendIOManagerEvent :: Word32 -> IO ()
+interruptIOManager :: IO ()
+interruptIOManager = POSIX.interruptIOManager <!> WINIO.interruptIOManager
 
-foreign import WINDOWS_CCONV "WaitForSingleObject"
-   c_WaitForSingleObject :: HANDLE -> DWORD -> IO DWORD
 
diff --git a/libraries/base/GHC/ConsoleHandler.hs b/libraries/base/GHC/ConsoleHandler.hsc
index 8579c22739..1fc26f0563 100644
--- a/libraries/base/GHC/ConsoleHandler.hs
+++ b/libraries/base/GHC/ConsoleHandler.hsc
@@ -27,9 +27,9 @@ import GHC.Base ()  -- dummy dependency
         ( Handler(..)
         , installHandler
         , ConsoleEvent(..)
-        , flushConsole
         ) where
 
+#include <windows.h>
 {-
 #include "rts/Signals.h"
 
@@ -44,13 +44,8 @@ Note: this #include is inside a Haskell comment
 import GHC.Base
 import Foreign
 import Foreign.C
-import GHC.IO.FD
-import GHC.IO.Exception
-import GHC.IO.Handle.Types
-import GHC.IO.Handle.Internals
 import GHC.Conc
 import Control.Concurrent.MVar
-import Data.Typeable
 
 data Handler
  = Default
@@ -122,11 +117,11 @@ installHandler handler
   where
    fromConsoleEvent ev =
      case ev of
-       ControlC -> 0 {- CTRL_C_EVENT-}
-       Break    -> 1 {- CTRL_BREAK_EVENT-}
-       Close    -> 2 {- CTRL_CLOSE_EVENT-}
-       Logoff   -> 5 {- CTRL_LOGOFF_EVENT-}
-       Shutdown -> 6 {- CTRL_SHUTDOWN_EVENT-}
+       ControlC -> #{const CTRL_C_EVENT       }
+       Break    -> #{const CTRL_BREAK_EVENT   }
+       Close    -> #{const CTRL_CLOSE_EVENT   }
+       Logoff   -> #{const CTRL_LOGOFF_EVENT  }
+       Shutdown -> #{const CTRL_SHUTDOWN_EVENT}
 
    toHandler hdlr ev = do
       case toWin32ConsoleEvent ev of
@@ -144,19 +139,4 @@ foreign import ccall unsafe "RtsExternal.h rts_InstallConsoleEvent"
 foreign import ccall unsafe "RtsExternal.h rts_ConsoleHandlerDone"
   rts_ConsoleHandlerDone :: CInt -> IO ()
 
-
-flushConsole :: Handle -> IO ()
-flushConsole h =
-  wantReadableHandle_ "flushConsole" h $ \ Handle__{haDevice=dev} ->
-    case cast dev of
-      Nothing -> ioException $
-                    IOError (Just h) IllegalOperation "flushConsole"
-                        "handle is not a file descriptor" Nothing Nothing
-      Just fd -> do
-        throwErrnoIfMinus1Retry_ "flushConsole" $
-           flush_console_fd (fdFD fd)
-
-foreign import ccall unsafe "consUtils.h flush_input_console__"
-        flush_console_fd :: CInt -> IO CInt
-
 #endif /* mingw32_HOST_OS */
diff --git a/libraries/base/GHC/Event/Internal.hs b/libraries/base/GHC/Event/Internal.hs
index 5778c6f3fe..2ed8d2e66c 100644
--- a/libraries/base/GHC/Event/Internal.hs
+++ b/libraries/base/GHC/Event/Internal.hs
@@ -10,150 +10,16 @@ module GHC.Event.Internal
     , poll
     , modifyFd
     , modifyFdOnce
-    -- * Event type
-    , Event
-    , evtRead
-    , evtWrite
-    , evtClose
-    , eventIs
-    -- * Lifetimes
-    , Lifetime(..)
-    , EventLifetime
-    , eventLifetime
-    , elLifetime
-    , elEvent
-    -- * Timeout type
-    , Timeout(..)
+    , module GHC.Event.Internal.Types
     -- * Helpers
     , throwErrnoIfMinus1NoRetry
     ) where
 
-import Data.Bits ((.|.), (.&.))
-import Data.OldList (foldl', filter, intercalate, null)
 import Foreign.C.Error (eINTR, getErrno, throwErrno)
 import System.Posix.Types (Fd)
 import GHC.Base
-import GHC.Word (Word64)
 import GHC.Num (Num(..))
-import GHC.Show (Show(..))
-import Data.Semigroup.Internal (stimesMonoid)
-
--- | An I\/O event.
-newtype Event = Event Int
-    deriving Eq -- ^ @since 4.4.0.0
-
-evtNothing :: Event
-evtNothing = Event 0
-{-# INLINE evtNothing #-}
-
--- | Data is available to be read.
-evtRead :: Event
-evtRead = Event 1
-{-# INLINE evtRead #-}
-
--- | The file descriptor is ready to accept a write.
-evtWrite :: Event
-evtWrite = Event 2
-{-# INLINE evtWrite #-}
-
--- | Another thread closed the file descriptor.
-evtClose :: Event
-evtClose = Event 4
-{-# INLINE evtClose #-}
-
-eventIs :: Event -> Event -> Bool
-eventIs (Event a) (Event b) = a .&. b /= 0
-
--- | @since 4.4.0.0
-instance Show Event where
-    show e = '[' : (intercalate "," . filter (not . null) $
-                    [evtRead `so` "evtRead",
-                     evtWrite `so` "evtWrite",
-                     evtClose `so` "evtClose"]) ++ "]"
-        where ev `so` disp | e `eventIs` ev = disp
-                           | otherwise      = ""
-
--- | @since 4.10.0.0
-instance Semigroup Event where
-    (<>)    = evtCombine
-    stimes  = stimesMonoid
-
--- | @since 4.4.0.0
-instance Monoid Event where
-    mempty  = evtNothing
-    mconcat = evtConcat
-
-evtCombine :: Event -> Event -> Event
-evtCombine (Event a) (Event b) = Event (a .|. b)
-{-# INLINE evtCombine #-}
-
-evtConcat :: [Event] -> Event
-evtConcat = foldl' evtCombine evtNothing
-{-# INLINE evtConcat #-}
-
--- | The lifetime of an event registration.
---
--- @since 4.8.1.0
-data Lifetime = OneShot   -- ^ the registration will be active for only one
-                          -- event
-              | MultiShot -- ^ the registration will trigger multiple times
-              deriving ( Show -- ^ @since 4.8.1.0
-                       , Eq   -- ^ @since 4.8.1.0
-                       )
-
--- | The longer of two lifetimes.
-elSupremum :: Lifetime -> Lifetime -> Lifetime
-elSupremum OneShot OneShot = OneShot
-elSupremum _       _       = MultiShot
-{-# INLINE elSupremum #-}
-
--- | @since 4.10.0.0
-instance Semigroup Lifetime where
-    (<>) = elSupremum
-    stimes = stimesMonoid
-
--- | @mappend@ takes the longer of two lifetimes.
---
--- @since 4.8.0.0
-instance Monoid Lifetime where
-    mempty = OneShot
-
--- | A pair of an event and lifetime
---
--- Here we encode the event in the bottom three bits and the lifetime
--- in the fourth bit.
-newtype EventLifetime = EL Int
-                      deriving ( Show -- ^ @since 4.8.0.0
-                               , Eq   -- ^ @since 4.8.0.0
-                               )
-
--- | @since 4.11.0.0
-instance Semigroup EventLifetime where
-    EL a <> EL b = EL (a .|. b)
-
--- | @since 4.8.0.0
-instance Monoid EventLifetime where
-    mempty = EL 0
-
-eventLifetime :: Event -> Lifetime -> EventLifetime
-eventLifetime (Event e) l = EL (e .|. lifetimeBit l)
-  where
-    lifetimeBit OneShot   = 0
-    lifetimeBit MultiShot = 8
-{-# INLINE eventLifetime #-}
-
-elLifetime :: EventLifetime -> Lifetime
-elLifetime (EL x) = if x .&. 8 == 0 then OneShot else MultiShot
-{-# INLINE elLifetime #-}
-
-elEvent :: EventLifetime -> Event
-elEvent (EL x) = Event (x .&. 0x7)
-{-# INLINE elEvent #-}
-
--- | A type alias for timeouts, specified in nanoseconds.
-data Timeout = Timeout {-# UNPACK #-} !Word64
-             | Forever
-               deriving Show -- ^ @since 4.4.0.0
+import GHC.Event.Internal.Types
 
 -- | Event notification backend.
 data Backend = forall a. Backend {
diff --git a/libraries/base/GHC/Event/Thread.hs b/libraries/base/GHC/Event/Thread.hs
index ad922d73f2..19b6cd4117 100644
--- a/libraries/base/GHC/Event/Thread.hs
+++ b/libraries/base/GHC/Event/Thread.hs
@@ -15,7 +15,7 @@ module GHC.Event.Thread
     , registerDelay
     , blockedOnBadFD -- used by RTS
     ) where
-
+-- TODO: Use new Windows I/O manager
 import Control.Exception (finally, SomeException, toException)
 import Data.Foldable (forM_, mapM_, sequence_)
 import Data.IORef (IORef, newIORef, readIORef, writeIORef)
diff --git a/libraries/base/GHC/Event/TimerManager.hs b/libraries/base/GHC/Event/TimerManager.hs
index 946f2333bf..f23d632b21 100644
--- a/libraries/base/GHC/Event/TimerManager.hs
+++ b/libraries/base/GHC/Event/TimerManager.hs
@@ -6,7 +6,7 @@
            , TypeSynonymInstances
            , FlexibleInstances
   #-}
-
+-- TODO: use the new Windows IO manager
 module GHC.Event.TimerManager
     ( -- * Types
       TimerManager
@@ -52,6 +52,7 @@ import GHC.Show (Show(..))
 import GHC.Event.Control
 import GHC.Event.Internal (Backend, Event, evtRead, Timeout(..))
 import GHC.Event.Unique (Unique, UniqueSource, newSource, newUnique)
+import GHC.Event.TimeOut
 import System.Posix.Types (Fd)
 
 import qualified GHC.Event.Internal as I
@@ -66,13 +67,6 @@ import qualified GHC.Event.Poll   as Poll
 ------------------------------------------------------------------------
 -- Types
 
--- | A timeout registration cookie.
-newtype TimeoutKey   = TK Unique
-    deriving Eq -- ^ @since 4.7.0.0
-
--- | Callback invoked on timeout events.
-type TimeoutCallback = IO ()
-
 data State = Created
            | Running
            | Dying
@@ -81,12 +75,6 @@ data State = Created
                       , Show -- ^ @since 4.7.0.0
                       )
 
--- | A priority search queue, with timeouts as priorities.
-type TimeoutQueue = Q.PSQ TimeoutCallback
-
--- | An edit to apply to a 'TimeoutQueue'.
-type TimeoutEdit = TimeoutQueue -> TimeoutQueue
-
 -- | The event manager state.
 data TimerManager = TimerManager
     { emBackend      :: !Backend
diff --git a/libraries/base/GHC/IO/FD.hs b/libraries/base/GHC/IO/FD.hs
index 7d7c195000..837c8b9858 100644
--- a/libraries/base/GHC/IO/FD.hs
+++ b/libraries/base/GHC/IO/FD.hs
@@ -36,6 +36,7 @@ import GHC.Show
 import GHC.Enum
 
 import GHC.IO
+import GHC.IO.Types
 import GHC.IO.IOMode
 import GHC.IO.Buffer
 import GHC.IO.BufferedIO
@@ -257,7 +258,8 @@ mkFD fd iomode mb_stat is_socket is_nonblock = do
            -- On Windows we need an additional call to get a unique device id
            -- and inode, since fstat just returns 0 for both.
            (unique_dev, unique_ino) <- getUniqueFileInfo fd dev ino
-           r <- lockFile fd unique_dev unique_ino (fromBool write)
+           r <- lockFile (fromIntegral fd) unique_dev unique_ino
+                         (fromBool write)
            when (r == -1)  $
                 ioException (IOError Nothing ResourceBusy "openFile"
                                    "file is locked" Nothing Nothing)
@@ -322,20 +324,20 @@ close fd =
            throwErrnoIfMinus1Retry_ "GHC.IO.FD.close" $
 #if defined(mingw32_HOST_OS)
            if fdIsSocket fd then
-             c_closesocket (fromIntegral realFd)
+             c_closesocket (fromIntegral $ toFd realFd)
            else
 #endif
-             c_close (fromIntegral realFd)
+             c_close (fromIntegral $ toFd realFd)
 
      -- release the lock *first*, because otherwise if we're preempted
      -- after closing but before releasing, the FD may have been reused.
      -- (#7646)
      release fd
 
-     closeFdWith closer (fromIntegral (fdFD fd))
+     closeWith closer (fromIntegral (fdFD fd) :: Fd)
 
 release :: FD -> IO ()
-release fd = do _ <- unlockFile (fdFD fd)
+release fd = do _ <- unlockFile (fromIntegral $ fdFD fd)
                 return ()
 
 #if defined(mingw32_HOST_OS)
@@ -348,10 +350,10 @@ isSeekable fd = do
   t <- devType fd
   return (t == RegularFile || t == RawDevice)
 
-seek :: FD -> SeekMode -> Integer -> IO ()
-seek fd mode off = do
-  throwErrnoIfMinus1Retry_ "seek" $
-     c_lseek (fdFD fd) (fromIntegral off) seektype
+seek :: FD -> SeekMode -> Integer -> IO Integer
+seek fd mode off = fromIntegral `fmap`
+  (throwErrnoIfMinus1Retry "seek" $
+     c_lseek (fdFD fd) (fromIntegral off) seektype)
  where
     seektype :: CInt
     seektype = case mode of
@@ -688,10 +690,10 @@ throwErrnoIfMinus1RetryOnBlock loc f on_block  =
 -- Locking/unlocking
 
 foreign import ccall unsafe "lockFile"
-  lockFile :: CInt -> Word64 -> Word64 -> CInt -> IO CInt
+  lockFile :: Word64 -> Word64 -> Word64 -> CInt -> IO CInt
 
 foreign import ccall unsafe "unlockFile"
-  unlockFile :: CInt -> IO CInt
+  unlockFile :: Word64 -> IO CInt
 
 #if defined(mingw32_HOST_OS)
 foreign import ccall unsafe "get_unique_file_info"
diff --git a/libraries/base/GHC/IO/Handle/Lock/Windows.hsc b/libraries/base/GHC/IO/Handle/Lock/Windows.hsc
index 1118e523ec..f223209da6 100644
--- a/libraries/base/GHC/IO/Handle/Lock/Windows.hsc
+++ b/libraries/base/GHC/IO/Handle/Lock/Windows.hsc
@@ -13,32 +13,63 @@ module GHC.IO.Handle.Lock.Windows where
 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_cconv.h>
 #include <windows.h>
 
 import Data.Bits
 import Data.Function
+import GHC.IO.Handle.Windows (handleToHANDLE)
 import Foreign.C.Error
 import Foreign.C.Types
 import Foreign.Marshal.Alloc
 import Foreign.Marshal.Utils
 import GHC.Base
+import qualified GHC.Event.Windows as Mgr
+import GHC.Event.Windows (LPOVERLAPPED, withOverlapped)
 import GHC.IO.FD
 import GHC.IO.Handle.FD
 import GHC.IO.Handle.Types (Handle)
 import GHC.IO.Handle.Lock.Common (LockMode(..))
+import GHC.IO.Handle.Windows (handleToHANDLE)
+import GHC.IO.Handle.Lock.Common (LockMode(..), FileLockingNotSupported(..))
+import GHC.IO.SubSystem
 import GHC.Ptr
 import GHC.Windows
 
 lockImpl :: Handle -> String -> LockMode -> Bool -> IO Bool
-lockImpl h ctx mode block = do
+lockImpl = lockImplPOSIX <!> lockImplWinIO
+
+lockImplWinIO :: Handle -> String -> LockMode -> Bool -> IO Bool
+lockImplWinIO h ctx mode block = do
+  wh      <- handleToHANDLE h
+  fix $ \retry ->
+          do retcode <- Mgr.withException ctx $
+                          withOverlapped ctx wh 0 (startCB wh) completionCB
+             case () of
+              _ | retcode == #{const ERROR_OPERATION_ABORTED} -> retry
+                | retcode == #{const ERROR_SUCCESS}           -> return True
+                | retcode == #{const ERROR_LOCK_VIOLATION} && not block
+                    -> return False
+                | otherwise -> failWith ctx retcode
+    where
+      cmode = case mode of
+                SharedLock    -> 0
+                ExclusiveLock -> #{const LOCKFILE_EXCLUSIVE_LOCK}
+      flags = if block
+                 then cmode
+                 else cmode .|. #{const LOCKFILE_FAIL_IMMEDIATELY}
+
+      startCB wh lpOverlapped = do
+        ret <- c_LockFileEx wh flags 0 #{const INFINITE} #{const INFINITE}
+                            lpOverlapped
+        return $ Mgr.CbNone ret
+
+      completionCB err _dwBytes
+        | err == #{const ERROR_SUCCESS} = Mgr.ioSuccess 0
+        | otherwise                     = Mgr.ioFailed err
+
+lockImplPOSIX :: Handle -> String -> LockMode -> Bool -> IO Bool
+lockImplPOSIX 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
@@ -49,12 +80,13 @@ lockImpl h ctx mode block = do
     -- "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
+    fix $ \retry -> c_LockFileEx wh flags 0 #{const INFINITE} #{const INFINITE}
+                                 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
+        | err == #{const ERROR_OPERATION_ABORTED}           -> retry
+        | otherwise                                         -> failWith ctx err
   where
     sizeof_OVERLAPPED = #{size OVERLAPPED}
 
@@ -63,12 +95,31 @@ lockImpl h ctx mode block = do
       ExclusiveLock -> #{const LOCKFILE_EXCLUSIVE_LOCK}
 
 unlockImpl :: Handle -> IO ()
-unlockImpl h = do
+unlockImpl = unlockImplPOSIX <!> unlockImplWinIO
+
+unlockImplWinIO :: Handle -> IO ()
+unlockImplWinIO h = do
+  wh <- handleToHANDLE h
+  _ <- Mgr.withException "unlockImpl" $
+          withOverlapped "unlockImpl" wh 0 (startCB wh) completionCB
+  return ()
+    where
+      startCB wh lpOverlapped = do
+        ret <- c_UnlockFileEx wh 0 #{const INFINITE} #{const INFINITE}
+                              lpOverlapped
+        return $ Mgr.CbNone ret
+
+      completionCB err _dwBytes
+        | err == #{const ERROR_SUCCESS} = Mgr.ioSuccess 0
+        | otherwise                     = Mgr.ioFailed err
+
+unlockImplPOSIX :: Handle -> IO ()
+unlockImplPOSIX 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
+    c_UnlockFileEx wh 0 #{const INFINITE} #{const INFINITE} ovrlpd >>= \case
       True  -> return ()
       False -> getLastError >>= failWith "hUnlock"
   where
@@ -80,10 +131,11 @@ foreign import ccall unsafe "_get_osfhandle"
 
 -- 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
+  c_LockFileEx :: HANDLE -> DWORD -> DWORD -> DWORD -> DWORD -> LPOVERLAPPED
+               -> 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
+  c_UnlockFileEx :: HANDLE -> DWORD -> DWORD -> DWORD -> LPOVERLAPPED -> IO BOOL
 
 #endif
diff --git a/libraries/base/System/Timeout.hs b/libraries/base/System/Timeout.hs
index df2c0f055a..1c41dc2ca2 100644
--- a/libraries/base/System/Timeout.hs
+++ b/libraries/base/System/Timeout.hs
@@ -15,7 +15,7 @@
 -- Attach a timeout event to arbitrary 'IO' computations.
 --
 -------------------------------------------------------------------------------
-
+-- TODO: Inspect is still suitable.
 module System.Timeout ( Timeout, timeout ) where
 
 #if !defined(mingw32_HOST_OS)
diff --git a/libraries/base/base.cabal b/libraries/base/base.cabal
index 1d4178a2bf..5342e86616 100644
--- a/libraries/base/base.cabal
+++ b/libraries/base/base.cabal
@@ -37,6 +37,7 @@ extra-source-files:
     include/ieee-flpt.h
     include/md5.h
     include/fs.h
+    include/winio_structs.h
     install-sh
 
 source-repository head
@@ -200,6 +201,7 @@ Library
         GHC.Enum
         GHC.Environment
         GHC.Err
+        GHC.Event.TimeOut
         GHC.Exception
         GHC.Exception.Type
         GHC.ExecutionStack
@@ -387,8 +389,25 @@ Library
             GHC.IO.Encoding.CodePage.API
             GHC.IO.Encoding.CodePage.Table
             GHC.Conc.Windows
+            GHC.Conc.IOCP
+            GHC.Conc.POSIX
+            GHC.Conc.POSIX.Const
             GHC.Windows
+            GHC.Event.Windows
+            GHC.Event.Windows.Clock
+            GHC.Event.Windows.ConsoleEvent
+            GHC.Event.Windows.FFI
+            GHC.Event.Windows.ManagedThreadPool
+            GHC.Event.Windows.Thread
+            GHC.IO.Windows.Handle
+            GHC.IO.Windows.Encoding
+            GHC.IO.Windows.Paths
         other-modules:
+            GHC.Event.Arr
+            GHC.Event.Array
+            GHC.Event.IntTable
+            GHC.Event.PSQ
+            GHC.Event.Unique
             System.CPUTime.Windows
     else
         exposed-modules:
diff --git a/libraries/base/cbits/Win32Utils.c b/libraries/base/cbits/Win32Utils.c
index 886c277b5c..7b9c9cd244 100644
--- a/libraries/base/cbits/Win32Utils.c
+++ b/libraries/base/cbits/Win32Utils.c
@@ -5,14 +5,17 @@
    ------------------------------------------------------------------------- */
 
 #if defined(_WIN32)
+/* Use Mingw's C99 print functions.  */
+#define __USE_MINGW_ANSI_STDIO 1
+/* Using Secure APIs */
+#define MINGW_HAS_SECURE_API 1
 
 #include "HsBase.h"
 #include <stdbool.h>
 #include <stdint.h>
-/* Using Secure APIs */
-#define MINGW_HAS_SECURE_API 1
 #include <wchar.h>
 #include <windows.h>
+#include <io.h>
 
 /* This is the error table that defines the mapping between OS error
    codes and errno values */
@@ -131,9 +134,8 @@ LPWSTR base_getErrorMessage(DWORD err)
     return what;
 }
 
-int get_unique_file_info(int fd, HsWord64 *dev, HsWord64 *ino)
+int get_unique_file_info_hwnd(HANDLE h, HsWord64 *dev, HsWord64 *ino)
 {
-    HANDLE h = (HANDLE)_get_osfhandle(fd);
     BY_HANDLE_FILE_INFORMATION info;
 
     if (GetFileInformationByHandle(h, &info))
@@ -148,6 +150,12 @@ int get_unique_file_info(int fd, HsWord64 *dev, HsWord64 *ino)
     return -1;
 }
 
+int get_unique_file_info(int fd, HsWord64 *dev, HsWord64 *ino)
+{
+    HANDLE h = (HANDLE)_get_osfhandle(fd);
+    return get_unique_file_info_hwnd (h, dev, ino);
+}
+
 BOOL file_exists(LPCTSTR path)
 {
     DWORD r = GetFileAttributes(path);
diff --git a/libraries/base/cbits/consUtils.c b/libraries/base/cbits/consUtils.c
index 0c9202d0c9..5ca0c1b608 100644
--- a/libraries/base/cbits/consUtils.c
+++ b/libraries/base/cbits/consUtils.c
@@ -62,9 +62,9 @@ set_console_echo__(int fd, int on)
     HANDLE h;
     DWORD  st;
     DWORD flgs = ENABLE_LINE_INPUT | ENABLE_ECHO_INPUT;
-    
+
     if ( (h = (HANDLE)_get_osfhandle(fd)) != INVALID_HANDLE_VALUE ) {
-	if ( GetConsoleMode(h,&st) && 
+	if ( GetConsoleMode(h,&st) &&
 	     SetConsoleMode(h,( on ? (st | flgs) : (st & ~ENABLE_ECHO_INPUT))) ) {
 	    return 0;
 	}
@@ -77,7 +77,7 @@ get_console_echo__(int fd)
 {
     HANDLE h;
     DWORD  st;
-    
+
     if ( (h = (HANDLE)_get_osfhandle(fd)) != INVALID_HANDLE_VALUE ) {
 	if ( GetConsoleMode(h,&st) ) {
 	    return (st & ENABLE_ECHO_INPUT ? 1 : 0);
@@ -86,26 +86,4 @@ get_console_echo__(int fd)
     return -1;
 }
 
-int
-flush_input_console__(int fd)
-{
-    HANDLE h = (HANDLE)_get_osfhandle(fd);
-    
-    if ( h != INVALID_HANDLE_VALUE ) {
-	/* If the 'fd' isn't connected to a console; treat the flush
-	 * operation as a NOP.
-	 */
-	DWORD unused;
-	if ( !GetConsoleMode(h,&unused) &&
-	     GetLastError() == ERROR_INVALID_HANDLE ) {
-	    return 0;
-	}
-	if ( FlushConsoleInputBuffer(h) ) {
-	    return 0;
-	}
-    }
-    /* ToDo: translate GetLastError() into something errno-friendly */
-    return -1;
-}
-
 #endif /* defined(_WIN32) || ... */
diff --git a/libraries/base/include/consUtils.h b/libraries/base/include/consUtils.h
index 3536593f3c..db5fc8eaef 100644
--- a/libraries/base/include/consUtils.h
+++ b/libraries/base/include/consUtils.h
@@ -1,4 +1,4 @@
-/* 
+/*
  * (c) The University of Glasgow, 2000-2002
  *
  * Win32 Console API helpers.
@@ -9,4 +9,3 @@ extern int is_console__(int fd);
 extern int set_console_buffering__(int fd, int cooked);
 extern int set_console_echo__(int fd, int on);
 extern int get_console_echo__(int fd);
-extern int flush_input_console__ (int fd);