    {-# 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 ()