{-# LANGUAGE Trustworthy #-}
{-# LANGUAGE BangPatterns, NoImplicitPrelude #-}

module GHC.Event.Thread
    ( getSystemEventManager
    , getSystemTimerManager
    , ensureIOManagerIsRunning
    , ioManagerCapabilitiesChanged
    , threadWaitRead
    , threadWaitWrite
    , threadWaitReadSTM
    , threadWaitWriteSTM
    , closeFdWith
    , threadDelay
    , 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)
import Data.Tuple (snd)
import Foreign.C.Error (eBADF, errnoToIOError)
import Foreign.C.Types (CInt(..), CUInt(..))
import Foreign.Ptr (Ptr)
import GHC.Base
import GHC.List (zipWith, zipWith3)
import GHC.Conc.Sync (TVar, ThreadId, ThreadStatus(..), atomically, forkIO,
                      labelThread, modifyMVar_, withMVar, newTVar, sharedCAF,
                      getNumCapabilities, threadCapability, myThreadId, forkOn,
                      threadStatus, writeTVar, newTVarIO, readTVar, retry,throwSTM,STM)
import GHC.IO (mask_, onException)
import GHC.IO.Exception (ioError)
import GHC.IOArray (IOArray, newIOArray, readIOArray, writeIOArray,
                    boundsIOArray)
import GHC.MVar (MVar, newEmptyMVar, newMVar, putMVar, takeMVar)
import GHC.Event.Control (controlWriteFd)
import GHC.Event.Internal (eventIs, evtClose)
import GHC.Event.Manager (Event, EventManager, evtRead, evtWrite, loop,
                             new, registerFd, unregisterFd_)
import qualified GHC.Event.Manager as M
import qualified GHC.Event.TimerManager as TM
import GHC.Num ((-), (+))
import GHC.Real (fromIntegral)
import GHC.Show (showSignedInt)
import System.IO.Unsafe (unsafePerformIO)
import System.Posix.Types (Fd)

-- | Suspends the current thread for a given number of microseconds
-- (GHC only).
--
-- There is no guarantee that the thread will be rescheduled promptly
-- when the delay has expired, but the thread will never continue to
-- run /earlier/ than specified.
threadDelay :: Int -> IO ()
threadDelay :: Int -> IO ()
threadDelay Int
usecs = IO () -> IO ()
forall a. IO a -> IO a
mask_ (IO () -> IO ()) -> IO () -> IO ()
forall a b. (a -> b) -> a -> b
$ do
  TimerManager
mgr <- IO TimerManager
getSystemTimerManager
  MVar ()
m <- IO (MVar ())
forall a. IO (MVar a)
newEmptyMVar
  TimeoutKey
reg <- TimerManager -> Int -> IO () -> IO TimeoutKey
TM.registerTimeout TimerManager
mgr Int
usecs (MVar () -> () -> IO ()
forall a. MVar a -> a -> IO ()
putMVar MVar ()
m ())
  MVar () -> IO ()
forall a. MVar a -> IO a
takeMVar MVar ()
m IO () -> IO () -> IO ()
forall a b. IO a -> IO b -> IO a
`onException` TimerManager -> TimeoutKey -> IO ()
TM.unregisterTimeout TimerManager
mgr TimeoutKey
reg

-- | 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 :: Int -> IO (TVar Bool)
registerDelay Int
usecs = do
  TVar Bool
t <- STM (TVar Bool) -> IO (TVar Bool)
forall a. STM a -> IO a
atomically (STM (TVar Bool) -> IO (TVar Bool))
-> STM (TVar Bool) -> IO (TVar Bool)
forall a b. (a -> b) -> a -> b
$ Bool -> STM (TVar Bool)
forall a. a -> STM (TVar a)
newTVar Bool
False
  TimerManager
mgr <- IO TimerManager
getSystemTimerManager
  TimeoutKey
_ <- TimerManager -> Int -> IO () -> IO TimeoutKey
TM.registerTimeout TimerManager
mgr Int
usecs (IO () -> IO TimeoutKey)
-> (STM () -> IO ()) -> STM () -> IO TimeoutKey
forall b c a. (b -> c) -> (a -> b) -> a -> c
. STM () -> IO ()
forall a. STM a -> IO a
atomically (STM () -> IO TimeoutKey) -> STM () -> IO TimeoutKey
forall a b. (a -> b) -> a -> b
$ TVar Bool -> Bool -> STM ()
forall a. TVar a -> a -> STM ()
writeTVar TVar Bool
t Bool
True
  TVar Bool -> IO (TVar Bool)
forall (m :: * -> *) a. Monad m => a -> m a
return TVar Bool
t

-- | Block the current thread until data is available to read from the
-- given file descriptor.
--
-- This will throw an 'Prelude.IOError' if the file descriptor was closed
-- while this thread was blocked.  To safely close a file descriptor
-- that has been used with 'threadWaitRead', use 'closeFdWith'.
threadWaitRead :: Fd -> IO ()
threadWaitRead :: Fd -> IO ()
threadWaitRead = Event -> Fd -> IO ()
threadWait Event
evtRead
{-# INLINE threadWaitRead #-}

-- | Block the current thread until the given file descriptor can
-- accept data to write.
--
-- This will throw an 'Prelude.IOError' if the file descriptor was closed
-- while this thread was blocked.  To safely close a file descriptor
-- that has been used with 'threadWaitWrite', use 'closeFdWith'.
threadWaitWrite :: Fd -> IO ()
threadWaitWrite :: Fd -> IO ()
threadWaitWrite = Event -> Fd -> IO ()
threadWait Event
evtWrite
{-# INLINE threadWaitWrite #-}

-- | Close a file descriptor in a concurrency-safe way.
--
-- Any threads that are blocked on the file descriptor via
-- 'threadWaitRead' or 'threadWaitWrite' will be unblocked by having
-- IO exceptions thrown.
closeFdWith :: (Fd -> IO ())        -- ^ Action that performs the close.
            -> Fd                   -- ^ File descriptor to close.
            -> IO ()
closeFdWith :: (Fd -> IO ()) -> Fd -> IO ()
closeFdWith Fd -> IO ()
close Fd
fd = do
  IOArray Int (Maybe (ThreadId, EventManager))
eventManagerArray <- IORef (IOArray Int (Maybe (ThreadId, EventManager)))
-> IO (IOArray Int (Maybe (ThreadId, EventManager)))
forall a. IORef a -> IO a
readIORef IORef (IOArray Int (Maybe (ThreadId, EventManager)))
eventManager
  let (Int
low, Int
high) = IOArray Int (Maybe (ThreadId, EventManager)) -> (Int, Int)
forall i e. IOArray i e -> (i, i)
boundsIOArray IOArray Int (Maybe (ThreadId, EventManager))
eventManagerArray
  [EventManager]
mgrs <- ((Int -> IO EventManager) -> [Int] -> IO [EventManager])
-> [Int] -> (Int -> IO EventManager) -> IO [EventManager]
forall a b c. (a -> b -> c) -> b -> a -> c
flip (Int -> IO EventManager) -> [Int] -> IO [EventManager]
forall (m :: * -> *) a b. Monad m => (a -> m b) -> [a] -> m [b]
mapM [Int
low..Int
high] ((Int -> IO EventManager) -> IO [EventManager])
-> (Int -> IO EventManager) -> IO [EventManager]
forall a b. (a -> b) -> a -> b
$ \Int
i -> do
    Just (ThreadId
_,!EventManager
mgr) <- IOArray Int (Maybe (ThreadId, EventManager))
-> Int -> IO (Maybe (ThreadId, EventManager))
forall i e. Ix i => IOArray i e -> i -> IO e
readIOArray IOArray Int (Maybe (ThreadId, EventManager))
eventManagerArray Int
i
    EventManager -> IO EventManager
forall (m :: * -> *) a. Monad m => a -> m a
return EventManager
mgr
  IO () -> IO ()
forall a. IO a -> IO a
mask_ (IO () -> IO ()) -> IO () -> IO ()
forall a b. (a -> b) -> a -> b
$ do
    [IntTable [FdData]]
tables <- ((EventManager -> IO (IntTable [FdData]))
 -> [EventManager] -> IO [IntTable [FdData]])
-> [EventManager]
-> (EventManager -> IO (IntTable [FdData]))
-> IO [IntTable [FdData]]
forall a b c. (a -> b -> c) -> b -> a -> c
flip (EventManager -> IO (IntTable [FdData]))
-> [EventManager] -> IO [IntTable [FdData]]
forall (m :: * -> *) a b. Monad m => (a -> m b) -> [a] -> m [b]
mapM [EventManager]
mgrs ((EventManager -> IO (IntTable [FdData]))
 -> IO [IntTable [FdData]])
-> (EventManager -> IO (IntTable [FdData]))
-> IO [IntTable [FdData]]
forall a b. (a -> b) -> a -> b
$ \EventManager
mgr -> MVar (IntTable [FdData]) -> IO (IntTable [FdData])
forall a. MVar a -> IO a
takeMVar (MVar (IntTable [FdData]) -> IO (IntTable [FdData]))
-> MVar (IntTable [FdData]) -> IO (IntTable [FdData])
forall a b. (a -> b) -> a -> b
$ EventManager -> Fd -> MVar (IntTable [FdData])
M.callbackTableVar EventManager
mgr Fd
fd
    [IO ()]
cbApps <- (EventManager -> IntTable [FdData] -> IO (IO ()))
-> [EventManager] -> [IntTable [FdData]] -> IO [IO ()]
forall {m :: * -> *} {a} {b} {a}.
Monad m =>
(a -> b -> m a) -> [a] -> [b] -> m [a]
zipWithM (\EventManager
mgr IntTable [FdData]
table -> EventManager -> IntTable [FdData] -> Fd -> IO (IO ())
M.closeFd_ EventManager
mgr IntTable [FdData]
table Fd
fd) [EventManager]
mgrs [IntTable [FdData]]
tables
    Fd -> IO ()
close Fd
fd IO () -> IO () -> IO ()
forall a b. IO a -> IO b -> IO a
`finally` [IO ()] -> IO ()
forall (t :: * -> *) (m :: * -> *) a.
(Foldable t, Monad m) =>
t (m a) -> m ()
sequence_ ((EventManager -> IntTable [FdData] -> IO () -> IO ())
-> [EventManager] -> [IntTable [FdData]] -> [IO ()] -> [IO ()]
forall a b c d. (a -> b -> c -> d) -> [a] -> [b] -> [c] -> [d]
zipWith3 EventManager -> IntTable [FdData] -> IO () -> IO ()
forall {b}. EventManager -> IntTable [FdData] -> IO b -> IO b
finish [EventManager]
mgrs [IntTable [FdData]]
tables [IO ()]
cbApps)
  where
    finish :: EventManager -> IntTable [FdData] -> IO b -> IO b
finish EventManager
mgr IntTable [FdData]
table IO b
cbApp = MVar (IntTable [FdData]) -> IntTable [FdData] -> IO ()
forall a. MVar a -> a -> IO ()
putMVar (EventManager -> Fd -> MVar (IntTable [FdData])
M.callbackTableVar EventManager
mgr Fd
fd) IntTable [FdData]
table IO () -> IO b -> IO b
forall (m :: * -> *) a b. Monad m => m a -> m b -> m b
>> IO b
cbApp
    zipWithM :: (a -> b -> m a) -> [a] -> [b] -> m [a]
zipWithM a -> b -> m a
f [a]
xs [b]
ys = [m a] -> m [a]
forall (m :: * -> *) a. Monad m => [m a] -> m [a]
sequence ((a -> b -> m a) -> [a] -> [b] -> [m a]
forall a b c. (a -> b -> c) -> [a] -> [b] -> [c]
zipWith a -> b -> m a
f [a]
xs [b]
ys)

threadWait :: Event -> Fd -> IO ()
threadWait :: Event -> Fd -> IO ()
threadWait Event
evt Fd
fd = IO () -> IO ()
forall a. IO a -> IO a
mask_ (IO () -> IO ()) -> IO () -> IO ()
forall a b. (a -> b) -> a -> b
$ do
  MVar Event
m <- IO (MVar Event)
forall a. IO (MVar a)
newEmptyMVar
  EventManager
mgr <- IO EventManager
getSystemEventManager_
  FdKey
reg <- EventManager -> IOCallback -> Fd -> Event -> Lifetime -> IO FdKey
registerFd EventManager
mgr (\FdKey
_ Event
e -> MVar Event -> Event -> IO ()
forall a. MVar a -> a -> IO ()
putMVar MVar Event
m Event
e) Fd
fd Event
evt Lifetime
M.OneShot
  Event
evt' <- MVar Event -> IO Event
forall a. MVar a -> IO a
takeMVar MVar Event
m IO Event -> IO Bool -> IO Event
forall a b. IO a -> IO b -> IO a
`onException` EventManager -> FdKey -> IO Bool
unregisterFd_ EventManager
mgr FdKey
reg
  if Event
evt' Event -> Event -> Bool
`eventIs` Event
evtClose
    then IOError -> IO ()
forall a. IOError -> IO a
ioError (IOError -> IO ()) -> IOError -> IO ()
forall a b. (a -> b) -> a -> b
$ String -> Errno -> Maybe Handle -> Maybe String -> IOError
errnoToIOError String
"threadWait" Errno
eBADF Maybe Handle
forall a. Maybe a
Nothing Maybe String
forall a. Maybe a
Nothing
    else () -> IO ()
forall (m :: * -> *) a. Monad m => a -> m a
return ()

-- used at least by RTS in 'select()' IO manager backend
blockedOnBadFD :: SomeException
blockedOnBadFD :: SomeException
blockedOnBadFD = IOError -> SomeException
forall e. Exception e => e -> SomeException
toException (IOError -> SomeException) -> IOError -> SomeException
forall a b. (a -> b) -> a -> b
$ String -> Errno -> Maybe Handle -> Maybe String -> IOError
errnoToIOError String
"awaitEvent" Errno
eBADF Maybe Handle
forall a. Maybe a
Nothing Maybe String
forall a. Maybe a
Nothing

threadWaitSTM :: Event -> Fd -> IO (STM (), IO ())
threadWaitSTM :: Event -> Fd -> IO (STM (), IO ())
threadWaitSTM Event
evt Fd
fd = IO (STM (), IO ()) -> IO (STM (), IO ())
forall a. IO a -> IO a
mask_ (IO (STM (), IO ()) -> IO (STM (), IO ()))
-> IO (STM (), IO ()) -> IO (STM (), IO ())
forall a b. (a -> b) -> a -> b
$ do
  TVar (Maybe Event)
m <- Maybe Event -> IO (TVar (Maybe Event))
forall a. a -> IO (TVar a)
newTVarIO Maybe Event
forall a. Maybe a
Nothing
  EventManager
mgr <- IO EventManager
getSystemEventManager_
  FdKey
reg <- EventManager -> IOCallback -> Fd -> Event -> Lifetime -> IO FdKey
registerFd EventManager
mgr (\FdKey
_ Event
e -> STM () -> IO ()
forall a. STM a -> IO a
atomically (TVar (Maybe Event) -> Maybe Event -> STM ()
forall a. TVar a -> a -> STM ()
writeTVar TVar (Maybe Event)
m (Event -> Maybe Event
forall a. a -> Maybe a
Just Event
e))) Fd
fd Event
evt Lifetime
M.OneShot
  let waitAction :: STM ()
waitAction =
        do Maybe Event
mevt <- TVar (Maybe Event) -> STM (Maybe Event)
forall a. TVar a -> STM a
readTVar TVar (Maybe Event)
m
           case Maybe Event
mevt of
             Maybe Event
Nothing -> STM ()
forall a. STM a
retry
             Just Event
evt' ->
               if Event
evt' Event -> Event -> Bool
`eventIs` Event
evtClose
               then IOError -> STM ()
forall e a. Exception e => e -> STM a
throwSTM (IOError -> STM ()) -> IOError -> STM ()
forall a b. (a -> b) -> a -> b
$ String -> Errno -> Maybe Handle -> Maybe String -> IOError
errnoToIOError String
"threadWaitSTM" Errno
eBADF Maybe Handle
forall a. Maybe a
Nothing Maybe String
forall a. Maybe a
Nothing
               else () -> STM ()
forall (m :: * -> *) a. Monad m => a -> m a
return ()
  (STM (), IO ()) -> IO (STM (), IO ())
forall (m :: * -> *) a. Monad m => a -> m a
return (STM ()
waitAction, EventManager -> FdKey -> IO Bool
unregisterFd_ EventManager
mgr FdKey
reg IO Bool -> IO () -> IO ()
forall (m :: * -> *) a b. Monad m => m a -> m b -> m b
>> () -> IO ()
forall (m :: * -> *) a. Monad m => a -> m a
return ())

-- | Allows a thread to use an STM action to wait for a file descriptor to be readable.
-- The STM action will retry until the file descriptor has data ready.
-- The second element of the return value pair is an IO action that can be used
-- to deregister interest in the file descriptor.
--
-- The STM action will throw an 'Prelude.IOError' if the file descriptor was closed
-- while the STM action is being executed.  To safely close a file descriptor
-- that has been used with 'threadWaitReadSTM', use 'closeFdWith'.
threadWaitReadSTM :: Fd -> IO (STM (), IO ())
threadWaitReadSTM :: Fd -> IO (STM (), IO ())
threadWaitReadSTM = Event -> Fd -> IO (STM (), IO ())
threadWaitSTM Event
evtRead
{-# INLINE threadWaitReadSTM #-}

-- | Allows a thread to use an STM action to wait until a file descriptor can accept a write.
-- The STM action will retry while the file until the given file descriptor can accept a write.
-- The second element of the return value pair is an IO action that can be used to deregister
-- interest in the file descriptor.
--
-- The STM action will throw an 'Prelude.IOError' if the file descriptor was closed
-- while the STM action is being executed.  To safely close a file descriptor
-- that has been used with 'threadWaitWriteSTM', use 'closeFdWith'.
threadWaitWriteSTM :: Fd -> IO (STM (), IO ())
threadWaitWriteSTM :: Fd -> IO (STM (), IO ())
threadWaitWriteSTM = Event -> Fd -> IO (STM (), IO ())
threadWaitSTM Event
evtWrite
{-# INLINE threadWaitWriteSTM #-}


-- | Retrieve the system event manager for the capability on which the
-- calling thread is running.
--
-- This function always returns 'Just' the current thread's event manager
-- when using the threaded RTS and 'Nothing' otherwise.
getSystemEventManager :: IO (Maybe EventManager)
getSystemEventManager :: IO (Maybe EventManager)
getSystemEventManager = do
  ThreadId
t <- IO ThreadId
myThreadId
  (Int
cap, Bool
_) <- ThreadId -> IO (Int, Bool)
threadCapability ThreadId
t
  IOArray Int (Maybe (ThreadId, EventManager))
eventManagerArray <- IORef (IOArray Int (Maybe (ThreadId, EventManager)))
-> IO (IOArray Int (Maybe (ThreadId, EventManager)))
forall a. IORef a -> IO a
readIORef IORef (IOArray Int (Maybe (ThreadId, EventManager)))
eventManager
  Maybe (ThreadId, EventManager)
mmgr <- IOArray Int (Maybe (ThreadId, EventManager))
-> Int -> IO (Maybe (ThreadId, EventManager))
forall i e. Ix i => IOArray i e -> i -> IO e
readIOArray IOArray Int (Maybe (ThreadId, EventManager))
eventManagerArray Int
cap
  Maybe EventManager -> IO (Maybe EventManager)
forall (m :: * -> *) a. Monad m => a -> m a
return (Maybe EventManager -> IO (Maybe EventManager))
-> Maybe EventManager -> IO (Maybe EventManager)
forall a b. (a -> b) -> a -> b
$ ((ThreadId, EventManager) -> EventManager)
-> Maybe (ThreadId, EventManager) -> Maybe EventManager
forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
fmap (ThreadId, EventManager) -> EventManager
forall a b. (a, b) -> b
snd Maybe (ThreadId, EventManager)
mmgr

getSystemEventManager_ :: IO EventManager
getSystemEventManager_ :: IO EventManager
getSystemEventManager_ = do
  Just EventManager
mgr <- IO (Maybe EventManager)
getSystemEventManager
  EventManager -> IO EventManager
forall (m :: * -> *) a. Monad m => a -> m a
return EventManager
mgr
{-# INLINE getSystemEventManager_ #-}

foreign import ccall unsafe "getOrSetSystemEventThreadEventManagerStore"
    getOrSetSystemEventThreadEventManagerStore :: Ptr a -> IO (Ptr a)

eventManager :: IORef (IOArray Int (Maybe (ThreadId, EventManager)))
eventManager :: IORef (IOArray Int (Maybe (ThreadId, EventManager)))
eventManager = IO (IORef (IOArray Int (Maybe (ThreadId, EventManager))))
-> IORef (IOArray Int (Maybe (ThreadId, EventManager)))
forall a. IO a -> a
unsafePerformIO (IO (IORef (IOArray Int (Maybe (ThreadId, EventManager))))
 -> IORef (IOArray Int (Maybe (ThreadId, EventManager))))
-> IO (IORef (IOArray Int (Maybe (ThreadId, EventManager))))
-> IORef (IOArray Int (Maybe (ThreadId, EventManager)))
forall a b. (a -> b) -> a -> b
$ do
    Int
numCaps <- IO Int
getNumCapabilities
    IOArray Int (Maybe (ThreadId, EventManager))
eventManagerArray <- (Int, Int)
-> Maybe (ThreadId, EventManager)
-> IO (IOArray Int (Maybe (ThreadId, EventManager)))
forall i e. Ix i => (i, i) -> e -> IO (IOArray i e)
newIOArray (Int
0, Int
numCaps Int -> Int -> Int
forall a. Num a => a -> a -> a
- Int
1) Maybe (ThreadId, EventManager)
forall a. Maybe a
Nothing
    IORef (IOArray Int (Maybe (ThreadId, EventManager)))
em <- IOArray Int (Maybe (ThreadId, EventManager))
-> IO (IORef (IOArray Int (Maybe (ThreadId, EventManager))))
forall a. a -> IO (IORef a)
newIORef IOArray Int (Maybe (ThreadId, EventManager))
eventManagerArray
    IORef (IOArray Int (Maybe (ThreadId, EventManager)))
-> (Ptr (IORef (IOArray Int (Maybe (ThreadId, EventManager))))
    -> IO (Ptr (IORef (IOArray Int (Maybe (ThreadId, EventManager))))))
-> IO (IORef (IOArray Int (Maybe (ThreadId, EventManager))))
forall a. a -> (Ptr a -> IO (Ptr a)) -> IO a
sharedCAF IORef (IOArray Int (Maybe (ThreadId, EventManager)))
em Ptr (IORef (IOArray Int (Maybe (ThreadId, EventManager))))
-> IO (Ptr (IORef (IOArray Int (Maybe (ThreadId, EventManager)))))
forall a. Ptr a -> IO (Ptr a)
getOrSetSystemEventThreadEventManagerStore
{-# NOINLINE eventManager #-}

numEnabledEventManagers :: IORef Int
numEnabledEventManagers :: IORef Int
numEnabledEventManagers = IO (IORef Int) -> IORef Int
forall a. IO a -> a
unsafePerformIO (IO (IORef Int) -> IORef Int) -> IO (IORef Int) -> IORef Int
forall a b. (a -> b) -> a -> b
$ do
  Int -> IO (IORef Int)
forall a. a -> IO (IORef a)
newIORef Int
0
{-# NOINLINE numEnabledEventManagers #-}

foreign import ccall unsafe "getOrSetSystemEventThreadIOManagerThreadStore"
    getOrSetSystemEventThreadIOManagerThreadStore :: Ptr a -> IO (Ptr a)

-- | The ioManagerLock protects the 'eventManager' value:
-- Only one thread at a time can start or shutdown event managers.
{-# NOINLINE ioManagerLock #-}
ioManagerLock :: MVar ()
ioManagerLock :: MVar ()
ioManagerLock = IO (MVar ()) -> MVar ()
forall a. IO a -> a
unsafePerformIO (IO (MVar ()) -> MVar ()) -> IO (MVar ()) -> MVar ()
forall a b. (a -> b) -> a -> b
$ do
   MVar ()
m <- () -> IO (MVar ())
forall a. a -> IO (MVar a)
newMVar ()
   MVar () -> (Ptr (MVar ()) -> IO (Ptr (MVar ()))) -> IO (MVar ())
forall a. a -> (Ptr a -> IO (Ptr a)) -> IO a
sharedCAF MVar ()
m Ptr (MVar ()) -> IO (Ptr (MVar ()))
forall a. Ptr a -> IO (Ptr a)
getOrSetSystemEventThreadIOManagerThreadStore

getSystemTimerManager :: IO TM.TimerManager
getSystemTimerManager :: IO TimerManager
getSystemTimerManager = do
  Just TimerManager
mgr <- IORef (Maybe TimerManager) -> IO (Maybe TimerManager)
forall a. IORef a -> IO a
readIORef IORef (Maybe TimerManager)
timerManager
  TimerManager -> IO TimerManager
forall (m :: * -> *) a. Monad m => a -> m a
return TimerManager
mgr

foreign import ccall unsafe "getOrSetSystemTimerThreadEventManagerStore"
    getOrSetSystemTimerThreadEventManagerStore :: Ptr a -> IO (Ptr a)

timerManager :: IORef (Maybe TM.TimerManager)
timerManager :: IORef (Maybe TimerManager)
timerManager = IO (IORef (Maybe TimerManager)) -> IORef (Maybe TimerManager)
forall a. IO a -> a
unsafePerformIO (IO (IORef (Maybe TimerManager)) -> IORef (Maybe TimerManager))
-> IO (IORef (Maybe TimerManager)) -> IORef (Maybe TimerManager)
forall a b. (a -> b) -> a -> b
$ do
    IORef (Maybe TimerManager)
em <- Maybe TimerManager -> IO (IORef (Maybe TimerManager))
forall a. a -> IO (IORef a)
newIORef Maybe TimerManager
forall a. Maybe a
Nothing
    IORef (Maybe TimerManager)
-> (Ptr (IORef (Maybe TimerManager))
    -> IO (Ptr (IORef (Maybe TimerManager))))
-> IO (IORef (Maybe TimerManager))
forall a. a -> (Ptr a -> IO (Ptr a)) -> IO a
sharedCAF IORef (Maybe TimerManager)
em Ptr (IORef (Maybe TimerManager))
-> IO (Ptr (IORef (Maybe TimerManager)))
forall a. Ptr a -> IO (Ptr a)
getOrSetSystemTimerThreadEventManagerStore
{-# NOINLINE timerManager #-}

foreign import ccall unsafe "getOrSetSystemTimerThreadIOManagerThreadStore"
    getOrSetSystemTimerThreadIOManagerThreadStore :: Ptr a -> IO (Ptr a)

{-# NOINLINE timerManagerThreadVar #-}
timerManagerThreadVar :: MVar (Maybe ThreadId)
timerManagerThreadVar :: MVar (Maybe ThreadId)
timerManagerThreadVar = IO (MVar (Maybe ThreadId)) -> MVar (Maybe ThreadId)
forall a. IO a -> a
unsafePerformIO (IO (MVar (Maybe ThreadId)) -> MVar (Maybe ThreadId))
-> IO (MVar (Maybe ThreadId)) -> MVar (Maybe ThreadId)
forall a b. (a -> b) -> a -> b
$ do
   MVar (Maybe ThreadId)
m <- Maybe ThreadId -> IO (MVar (Maybe ThreadId))
forall a. a -> IO (MVar a)
newMVar Maybe ThreadId
forall a. Maybe a
Nothing
   MVar (Maybe ThreadId)
-> (Ptr (MVar (Maybe ThreadId))
    -> IO (Ptr (MVar (Maybe ThreadId))))
-> IO (MVar (Maybe ThreadId))
forall a. a -> (Ptr a -> IO (Ptr a)) -> IO a
sharedCAF MVar (Maybe ThreadId)
m Ptr (MVar (Maybe ThreadId)) -> IO (Ptr (MVar (Maybe ThreadId)))
forall a. Ptr a -> IO (Ptr a)
getOrSetSystemTimerThreadIOManagerThreadStore

ensureIOManagerIsRunning :: IO ()
ensureIOManagerIsRunning :: IO ()
ensureIOManagerIsRunning
  | Bool -> Bool
not Bool
threaded = () -> IO ()
forall (m :: * -> *) a. Monad m => a -> m a
return ()
  | Bool
otherwise = do
      IO ()
startIOManagerThreads
      IO ()
startTimerManagerThread

startIOManagerThreads :: IO ()
startIOManagerThreads :: IO ()
startIOManagerThreads =
  MVar () -> (() -> IO ()) -> IO ()
forall a b. MVar a -> (a -> IO b) -> IO b
withMVar MVar ()
ioManagerLock ((() -> IO ()) -> IO ()) -> (() -> IO ()) -> IO ()
forall a b. (a -> b) -> a -> b
$ \()
_ -> do
    IOArray Int (Maybe (ThreadId, EventManager))
eventManagerArray <- IORef (IOArray Int (Maybe (ThreadId, EventManager)))
-> IO (IOArray Int (Maybe (ThreadId, EventManager)))
forall a. IORef a -> IO a
readIORef IORef (IOArray Int (Maybe (ThreadId, EventManager)))
eventManager
    let (Int
_, Int
high) = IOArray Int (Maybe (ThreadId, EventManager)) -> (Int, Int)
forall i e. IOArray i e -> (i, i)
boundsIOArray IOArray Int (Maybe (ThreadId, EventManager))
eventManagerArray
    (Int -> IO ()) -> [Int] -> IO ()
forall (t :: * -> *) (m :: * -> *) a b.
(Foldable t, Monad m) =>
(a -> m b) -> t a -> m ()
mapM_ (IOArray Int (Maybe (ThreadId, EventManager)) -> Int -> IO ()
startIOManagerThread IOArray Int (Maybe (ThreadId, EventManager))
eventManagerArray) [Int
0..Int
high]
    IORef Int -> Int -> IO ()
forall a. IORef a -> a -> IO ()
writeIORef IORef Int
numEnabledEventManagers (Int
highInt -> Int -> Int
forall a. Num a => a -> a -> a
+Int
1)

show_int :: Int -> String
show_int :: Int -> String
show_int Int
i = Int -> Int -> ShowS
showSignedInt Int
0 Int
i String
""

restartPollLoop :: EventManager -> Int -> IO ThreadId
restartPollLoop :: EventManager -> Int -> IO ThreadId
restartPollLoop EventManager
mgr Int
i = do
  EventManager -> IO ()
M.release EventManager
mgr
  !ThreadId
t <- Int -> IO () -> IO ThreadId
forkOn Int
i (IO () -> IO ThreadId) -> IO () -> IO ThreadId
forall a b. (a -> b) -> a -> b
$ EventManager -> IO ()
loop EventManager
mgr
  ThreadId -> String -> IO ()
labelThread ThreadId
t (String
"IOManager on cap " String -> ShowS
forall a. [a] -> [a] -> [a]
++ Int -> String
show_int Int
i)
  ThreadId -> IO ThreadId
forall (m :: * -> *) a. Monad m => a -> m a
return ThreadId
t

startIOManagerThread :: IOArray Int (Maybe (ThreadId, EventManager))
                        -> Int
                        -> IO ()
startIOManagerThread :: IOArray Int (Maybe (ThreadId, EventManager)) -> Int -> IO ()
startIOManagerThread IOArray Int (Maybe (ThreadId, EventManager))
eventManagerArray Int
i = do
  let create :: IO ()
create = do
        !EventManager
mgr <- IO EventManager
new
        !ThreadId
t <- Int -> IO () -> IO ThreadId
forkOn Int
i (IO () -> IO ThreadId) -> IO () -> IO ThreadId
forall a b. (a -> b) -> a -> b
$ do
                CUInt -> CInt -> IO ()
c_setIOManagerControlFd
                  (Int -> CUInt
forall a b. (Integral a, Num b) => a -> b
fromIntegral Int
i)
                  (Fd -> CInt
forall a b. (Integral a, Num b) => a -> b
fromIntegral (Fd -> CInt) -> Fd -> CInt
forall a b. (a -> b) -> a -> b
$ Control -> Fd
controlWriteFd (Control -> Fd) -> Control -> Fd
forall a b. (a -> b) -> a -> b
$ EventManager -> Control
M.emControl EventManager
mgr)
                EventManager -> IO ()
loop EventManager
mgr
        ThreadId -> String -> IO ()
labelThread ThreadId
t (String
"IOManager on cap " String -> ShowS
forall a. [a] -> [a] -> [a]
++ Int -> String
show_int Int
i)
        IOArray Int (Maybe (ThreadId, EventManager))
-> Int -> Maybe (ThreadId, EventManager) -> IO ()
forall i e. Ix i => IOArray i e -> i -> e -> IO ()
writeIOArray IOArray Int (Maybe (ThreadId, EventManager))
eventManagerArray Int
i ((ThreadId, EventManager) -> Maybe (ThreadId, EventManager)
forall a. a -> Maybe a
Just (ThreadId
t,EventManager
mgr))
  Maybe (ThreadId, EventManager)
old <- IOArray Int (Maybe (ThreadId, EventManager))
-> Int -> IO (Maybe (ThreadId, EventManager))
forall i e. Ix i => IOArray i e -> i -> IO e
readIOArray IOArray Int (Maybe (ThreadId, EventManager))
eventManagerArray Int
i
  case Maybe (ThreadId, EventManager)
old of
    Maybe (ThreadId, EventManager)
Nothing     -> IO ()
create
    Just (ThreadId
t,EventManager
em) -> do
      ThreadStatus
s <- ThreadId -> IO ThreadStatus
threadStatus ThreadId
t
      case ThreadStatus
s of
        ThreadStatus
ThreadFinished -> IO ()
create
        ThreadStatus
ThreadDied     -> do
          -- Sanity check: if the thread has died, there is a chance
          -- that event manager is still alive. This could happened during
          -- the fork, for example. In this case we should clean up
          -- open pipes and everything else related to the event manager.
          -- See #4449
          CUInt -> CInt -> IO ()
c_setIOManagerControlFd (Int -> CUInt
forall a b. (Integral a, Num b) => a -> b
fromIntegral Int
i) (-CInt
1)
          EventManager -> IO ()
M.cleanup EventManager
em
          IO ()
create
        ThreadStatus
_other         -> () -> IO ()
forall (m :: * -> *) a. Monad m => a -> m a
return ()

startTimerManagerThread :: IO ()
startTimerManagerThread :: IO ()
startTimerManagerThread = MVar (Maybe ThreadId)
-> (Maybe ThreadId -> IO (Maybe ThreadId)) -> IO ()
forall a. MVar a -> (a -> IO a) -> IO ()
modifyMVar_ MVar (Maybe ThreadId)
timerManagerThreadVar ((Maybe ThreadId -> IO (Maybe ThreadId)) -> IO ())
-> (Maybe ThreadId -> IO (Maybe ThreadId)) -> IO ()
forall a b. (a -> b) -> a -> b
$ \Maybe ThreadId
old -> do
  let create :: IO (Maybe ThreadId)
create = do
        !TimerManager
mgr <- IO TimerManager
TM.new
        CInt -> IO ()
c_setTimerManagerControlFd
          (Fd -> CInt
forall a b. (Integral a, Num b) => a -> b
fromIntegral (Fd -> CInt) -> Fd -> CInt
forall a b. (a -> b) -> a -> b
$ Control -> Fd
controlWriteFd (Control -> Fd) -> Control -> Fd
forall a b. (a -> b) -> a -> b
$ TimerManager -> Control
TM.emControl TimerManager
mgr)
        IORef (Maybe TimerManager) -> Maybe TimerManager -> IO ()
forall a. IORef a -> a -> IO ()
writeIORef IORef (Maybe TimerManager)
timerManager (Maybe TimerManager -> IO ()) -> Maybe TimerManager -> IO ()
forall a b. (a -> b) -> a -> b
$ TimerManager -> Maybe TimerManager
forall a. a -> Maybe a
Just TimerManager
mgr
        !ThreadId
t <- IO () -> IO ThreadId
forkIO (IO () -> IO ThreadId) -> IO () -> IO ThreadId
forall a b. (a -> b) -> a -> b
$ TimerManager -> IO ()
TM.loop TimerManager
mgr
        ThreadId -> String -> IO ()
labelThread ThreadId
t String
"TimerManager"
        Maybe ThreadId -> IO (Maybe ThreadId)
forall (m :: * -> *) a. Monad m => a -> m a
return (Maybe ThreadId -> IO (Maybe ThreadId))
-> Maybe ThreadId -> IO (Maybe ThreadId)
forall a b. (a -> b) -> a -> b
$ ThreadId -> Maybe ThreadId
forall a. a -> Maybe a
Just ThreadId
t
  case Maybe ThreadId
old of
    Maybe ThreadId
Nothing            -> IO (Maybe ThreadId)
create
    st :: Maybe ThreadId
st@(Just ThreadId
t) -> do
      ThreadStatus
s <- ThreadId -> IO ThreadStatus
threadStatus ThreadId
t
      case ThreadStatus
s of
        ThreadStatus
ThreadFinished -> IO (Maybe ThreadId)
create
        ThreadStatus
ThreadDied     -> do
          -- Sanity check: if the thread has died, there is a chance
          -- that event manager is still alive. This could happened during
          -- the fork, for example. In this case we should clean up
          -- open pipes and everything else related to the event manager.
          -- See #4449
          Maybe TimerManager
mem <- IORef (Maybe TimerManager) -> IO (Maybe TimerManager)
forall a. IORef a -> IO a
readIORef IORef (Maybe TimerManager)
timerManager
          ()
_ <- case Maybe TimerManager
mem of
                 Maybe TimerManager
Nothing -> () -> IO ()
forall (m :: * -> *) a. Monad m => a -> m a
return ()
                 Just TimerManager
em -> do CInt -> IO ()
c_setTimerManagerControlFd (-CInt
1)
                               TimerManager -> IO ()
TM.cleanup TimerManager
em
          IO (Maybe ThreadId)
create
        ThreadStatus
_other         -> Maybe ThreadId -> IO (Maybe ThreadId)
forall (m :: * -> *) a. Monad m => a -> m a
return Maybe ThreadId
st

foreign import ccall unsafe "rtsSupportsBoundThreads" threaded :: Bool

ioManagerCapabilitiesChanged :: IO ()
ioManagerCapabilitiesChanged :: IO ()
ioManagerCapabilitiesChanged = do
  MVar () -> (() -> IO ()) -> IO ()
forall a b. MVar a -> (a -> IO b) -> IO b
withMVar MVar ()
ioManagerLock ((() -> IO ()) -> IO ()) -> (() -> IO ()) -> IO ()
forall a b. (a -> b) -> a -> b
$ \()
_ -> do
    Int
new_n_caps <- IO Int
getNumCapabilities
    Int
numEnabled <- IORef Int -> IO Int
forall a. IORef a -> IO a
readIORef IORef Int
numEnabledEventManagers
    IORef Int -> Int -> IO ()
forall a. IORef a -> a -> IO ()
writeIORef IORef Int
numEnabledEventManagers Int
new_n_caps
    IOArray Int (Maybe (ThreadId, EventManager))
eventManagerArray <- IORef (IOArray Int (Maybe (ThreadId, EventManager)))
-> IO (IOArray Int (Maybe (ThreadId, EventManager)))
forall a. IORef a -> IO a
readIORef IORef (IOArray Int (Maybe (ThreadId, EventManager)))
eventManager
    let (Int
_, Int
high) = IOArray Int (Maybe (ThreadId, EventManager)) -> (Int, Int)
forall i e. IOArray i e -> (i, i)
boundsIOArray IOArray Int (Maybe (ThreadId, EventManager))
eventManagerArray
    let old_n_caps :: Int
old_n_caps = Int
high Int -> Int -> Int
forall a. Num a => a -> a -> a
+ Int
1
    if Int
new_n_caps Int -> Int -> Bool
forall a. Ord a => a -> a -> Bool
> Int
old_n_caps
      then do IOArray Int (Maybe (ThreadId, EventManager))
new_eventManagerArray <- (Int, Int)
-> Maybe (ThreadId, EventManager)
-> IO (IOArray Int (Maybe (ThreadId, EventManager)))
forall i e. Ix i => (i, i) -> e -> IO (IOArray i e)
newIOArray (Int
0, Int
new_n_caps Int -> Int -> Int
forall a. Num a => a -> a -> a
- Int
1) Maybe (ThreadId, EventManager)
forall a. Maybe a
Nothing

              -- copy the existing values into the new array:
              [Int] -> (Int -> IO ()) -> IO ()
forall (t :: * -> *) (m :: * -> *) a b.
(Foldable t, Monad m) =>
t a -> (a -> m b) -> m ()
forM_ [Int
0..Int
high] ((Int -> IO ()) -> IO ()) -> (Int -> IO ()) -> IO ()
forall a b. (a -> b) -> a -> b
$ \Int
i -> do
                Just (ThreadId
tid,EventManager
mgr) <- IOArray Int (Maybe (ThreadId, EventManager))
-> Int -> IO (Maybe (ThreadId, EventManager))
forall i e. Ix i => IOArray i e -> i -> IO e
readIOArray IOArray Int (Maybe (ThreadId, EventManager))
eventManagerArray Int
i
                if Int
i Int -> Int -> Bool
forall a. Ord a => a -> a -> Bool
< Int
numEnabled
                  then IOArray Int (Maybe (ThreadId, EventManager))
-> Int -> Maybe (ThreadId, EventManager) -> IO ()
forall i e. Ix i => IOArray i e -> i -> e -> IO ()
writeIOArray IOArray Int (Maybe (ThreadId, EventManager))
new_eventManagerArray Int
i ((ThreadId, EventManager) -> Maybe (ThreadId, EventManager)
forall a. a -> Maybe a
Just (ThreadId
tid,EventManager
mgr))
                  else do ThreadId
tid' <- EventManager -> Int -> IO ThreadId
restartPollLoop EventManager
mgr Int
i
                          IOArray Int (Maybe (ThreadId, EventManager))
-> Int -> Maybe (ThreadId, EventManager) -> IO ()
forall i e. Ix i => IOArray i e -> i -> e -> IO ()
writeIOArray IOArray Int (Maybe (ThreadId, EventManager))
new_eventManagerArray Int
i ((ThreadId, EventManager) -> Maybe (ThreadId, EventManager)
forall a. a -> Maybe a
Just (ThreadId
tid',EventManager
mgr))

              -- create new IO managers for the new caps:
              [Int] -> (Int -> IO ()) -> IO ()
forall (t :: * -> *) (m :: * -> *) a b.
(Foldable t, Monad m) =>
t a -> (a -> m b) -> m ()
forM_ [Int
old_n_caps..Int
new_n_capsInt -> Int -> Int
forall a. Num a => a -> a -> a
-Int
1] ((Int -> IO ()) -> IO ()) -> (Int -> IO ()) -> IO ()
forall a b. (a -> b) -> a -> b
$
                IOArray Int (Maybe (ThreadId, EventManager)) -> Int -> IO ()
startIOManagerThread IOArray Int (Maybe (ThreadId, EventManager))
new_eventManagerArray

              -- update the event manager array reference:
              IORef (IOArray Int (Maybe (ThreadId, EventManager)))
-> IOArray Int (Maybe (ThreadId, EventManager)) -> IO ()
forall a. IORef a -> a -> IO ()
writeIORef IORef (IOArray Int (Maybe (ThreadId, EventManager)))
eventManager IOArray Int (Maybe (ThreadId, EventManager))
new_eventManagerArray
      else Bool -> IO () -> IO ()
forall (f :: * -> *). Applicative f => Bool -> f () -> f ()
when (Int
new_n_caps Int -> Int -> Bool
forall a. Ord a => a -> a -> Bool
> Int
numEnabled) (IO () -> IO ()) -> IO () -> IO ()
forall a b. (a -> b) -> a -> b
$
            [Int] -> (Int -> IO ()) -> IO ()
forall (t :: * -> *) (m :: * -> *) a b.
(Foldable t, Monad m) =>
t a -> (a -> m b) -> m ()
forM_ [Int
numEnabled..Int
new_n_capsInt -> Int -> Int
forall a. Num a => a -> a -> a
-Int
1] ((Int -> IO ()) -> IO ()) -> (Int -> IO ()) -> IO ()
forall a b. (a -> b) -> a -> b
$ \Int
i -> do
              Just (ThreadId
_,EventManager
mgr) <- IOArray Int (Maybe (ThreadId, EventManager))
-> Int -> IO (Maybe (ThreadId, EventManager))
forall i e. Ix i => IOArray i e -> i -> IO e
readIOArray IOArray Int (Maybe (ThreadId, EventManager))
eventManagerArray Int
i
              ThreadId
tid <- EventManager -> Int -> IO ThreadId
restartPollLoop EventManager
mgr Int
i
              IOArray Int (Maybe (ThreadId, EventManager))
-> Int -> Maybe (ThreadId, EventManager) -> IO ()
forall i e. Ix i => IOArray i e -> i -> e -> IO ()
writeIOArray IOArray Int (Maybe (ThreadId, EventManager))
eventManagerArray Int
i ((ThreadId, EventManager) -> Maybe (ThreadId, EventManager)
forall a. a -> Maybe a
Just (ThreadId
tid,EventManager
mgr))

-- Used to tell the RTS how it can send messages to the I/O manager.
foreign import ccall unsafe "setIOManagerControlFd"
   c_setIOManagerControlFd :: CUInt -> CInt -> IO ()

foreign import ccall unsafe "setTimerManagerControlFd"
   c_setTimerManagerControlFd :: CInt -> IO ()