diff options
34 files changed, 476 insertions, 1005 deletions
diff --git a/includes/rts/FileLock.h b/includes/rts/FileLock.h index 978ccf86b6..84f1f63881 100644 --- a/includes/rts/FileLock.h +++ b/includes/rts/FileLock.h @@ -15,5 +15,7 @@ #include "Stg.h" -int lockFile(int fd, StgWord64 dev, StgWord64 ino, int for_writing); -int unlockFile(int fd); +/* No valid FD would be negative, so use a word instead of int so the value + is compatible with a Windows handle. */ +int lockFile(StgWord id, StgWord64 dev, StgWord64 ino, int for_writing); +int unlockFile(StgWord id); diff --git a/includes/rts/IOManager.h b/includes/rts/IOManager.h index 603cb3f578..4c392e2058 100644 --- a/includes/rts/IOManager.h +++ b/includes/rts/IOManager.h @@ -15,6 +15,11 @@ #if defined(mingw32_HOST_OS) +#define IO_MANAGER_WAKEUP 0xffffffff +#define IO_MANAGER_DIE 0xfffffffe +/* spurious wakeups are returned as zero. */ +/* console events are ((event<<1) | 1). */ + int rts_InstallConsoleEvent ( int action, StgStablePtr *handler ); void rts_ConsoleHandlerDone ( int ev ); extern StgInt console_handler; @@ -31,13 +36,15 @@ void setIOManagerWakeupFd (int fd); #endif -// -// Communicating with the IO manager thread (see GHC.Conc). -// Posix implementation in posix/Signals.c -// Win32 implementation in win32/ThrIOManager.c -// +/* + * Communicating with the IO manager thread (see GHC.Conc). + * Posix implementation in posix/Signals.c + * Win32 implementation in win32/ThrIOManager.c, Windows's WINIO has the same + * interfaces for Threaded and Non-threaded I/O, so these methods are always + * available for WINIO. +*/ void ioManagerWakeup (void); -#if defined(THREADED_RTS) +#if defined(THREADED_RTS) || defined(mingw32_HOST_OS) void ioManagerDie (void); void ioManagerStart (void); #endif 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); diff --git a/rts/FileLock.c b/rts/FileLock.c index 351d2a58f7..34f4046b38 100644 --- a/rts/FileLock.c +++ b/rts/FileLock.c @@ -25,10 +25,10 @@ typedef struct { // Two hash tables. The first maps objects (device/inode pairs) to // Lock objects containing the number of active readers or writers. The -// second maps file descriptors to lock objects, so that we can unlock -// by FD without needing to fstat() again. +// second maps file descriptors or file handles to lock objects, so that we can +// unlock by FD or HANDLE without needing to fstat() again. static HashTable *obj_hash; -static HashTable *fd_hash; +static HashTable *key_hash; #if defined(THREADED_RTS) static Mutex file_lock_mutex; @@ -53,7 +53,7 @@ void initFileLocking(void) { obj_hash = allocHashTable(); - fd_hash = allocHashTable(); /* ordinary word-based table */ + key_hash = allocHashTable(); /* ordinary word-based table */ #if defined(THREADED_RTS) initMutex(&file_lock_mutex); #endif @@ -69,14 +69,14 @@ void freeFileLocking(void) { freeHashTable(obj_hash, freeLock); - freeHashTable(fd_hash, NULL); + freeHashTable(key_hash, NULL); #if defined(THREADED_RTS) closeMutex(&file_lock_mutex); #endif } int -lockFile(int fd, StgWord64 dev, StgWord64 ino, int for_writing) +lockFile(StgWord id, StgWord64 dev, StgWord64 ino, int for_writing) { Lock key, *lock; @@ -94,7 +94,7 @@ lockFile(int fd, StgWord64 dev, StgWord64 ino, int for_writing) lock->inode = ino; lock->readers = for_writing ? -1 : 1; insertHashTable_(obj_hash, (StgWord)lock, (void *)lock, hashLock); - insertHashTable(fd_hash, fd, lock); + insertHashTable(key_hash, id, lock); RELEASE_LOCK(&file_lock_mutex); return 0; } @@ -105,7 +105,7 @@ lockFile(int fd, StgWord64 dev, StgWord64 ino, int for_writing) RELEASE_LOCK(&file_lock_mutex); return -1; } - insertHashTable(fd_hash, fd, lock); + insertHashTable(key_hash, id, lock); lock->readers++; RELEASE_LOCK(&file_lock_mutex); return 0; @@ -113,15 +113,15 @@ lockFile(int fd, StgWord64 dev, StgWord64 ino, int for_writing) } int -unlockFile(int fd) +unlockFile(StgWord id) { Lock *lock; ACQUIRE_LOCK(&file_lock_mutex); - lock = lookupHashTable(fd_hash, fd); + lock = lookupHashTable(key_hash, id); if (lock == NULL) { - // errorBelch("unlockFile: fd %d not found", fd); + // errorBelch("unlockFile: key %d not found", key); // This is normal: we didn't know when calling unlockFile // whether this FD referred to a locked file or not. RELEASE_LOCK(&file_lock_mutex); @@ -138,7 +138,7 @@ unlockFile(int fd) removeHashTable_(obj_hash, (StgWord)lock, NULL, hashLock, cmpLocks); stgFree(lock); } - removeHashTable(fd_hash, fd, NULL); + removeHashTable(key_hash, id, NULL); RELEASE_LOCK(&file_lock_mutex); return 0; diff --git a/rts/Prelude.h b/rts/Prelude.h index c6971677af..0527218da0 100644 --- a/rts/Prelude.h +++ b/rts/Prelude.h @@ -52,8 +52,12 @@ PRELUDE_CLOSURE(base_GHCziExceptionziType_overflowException_closure); PRELUDE_CLOSURE(base_GHCziConcziSync_runSparks_closure); PRELUDE_CLOSURE(base_GHCziConcziIO_ensureIOManagerIsRunning_closure); +PRELUDE_CLOSURE(base_GHCziConcziIO_interruptIOManager_closure); PRELUDE_CLOSURE(base_GHCziConcziIO_ioManagerCapabilitiesChanged_closure); PRELUDE_CLOSURE(base_GHCziConcziSignal_runHandlersPtr_closure); +#if defined(mingw32_HOST_OS) +PRELUDE_CLOSURE(base_GHCziEventziWindows_processRemoteCompletion_closure); +#endif PRELUDE_CLOSURE(base_GHCziTopHandler_flushStdHandles_closure); PRELUDE_CLOSURE(base_GHCziTopHandler_runMainIO_closure); @@ -85,8 +89,12 @@ PRELUDE_INFO(base_GHCziStable_StablePtr_con_info); #define runSparks_closure DLL_IMPORT_DATA_REF(base_GHCziConcziSync_runSparks_closure) #define ensureIOManagerIsRunning_closure DLL_IMPORT_DATA_REF(base_GHCziConcziIO_ensureIOManagerIsRunning_closure) +#define interruptIOManager_closure DLL_IMPORT_DATA_REF(base_GHCziConcziIO_interruptIOManager_closure) #define ioManagerCapabilitiesChanged_closure DLL_IMPORT_DATA_REF(base_GHCziConcziIO_ioManagerCapabilitiesChanged_closure) #define runHandlersPtr_closure DLL_IMPORT_DATA_REF(base_GHCziConcziSignal_runHandlersPtr_closure) +#if defined(mingw32_HOST_OS) +#define processRemoteCompletion_closure DLL_IMPORT_DATA_REF(base_GHCziEventziWindows_processRemoteCompletion_closure) +#endif #define flushStdHandles_closure DLL_IMPORT_DATA_REF(base_GHCziTopHandler_flushStdHandles_closure) #define runMainIO_closure DLL_IMPORT_DATA_REF(base_GHCziTopHandler_runMainIO_closure) diff --git a/rts/RtsStartup.c b/rts/RtsStartup.c index 31f8267708..a52c02190e 100644 --- a/rts/RtsStartup.c +++ b/rts/RtsStartup.c @@ -46,7 +46,8 @@ #endif #if defined(mingw32_HOST_OS) && !defined(THREADED_RTS) -#include "win32/AsyncIO.h" +#include "win32/AsyncMIO.h" +#include "win32/AsyncWinIO.h" #endif #if defined(mingw32_HOST_OS) @@ -299,10 +300,13 @@ hs_init_ghc(int *argc, char **argv[], RtsConfig rts_config) getStablePtr((StgPtr)nestedAtomically_closure); getStablePtr((StgPtr)runSparks_closure); getStablePtr((StgPtr)ensureIOManagerIsRunning_closure); + getStablePtr((StgPtr)interruptIOManager_closure); getStablePtr((StgPtr)ioManagerCapabilitiesChanged_closure); #if !defined(mingw32_HOST_OS) getStablePtr((StgPtr)blockedOnBadFD_closure); getStablePtr((StgPtr)runHandlersPtr_closure); +#else + getStablePtr((StgPtr)processRemoteCompletion_closure); #endif // Initialize the top-level handler system @@ -338,7 +342,10 @@ hs_init_ghc(int *argc, char **argv[], RtsConfig rts_config) #endif #if defined(mingw32_HOST_OS) && !defined(THREADED_RTS) - startupAsyncIO(); + if (is_io_mng_native_p()) + startupAsyncWinIO(); + else + startupAsyncIO(); #endif x86_init_fpu(); @@ -520,7 +527,10 @@ hs_exit_(bool wait_foreign) #endif #if defined(mingw32_HOST_OS) && !defined(THREADED_RTS) - shutdownAsyncIO(wait_foreign); + if (is_io_mng_native_p()) + shutdownAsyncWinIO(wait_foreign); + else + shutdownAsyncIO(wait_foreign); #endif /* free hash table storage */ diff --git a/rts/RtsSymbols.c b/rts/RtsSymbols.c index 0f0bd56c82..ff430d0137 100644 --- a/rts/RtsSymbols.c +++ b/rts/RtsSymbols.c @@ -26,6 +26,7 @@ #include <io.h> #include <windows.h> #include <shfolder.h> /* SHGetFolderPathW */ +#include "win32/AsyncWinIO.h" #endif #if defined(openbsd_HOST_OS) @@ -142,11 +143,15 @@ /* see Note [Symbols for MinGW's printf] */ \ SymI_HasProto(_lock_file) \ SymI_HasProto(_unlock_file) \ + SymI_HasProto(__mingw_vsnwprintf) \ + /* ^^ Need to figure out why this is needed. */ \ /* See Note [_iob_func symbol] */ \ RTS_WIN64_ONLY(SymI_HasProto_redirect( \ __imp___acrt_iob_func, __rts_iob_func, true)) \ RTS_WIN32_ONLY(SymI_HasProto_redirect( \ - __imp____acrt_iob_func, __rts_iob_func, true)) + __imp____acrt_iob_func, __rts_iob_func, true)) \ + SymI_HasProto(__mingw_vsnwprintf) + /* ^^ Need to figure out why this is needed. */ #define RTS_MINGW_COMPAT_SYMBOLS \ SymI_HasProto_deprecated(access) \ @@ -337,11 +342,16 @@ SymI_HasProto(blockUserSignals) \ SymI_HasProto(unblockUserSignals) #else -#define RTS_USER_SIGNALS_SYMBOLS \ - SymI_HasProto(ioManagerWakeup) \ - SymI_HasProto(sendIOManagerEvent) \ - SymI_HasProto(readIOManagerEvent) \ - SymI_HasProto(getIOManagerEvent) \ +#define RTS_USER_SIGNALS_SYMBOLS \ + SymI_HasProto(registerNewIOCPHandle) \ + SymI_HasProto(getOverlappedEntries) \ + SymI_HasProto(servicedIOEntries) \ + SymI_HasProto(completeSynchronousRequest) \ + SymI_HasProto(registerAlertableWait) \ + SymI_HasProto(ioManagerWakeup) \ + SymI_HasProto(sendIOManagerEvent) \ + SymI_HasProto(readIOManagerEvent) \ + SymI_HasProto(getIOManagerEvent) \ SymI_HasProto(console_handler) #endif diff --git a/rts/package.conf.in b/rts/package.conf.in index 45866a1ecd..a03eff6a14 100644 --- a/rts/package.conf.in +++ b/rts/package.conf.in @@ -105,8 +105,12 @@ ld-options: , "-Wl,-u,_base_GHCziExceptionziType_overflowException_closure" , "-Wl,-u,_base_GHCziConcziSync_runSparks_closure" , "-Wl,-u,_base_GHCziConcziIO_ensureIOManagerIsRunning_closure" + , "-Wl,-u,_base_GHCziConcziIO_interruptIOManager_closure" , "-Wl,-u,_base_GHCziConcziIO_ioManagerCapabilitiesChanged_closure" , "-Wl,-u,_base_GHCziConcziSignal_runHandlersPtr_closure" +#if defined(mingw32_HOST_OS) + , "-Wl,-u,_base_GHCziEventziWindows_processRemoteCompletion_closure" +#endif , "-Wl,-u,_base_GHCziTopHandler_flushStdHandles_closure" , "-Wl,-u,_base_GHCziTopHandler_runMainIO_closure" , "-Wl,-u,_ghczmprim_GHCziTypes_Czh_con_info" @@ -214,8 +218,12 @@ ld-options: , "-Wl,-u,base_GHCziExceptionziType_overflowException_closure" , "-Wl,-u,base_GHCziConcziSync_runSparks_closure" , "-Wl,-u,base_GHCziConcziIO_ensureIOManagerIsRunning_closure" + , "-Wl,-u,base_GHCziConcziIO_interruptIOManager_closure" , "-Wl,-u,base_GHCziConcziIO_ioManagerCapabilitiesChanged_closure" , "-Wl,-u,base_GHCziConcziSignal_runHandlersPtr_closure" +#if defined(mingw32_HOST_OS) + , "-Wl,-u,base_GHCziEventziWindows_processRemoteCompletion_closure" +#endif , "-Wl,-u,base_GHCziTopHandler_flushStdHandles_closure" , "-Wl,-u,base_GHCziTopHandler_runMainIO_closure" , "-Wl,-u,ghczmprim_GHCziTypes_Czh_con_info" diff --git a/rts/rts.cabal.in b/rts/rts.cabal.in index ebbd9a9e71..a16582a7f5 100644 --- a/rts/rts.cabal.in +++ b/rts/rts.cabal.in @@ -97,6 +97,7 @@ library dbghelp -- for process information psapi + -- TODO: Hadrian will use this cabal file, so drop WINVER from Hadrian's configs. -- Minimum supported Windows version. -- These numbers can be found at: -- https://msdn.microsoft.com/en-us/library/windows/desktop/aa383745(v=vs.85).aspx @@ -231,6 +232,7 @@ library "-Wl,-u,_base_GHCziEventziThread_blockedOnBadFD_closure" "-Wl,-u,_base_GHCziConcziSync_runSparks_closure" "-Wl,-u,_base_GHCziConcziIO_ensureIOManagerIsRunning_closure" + "-Wl,-u,_base_GHCziConcziIO_interruptIOManager_closure" "-Wl,-u,_base_GHCziConcziIO_ioManagerCapabilitiesChanged_closure" "-Wl,-u,_base_GHCziConcziSignal_runHandlersPtr_closure" "-Wl,-u,_base_GHCziTopHandler_flushStdHandles_closure" @@ -310,6 +312,7 @@ library "-Wl,-u,base_GHCziEventziThread_blockedOnBadFD_closure" "-Wl,-u,base_GHCziConcziSync_runSparks_closure" "-Wl,-u,base_GHCziConcziIO_ensureIOManagerIsRunning_closure" + "-Wl,-u,base_GHCziConcziIO_interruptIOManager_closure" "-Wl,-u,base_GHCziConcziIO_ioManagerCapabilitiesChanged_closure" "-Wl,-u,base_GHCziConcziSignal_runHandlersPtr_closure" "-Wl,-u,base_GHCziTopHandler_flushStdHandles_closure" @@ -366,6 +369,17 @@ library -- This symbol is useful in gdb, but not referred to anywhere, -- so we need to force it to be included in the binary. ld-options: "-Wl,-u,findPtr" + -- This symbol is useful in gdb, but not referred to anywhere, + -- so we need to force it to be included in the binary. + "-Wl,-u,findPtr" + + if os(windows) + if flag(leading-underscore) + ld-options: + "-Wl,-u,_base_GHCziEventziWindows_processRemoteCompletion_closure" + else + ld-options: + "-Wl,-u,base_GHCziEventziWindows_processRemoteCompletion_closure" if os(osx) ld-options: "-Wl,-search_paths_first" @@ -497,7 +511,8 @@ library -- I wish we had wildcards..., this would be: -- *.c hooks/**/*.c sm/**/*.c eventlog/**/*.c linker/**/*.c if os(windows) - c-sources: win32/AsyncIO.c + c-sources: win32/AsyncMIO.c + win32/AsyncWinIO.c win32/AwaitEvent.c win32/ConsoleHandler.c win32/GetEnv.c diff --git a/rts/win32/AsyncIO.c b/rts/win32/AsyncIO.c deleted file mode 100644 index 49da79d2dd..0000000000 --- a/rts/win32/AsyncIO.c +++ /dev/null @@ -1,384 +0,0 @@ -/* AsyncIO.c - * - * Integrating Win32 asynchronous I/O with the GHC RTS. - * - * (c) sof, 2002-2003. - */ - -#if !defined(THREADED_RTS) - -#include "Rts.h" -#include "RtsUtils.h" -#include <windows.h> -#include <stdio.h> -#include "Schedule.h" -#include "Capability.h" -#include "win32/AsyncIO.h" -#include "win32/IOManager.h" - -/* - * Overview: - * - * Haskell code issue asynchronous I/O requests via the - * async{Read,Write,DoOp}# primops. These cause addIORequest() - * to be invoked, which forwards the request to the underlying - * asynchronous I/O subsystem. Each request is tagged with a unique - * ID. - * - * addIORequest() returns this ID, so that when the blocked CH - * thread is added onto blocked_queue, its TSO is annotated with - * it. Upon completion of an I/O request, the async I/O handling - * code makes a back-call to signal its completion; the local - * onIOComplete() routine. It adds the IO request ID (along with - * its result data) to a queue of completed requests before returning. - * - * The queue of completed IO request is read by the thread operating - * the RTS scheduler. It de-queues the CH threads corresponding - * to the request IDs, making them runnable again. - * - */ - -typedef struct CompletedReq { - unsigned int reqID; - HsInt len; - HsInt errCode; -} CompletedReq; - -#define MAX_REQUESTS 200 - -static CRITICAL_SECTION queue_lock; -static HANDLE completed_req_event = INVALID_HANDLE_VALUE; -static HANDLE abandon_req_wait = INVALID_HANDLE_VALUE; -static HANDLE wait_handles[2]; -static CompletedReq completedTable[MAX_REQUESTS]; -static int completed_hw; -static HANDLE completed_table_sema; -static int issued_reqs; - -static void -onIOComplete(unsigned int reqID, - int fd STG_UNUSED, - HsInt len, - void* buf STG_UNUSED, - HsInt errCode) -{ - DWORD dwRes; - /* Deposit result of request in queue/table..when there's room. */ - dwRes = WaitForSingleObject(completed_table_sema, INFINITE); - switch (dwRes) { - case WAIT_OBJECT_0: - case WAIT_ABANDONED: - break; - default: - /* Not likely */ - fprintf(stderr, - "onIOComplete: failed to grab table semaphore (res=%d, err=%d), " - "dropping request 0x%x\n", reqID, dwRes, GetLastError()); - fflush(stderr); - return; - } - EnterCriticalSection(&queue_lock); - if (completed_hw == MAX_REQUESTS) { - /* Shouldn't happen */ - fprintf(stderr, "onIOComplete: ERROR -- Request table overflow (%d); " - "dropping.\n", reqID); - fflush(stderr); - } else { -#if 0 - fprintf(stderr, "onCompl: %d %d %d %d %d\n", - reqID, len, errCode, issued_reqs, completed_hw); - fflush(stderr); -#endif - completedTable[completed_hw].reqID = reqID; - completedTable[completed_hw].len = len; - completedTable[completed_hw].errCode = errCode; - completed_hw++; - issued_reqs--; - if (completed_hw == 1) { - /* The event is used to wake up the scheduler thread should it - * be blocked waiting for requests to complete. The event resets - * once that thread has cleared out the request queue/table. - */ - SetEvent(completed_req_event); - } - } - LeaveCriticalSection(&queue_lock); -} - -unsigned int -addIORequest(int fd, - bool forWriting, - bool isSock, - HsInt len, - char* buf) -{ - EnterCriticalSection(&queue_lock); - issued_reqs++; - LeaveCriticalSection(&queue_lock); -#if 0 - fprintf(stderr, "addIOReq: %d %d %d\n", fd, forWriting, len); - fflush(stderr); -#endif - return AddIORequest(fd,forWriting,isSock,len,buf,onIOComplete); -} - -unsigned int -addDelayRequest(HsInt usecs) -{ - EnterCriticalSection(&queue_lock); - issued_reqs++; - LeaveCriticalSection(&queue_lock); -#if 0 - fprintf(stderr, "addDelayReq: %d\n", usecs); fflush(stderr); -#endif - return AddDelayRequest(usecs,onIOComplete); -} - -unsigned int -addDoProcRequest(void* proc, void* param) -{ - EnterCriticalSection(&queue_lock); - issued_reqs++; - LeaveCriticalSection(&queue_lock); -#if 0 - fprintf(stderr, "addProcReq: %p %p\n", proc, param); fflush(stderr); -#endif - return AddProcRequest(proc,param,onIOComplete); -} - - -int -startupAsyncIO() -{ - if (!StartIOManager()) { - return 0; - } - InitializeCriticalSection(&queue_lock); - /* Create a pair of events: - * - * - completed_req_event -- signals the deposit of request result; - * manual reset. - * - abandon_req_wait -- external OS thread tells current - * RTS/Scheduler thread to abandon wait - * for IO request completion. - * Auto reset. - */ - completed_req_event = CreateEvent (NULL, TRUE, FALSE, NULL); - abandon_req_wait = CreateEvent (NULL, FALSE, FALSE, NULL); - wait_handles[0] = completed_req_event; - wait_handles[1] = abandon_req_wait; - completed_hw = 0; - if ( !(completed_table_sema = CreateSemaphore(NULL, MAX_REQUESTS, - MAX_REQUESTS, NULL)) ) { - DWORD rc = GetLastError(); - fprintf(stderr, "startupAsyncIO: CreateSemaphore failed 0x%x\n", - (int)rc); - fflush(stderr); - } - - return ( completed_req_event != INVALID_HANDLE_VALUE && - abandon_req_wait != INVALID_HANDLE_VALUE && - completed_table_sema != NULL ); -} - -void -shutdownAsyncIO(bool wait_threads) -{ - ShutdownIOManager(wait_threads); - if (completed_req_event != INVALID_HANDLE_VALUE) { - CloseHandle(completed_req_event); - completed_req_event = INVALID_HANDLE_VALUE; - } - if (abandon_req_wait != INVALID_HANDLE_VALUE) { - CloseHandle(abandon_req_wait); - abandon_req_wait = INVALID_HANDLE_VALUE; - } - if (completed_table_sema != NULL) { - CloseHandle(completed_table_sema); - completed_table_sema = NULL; - } - DeleteCriticalSection(&queue_lock); -} - -/* - * Function: awaitRequests(wait) - * - * Check for the completion of external IO work requests. Worker - * threads signal completion of IO requests by depositing them - * in a table (completedTable). awaitRequests() matches up - * requests in that table with threads on the blocked_queue, - * making the threads whose IO requests have completed runnable - * again. - * - * awaitRequests() is called by the scheduler periodically _or_ if - * it is out of work, and need to wait for the completion of IO - * requests to make further progress. In the latter scenario, - * awaitRequests() will simply block waiting for worker threads - * to complete if the 'completedTable' is empty. - */ -int -awaitRequests(bool wait) -{ -#if !defined(THREADED_RTS) - // none of this is actually used in the threaded RTS - -start: -#if 0 - fprintf(stderr, "awaitRequests(): %d %d %d\n", - issued_reqs, completed_hw, wait); - fflush(stderr); -#endif - EnterCriticalSection(&queue_lock); - // Nothing immediately available & we won't wait - if ((!wait && completed_hw == 0) -#if 0 - // If we just return when wait==false, we'll go into a busy - // wait loop, so I disabled this condition --SDM 18/12/2003 - (issued_reqs == 0 && completed_hw == 0) -#endif - ) { - LeaveCriticalSection(&queue_lock); - return 0; - } - if (completed_hw == 0) { - // empty table, drop lock and wait - LeaveCriticalSection(&queue_lock); - if ( wait && sched_state == SCHED_RUNNING ) { - DWORD dwRes = WaitForMultipleObjects(2, wait_handles, - FALSE, INFINITE); - switch (dwRes) { - case WAIT_OBJECT_0: - // a request was completed - break; - case WAIT_OBJECT_0 + 1: - case WAIT_TIMEOUT: - // timeout (unlikely) or told to abandon waiting - return 0; - case WAIT_FAILED: { - DWORD dw = GetLastError(); - fprintf(stderr, "awaitRequests: wait failed -- " - "error code: %lu\n", dw); fflush(stderr); - return 0; - } - default: - fprintf(stderr, "awaitRequests: unexpected wait return " - "code %lu\n", dwRes); fflush(stderr); - return 0; - } - } else { - return 0; - } - goto start; - } else { - int i; - StgTSO *tso, *prev; - - for (i=0; i < completed_hw; i++) { - /* For each of the completed requests, match up their Ids - * with those of the threads on the blocked_queue. If the - * thread that made the IO request has been subsequently - * killed (and removed from blocked_queue), no match will - * be found for that request Id. - * - * i.e., killing a Haskell thread doesn't attempt to cancel - * the IO request it is blocked on. - * - */ - unsigned int rID = completedTable[i].reqID; - - prev = NULL; - for(tso = blocked_queue_hd; tso != END_TSO_QUEUE; - tso = tso->_link) { - - switch(tso->why_blocked) { - case BlockedOnRead: - case BlockedOnWrite: - case BlockedOnDoProc: - if (tso->block_info.async_result->reqID == rID) { - // Found the thread blocked waiting on request; - // stodgily fill - // in its result block. - tso->block_info.async_result->len = - completedTable[i].len; - tso->block_info.async_result->errCode = - completedTable[i].errCode; - - // Drop the matched TSO from blocked_queue - if (prev) { - setTSOLink(&MainCapability, prev, tso->_link); - } else { - blocked_queue_hd = tso->_link; - } - if (blocked_queue_tl == tso) { - blocked_queue_tl = prev ? prev : END_TSO_QUEUE; - } - - // Terminates the run queue + this inner for-loop. - tso->_link = END_TSO_QUEUE; - tso->why_blocked = NotBlocked; - // save the StgAsyncIOResult in the - // stg_block_async_info stack frame, because - // the block_info field will be overwritten by - // pushOnRunQueue(). - tso->stackobj->sp[1] = (W_)tso->block_info.async_result; - pushOnRunQueue(&MainCapability, tso); - break; - } - break; - default: - if (tso->why_blocked != NotBlocked) { - barf("awaitRequests: odd thread state"); - } - break; - } - - prev = tso; - } - /* Signal that there's completed table slots available */ - if ( !ReleaseSemaphore(completed_table_sema, 1, NULL) ) { - DWORD dw = GetLastError(); - fprintf(stderr, "awaitRequests: failed to signal semaphore " - "(error code=0x%x)\n", (int)dw); - fflush(stderr); - } - } - completed_hw = 0; - ResetEvent(completed_req_event); - LeaveCriticalSection(&queue_lock); - return 1; - } -#endif /* !THREADED_RTS */ -} - -/* - * Function: abandonRequestWait() - * - * Wake up a thread that's blocked waiting for new IO requests - * to complete (via awaitRequests().) - */ -void -abandonRequestWait( void ) -{ - /* the event is auto-reset, but in case there's no thread - * already waiting on the event, we want to return it to - * a non-signalled state. - * - * Careful! There is no synchronisation between - * abandonRequestWait and awaitRequest, which means that - * abandonRequestWait might be called just before a thread - * goes into a wait, and we miss the abandon signal. So we - * must SetEvent() here rather than PulseEvent() to ensure - * that the event isn't lost. We can re-optimise by resetting - * the event somewhere safe if we know the event has been - * properly serviced (see resetAbandon() below). --SDM 18/12/2003 - */ - SetEvent(abandon_req_wait); -} - -void -resetAbandonRequestWait( void ) -{ - ResetEvent(abandon_req_wait); -} - -#endif /* !defined(THREADED_RTS) */ diff --git a/rts/win32/AsyncIO.h b/rts/win32/AsyncIO.h deleted file mode 100644 index 75d0e0460d..0000000000 --- a/rts/win32/AsyncIO.h +++ /dev/null @@ -1,24 +0,0 @@ -/* AsyncIO.h - * - * Integrating Win32 asynchronous I/O with the GHC RTS. - * - * (c) sof, 2002-2003. - */ - -#pragma once - -extern unsigned int -addIORequest(int fd, - bool forWriting, - bool isSock, - HsInt len, - char* buf); -extern unsigned int addDelayRequest(HsInt usecs); -extern unsigned int addDoProcRequest(void* proc, void* param); -extern int startupAsyncIO(void); -extern void shutdownAsyncIO(bool wait_threads); - -extern int awaitRequests(bool wait); - -extern void abandonRequestWait(void); -extern void resetAbandonRequestWait(void); diff --git a/rts/win32/AwaitEvent.c b/rts/win32/AwaitEvent.c index b639121c87..6a621d6ef5 100644 --- a/rts/win32/AwaitEvent.c +++ b/rts/win32/AwaitEvent.c @@ -14,15 +14,18 @@ * */ #include "Rts.h" +#include "RtsFlags.h" #include "Schedule.h" #include "AwaitEvent.h" #include <windows.h> -#include "win32/AsyncIO.h" +#include "win32/AsyncMIO.h" +#include "win32/AsyncWinIO.h" #include "win32/ConsoleHandler.h" +#include <stdbool.h> // Used to avoid calling abandonRequestWait() if we don't need to. // Protected by sched_mutex. -static uint32_t workerWaitingForRequests = 0; +static bool workerWaitingForRequests = false; void awaitEvent(bool wait) @@ -30,9 +33,12 @@ awaitEvent(bool wait) do { /* Try to de-queue completed IO requests */ - workerWaitingForRequests = 1; - awaitRequests(wait); - workerWaitingForRequests = 0; + workerWaitingForRequests = true; + if (is_io_mng_native_p()) + awaitAsyncRequests(wait); + else + awaitRequests(wait); + workerWaitingForRequests = false; // If a signal was raised, we need to service it // XXX the scheduler loop really should be calling diff --git a/rts/win32/ConsoleHandler.c b/rts/win32/ConsoleHandler.c index 3ddf4103da..05d15868eb 100644 --- a/rts/win32/ConsoleHandler.c +++ b/rts/win32/ConsoleHandler.c @@ -1,13 +1,15 @@ /* * Console control handler support. * + * NOTE: This is the MIO manager, only used for --io-manager=posix. + * For the WINIO manager see base in the GHC.Event modules. */ #include "Rts.h" #include <windows.h> #include "ConsoleHandler.h" #include "Schedule.h" #include "RtsUtils.h" -#include "AsyncIO.h" +#include "AsyncMIO.h" #include "RtsSignals.h" extern int stg_InstallConsoleEvent(int action, StgStablePtr *handler); @@ -86,7 +88,6 @@ static BOOL WINAPI shutdown_handler(DWORD dwCtrlType) return false; case CTRL_C_EVENT: case CTRL_BREAK_EVENT: - // If we're already trying to interrupt the RTS, terminate with // extreme prejudice. So the first ^C tries to exit the program // cleanly, and the second one just kills it. @@ -223,12 +224,12 @@ static BOOL WINAPI generic_handler(DWORD dwCtrlType) #if defined(THREADED_RTS) sendIOManagerEvent((StgWord8) ((dwCtrlType<<1) | 1)); + interruptIOManagerEvent (); #else if ( stg_pending_events < N_PENDING_EVENTS ) { stg_pending_buf[stg_pending_events] = dwCtrlType; stg_pending_events++; } - // we need to wake up awaitEvent() abandonRequestWait(); #endif diff --git a/rts/win32/ConsoleHandler.h b/rts/win32/ConsoleHandler.h index 06af9dd0d0..bb7278abba 100644 --- a/rts/win32/ConsoleHandler.h +++ b/rts/win32/ConsoleHandler.h @@ -1,6 +1,8 @@ /* * Console control handler support. * + * NOTE: This is the MIO manager, only used for --io-manager=posix. + * For the WINIO manager see base in the GHC.Event modules. */ #pragma once @@ -16,24 +18,24 @@ */ #if !defined(THREADED_RTS) -/* +/* * under THREADED_RTS, console events are passed to the IO manager * thread, which starts up the handler. See ThrIOManager.c. */ /* - * Function: signals_pending() - * + * Function: signals_pending() + * * Used by the RTS to check whether new signals have been 'recently' reported. - * If so, the RTS arranges for the delivered signals to be handled by - * de-queueing them from their table, running the associated Haskell + * If so, the RTS arranges for the delivered signals to be handled by + * de-queueing them from their table, running the associated Haskell * signal handler. */ extern StgInt stg_pending_events; #define signals_pending() ( stg_pending_events > 0) -/* +/* * Function: anyUserHandlers() * * Used by the Scheduler to decide whether its worth its while to stick diff --git a/rts/win32/IOManager.c b/rts/win32/IOManager.c index e5da32b982..47bcf4bcf4 100644 --- a/rts/win32/IOManager.c +++ b/rts/win32/IOManager.c @@ -3,6 +3,9 @@ * Non-blocking / asynchronous I/O for Win32. * * (c) sof, 2002-2003. + * + * NOTE: This is the MIO manager, only used for --io-manager=posix. + * For the WINIO manager see base in the GHC.Event modules. */ #if !defined(THREADED_RTS) diff --git a/rts/win32/IOManager.h b/rts/win32/IOManager.h index a5bd61ab1b..cb876db9cc 100644 --- a/rts/win32/IOManager.h +++ b/rts/win32/IOManager.h @@ -3,6 +3,9 @@ * Non-blocking / asynchronous I/O for Win32. * * (c) sof, 2002-2003 + * + * NOTE: This is the MIO manager, only used for --io-manager=posix. + * For the WINIO manager see base in the GHC.Event modules. */ #pragma once @@ -102,3 +105,5 @@ extern int AddProcRequest ( void* proc, CompletionProc onCompletion); extern void abandonWorkRequest ( int reqID ); + +extern void interruptIOManagerEvent ( void ); diff --git a/rts/win32/ThrIOManager.c b/rts/win32/ThrIOManager.c index 44414b92c3..b70a178faf 100644 --- a/rts/win32/ThrIOManager.c +++ b/rts/win32/ThrIOManager.c @@ -5,6 +5,7 @@ * The IO manager thread in THREADED_RTS. * See also libraries/base/GHC/Conc.hs. * + * NOTE: This is used by both MIO and WINIO * ---------------------------------------------------------------------------*/ #include "Rts.h" @@ -15,28 +16,14 @@ // Here's the Event that we use to wake up the IO manager thread static HANDLE io_manager_event = INVALID_HANDLE_VALUE; -// must agree with values in GHC.Conc: -#define IO_MANAGER_WAKEUP 0xffffffff -#define IO_MANAGER_DIE 0xfffffffe -// spurious wakeups are returned as zero. -// console events are ((event<<1) | 1) - -#if defined(THREADED_RTS) - #define EVENT_BUFSIZ 256 Mutex event_buf_mutex; StgWord32 event_buf[EVENT_BUFSIZ]; uint32_t next_event; -#endif - HANDLE getIOManagerEvent (void) { - // This function has to exist even in the non-THREADED_RTS, - // because code in GHC.Conc refers to it. It won't ever be called - // unless we're in the threaded RTS, however. -#if defined(THREADED_RTS) HANDLE hRes; ACQUIRE_LOCK(&event_buf_mutex); @@ -57,18 +44,12 @@ getIOManagerEvent (void) RELEASE_LOCK(&event_buf_mutex); return hRes; -#else - return NULL; -#endif } HsWord32 readIOManagerEvent (void) { - // This function must exist even in non-THREADED_RTS, - // see getIOManagerEvent() above. -#if defined(THREADED_RTS) HsWord32 res; ACQUIRE_LOCK(&event_buf_mutex); @@ -77,7 +58,11 @@ readIOManagerEvent (void) if (next_event == 0) { res = 0; // no event to return } else { - res = (HsWord32)(event_buf[--next_event]); + do { + // Dequeue as many wakeup events as possible. + res = (HsWord32)(event_buf[--next_event]); + } while (res == IO_MANAGER_WAKEUP && next_event); + if (next_event == 0) { if (!ResetEvent(io_manager_event)) { sysErrorBelch("readIOManagerEvent"); @@ -91,34 +76,45 @@ readIOManagerEvent (void) RELEASE_LOCK(&event_buf_mutex); - // debugBelch("readIOManagerEvent: %d\n", res); + //debugBelch("readIOManagerEvent: %d\n", res); return res; -#else - return 0; -#endif } void sendIOManagerEvent (HsWord32 event) { -#if defined(THREADED_RTS) ACQUIRE_LOCK(&event_buf_mutex); - // debugBelch("sendIOManagerEvent: %d\n", event); + //debugBelch("sendIOManagerEvent: %d to %p\n", event, io_manager_event); if (io_manager_event != INVALID_HANDLE_VALUE) { if (next_event == EVENT_BUFSIZ) { errorBelch("event buffer overflowed; event dropped"); } else { + event_buf[next_event++] = (StgWord32)event; if (!SetEvent(io_manager_event)) { - sysErrorBelch("sendIOManagerEvent"); + sysErrorBelch("sendIOManagerEvent: SetEvent"); stg_exit(EXIT_FAILURE); } - event_buf[next_event++] = (StgWord32)event; } } RELEASE_LOCK(&event_buf_mutex); -#endif +} + +void +interruptIOManagerEvent (void) +{ + if (is_io_mng_native_p ()) { + ACQUIRE_LOCK(&event_buf_mutex); + + /* How expensive is this??. */ + Capability *cap; + cap = rts_lock(); + rts_evalIO(&cap, interruptIOManager_closure, NULL); + rts_unlock(cap); + + RELEASE_LOCK(&event_buf_mutex); + } } void @@ -127,7 +123,6 @@ ioManagerWakeup (void) sendIOManagerEvent(IO_MANAGER_WAKEUP); } -#if defined(THREADED_RTS) void ioManagerDie (void) { @@ -145,7 +140,9 @@ ioManagerDie (void) void ioManagerStart (void) { +#if defined(THREADED_RTS) initMutex(&event_buf_mutex); +#endif next_event = 0; // Make sure the IO manager thread is running @@ -156,4 +153,3 @@ ioManagerStart (void) rts_unlock(cap); } } -#endif diff --git a/rts/win32/libHSbase.def b/rts/win32/libHSbase.def index de4db2244b..fb705bbd9f 100644 --- a/rts/win32/libHSbase.def +++ b/rts/win32/libHSbase.def @@ -27,8 +27,10 @@ EXPORTS base_GHCziPtr_FunPtr_con_info base_GHCziConcziIO_ensureIOManagerIsRunning_closure + base_GHCziConcziIO_interruptIOManager_closure base_GHCziConcziIO_ioManagerCapabilitiesChanged_closure base_GHCziConcziSync_runSparks_closure + base_GHCziEventziWindows_processRemoteCompletion_closure base_GHCziTopHandler_flushStdHandles_closure |