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

    #include <ghcplatform.h>

    module GHC.Internal.Event.Thread
    #if defined(javascript_HOST_ARCH)
        ( ) where

    -- See W1 of Note [Tracking dependencies on primitives] in GHC.Internal.Base
    import GHC.Internal.Types ()

    #else
        ( getSystemEventManager
        , getSystemTimerManager
        , ensureIOManagerIsRunning
        , ioManagerCapabilitiesChanged
        , threadWaitRead
        , threadWaitWrite
        , threadWaitReadSTM
        , threadWaitWriteSTM
        , closeFdWith
        , threadDelay
        , registerDelay
        , blockedOnBadFD -- used by RTS
        ) where

    -- TODO: Use new Windows I/O manager
    import GHC.Internal.Control.Exception (finally, SomeException, toException)
    import GHC.Internal.Data.Foldable (forM_, mapM_, sequence_)
    import GHC.Internal.Data.IORef (IORef, newIORef, readIORef, writeIORef, atomicWriteIORef)
    import GHC.Internal.Data.Maybe (fromMaybe)
    import GHC.Internal.Data.Tuple (snd)
    import GHC.Internal.Foreign.C.Error (eBADF, errnoToIOError)
    import GHC.Internal.Foreign.C.Types (CInt(..), CUInt(..))
    import GHC.Internal.Foreign.Ptr (Ptr)
    import GHC.Internal.Base
    import GHC.Internal.List (zipWith, zipWith3)
    import GHC.Internal.Conc.Sync (TVar, ThreadId, ThreadStatus(..), atomically, forkIO,
                          labelThread, modifyMVar_, withMVar, newTVar, sharedCAF,
                          getNumCapabilities, threadCapability, myThreadId, forkOn,
                          threadStatus, writeTVar, newTVarIO, readTVar, retry,
                          throwSTM, STM, yield)
    import GHC.Internal.IO (mask_, uninterruptibleMask_, onException)
    import GHC.Internal.IO.Exception (ioError)
    import GHC.Internal.IOArray (IOArray, newIOArray, readIOArray, writeIOArray,
                        boundsIOArray)
    import GHC.Internal.MVar (MVar, newEmptyMVar, newMVar, putMVar, takeMVar)
    import GHC.Internal.Event.Control (controlWriteFd)
    import GHC.Internal.Event.Internal (eventIs, evtClose)
    import GHC.Internal.Event.Manager (Event, EventManager, evtRead, evtWrite, loop,
                                 new, registerFd, unregisterFd_)
    import qualified GHC.Internal.Event.Manager as M
    import qualified GHC.Internal.Event.TimerManager as TM
    import GHC.Internal.Ix (inRange)
    import GHC.Internal.Num ((-), (+))
    import GHC.Internal.Real (fromIntegral)
    import GHC.Internal.Show (showSignedInt)
    import GHC.Internal.IO.Unsafe (unsafePerformIO)
    import GHC.Internal.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.
    --
    -- Be careful not to exceed @maxBound :: Int@, which on 32-bit machines is only
    -- 2147483647 μs, less than 36 minutes.
    --
    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
      mgr <- IO TimerManager
    getSystemTimerManager
      m <- newEmptyMVar
      reg <- TM.registerTimeout mgr usecs (putMVar m ())
      takeMVar m `onException` TM.unregisterTimeout mgr reg

    -- | Set the value of returned TVar to True after a given number of
    -- microseconds. The caveats associated with threadDelay also apply.
    --
    -- Be careful not to exceed @maxBound :: Int@, which on 32-bit machines is only
    -- 2147483647 μs, less than 36 minutes.
    --
    registerDelay :: Int -> IO (TVar Bool)
    registerDelay :: Int -> IO (TVar Bool)
    registerDelay Int
    usecs = do
      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
      mgr <- getSystemTimerManager
      _ <- TM.registerTimeout mgr usecs . atomically $ writeTVar t True
      return 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.
    --
    -- Closing file descriptors on one thread while they are still being
    -- used by other threads is always prone to race conditions (since e.g.
    -- on Linux file descriptors can be immediately reused after closing).
    --
    -- It is recommended to only call @'closeFdWith'@ when the file descriptor
    -- can no longer be used by other threads.
    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 = IO ()
    close_loop
      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 a b. IO a -> IO b -> IO b
    forall (m :: * -> *) a b. Monad m => m a -> m b -> m b
    >> IO b
    cbApp
        zipWithM :: (t -> t -> m a) -> [t] -> [t] -> m [a]
    zipWithM t -> t -> m a
    f [t]
    xs [t]
    ys = [m a] -> m [a]
    forall (m :: * -> *) a. Monad m => [m a] -> m [a]
    sequence ((t -> t -> m a) -> [t] -> [t] -> [m a]
    forall a b c. (a -> b -> c) -> [a] -> [b] -> [c]
    zipWith t -> t -> m a
    f [t]
    xs [t]
    ys)
          -- The array inside 'eventManager' can be swapped out at any time, see
          -- 'ioManagerCapabilitiesChanged'. See #21651. We detect this case by
          -- checking the array bounds before and after. When such a swap has
          -- happened we cleanup and try again
        close_loop :: IO ()
    close_loop = do
          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 ema_bounds@(low, high) = boundsIOArray eventManagerArray
          mgrs <- flip mapM [low..high] $ \Int
    i -> do
            Just (_,!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
            return mgr

          -- 'takeMVar', and 'M.closeFd_' might block, although for a very short time.
          -- To make 'closeFdWith' safe in presence of asynchronous exceptions we have
          -- to use uninterruptible mask.
          join $ uninterruptibleMask_ $ do
            tables <- flip mapM mgrs $ \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
            new_ema_bounds <- boundsIOArray `fmap` readIORef eventManager
            -- Here we exploit Note [The eventManager Array]
            if new_ema_bounds /= ema_bounds
              then do
                -- the array has been modified.
                -- mgrs still holds the right EventManagers, by the Note.
                -- new_ema_bounds must be larger than ema_bounds, by the note.
                -- return the MVars we took and try again
                sequence_ $ zipWith (\EventManager
    mgr IntTable [FdData]
    table -> EventManager -> IntTable [FdData] -> IO () -> IO ()
    forall {b}. EventManager -> IntTable [FdData] -> IO b -> IO b
    finish EventManager
    mgr IntTable [FdData]
    table (() -> IO ()
    forall a. a -> IO a
    forall (f :: * -> *) a. Applicative f => a -> f a
    pure ())) mgrs tables
                pure close_loop
              else do
                -- We surely have taken all the appropriate MVars. Even if the array
                -- has been swapped, our mgrs is still correct.
                -- Remove the Fd from all callback tables, close the Fd, and run all
                -- callbacks.
                cbApps <- zipWithM (\EventManager
    mgr IntTable [FdData]
    table -> EventManager -> IntTable [FdData] -> Fd -> IO (IO ())
    M.closeFd_ EventManager
    mgr IntTable [FdData]
    table Fd
    fd) mgrs tables
                close fd `finally` sequence_ (zipWith3 finish mgrs tables cbApps)
                pure (pure ())

    -- | Wait for an event on a file descriptor.
    --
    -- The given @'Event'@ may only be (a combination of) @'evtRead'@ or
    -- @'evtWrite'@, but not @'evtClose'@. See @'evtClose'@ for more details.
    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
      m <- IO (MVar Event)
    forall a. IO (MVar a)
    newEmptyMVar
      mgr <- getSystemEventManager_
      reg <- registerFd mgr (\FdKey
    _ Event
    e -> MVar Event -> Event -> IO ()
    forall a. MVar a -> a -> IO ()
    putMVar MVar Event
    m Event
    e) fd evt M.OneShot
      evt' <- takeMVar m `onException` unregisterFd_ mgr reg
      if evt' `eventIs` evtClose
        then ioError $ errnoToIOError "threadWait" eBADF Nothing Nothing
        else 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
      m <- Maybe Event -> IO (TVar (Maybe Event))
    forall a. a -> IO (TVar a)
    newTVarIO Maybe Event
    forall a. Maybe a
    Nothing
      mgr <- getSystemEventManager_
      reg <- registerFd 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 evt M.OneShot
      let waitAction =
            do mevt <- TVar (Maybe Event) -> STM (Maybe Event)
    forall a. TVar a -> STM a
    readTVar TVar (Maybe Event)
    m
               case 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 a. a -> STM a
    forall (m :: * -> *) a. Monad m => a -> m a
    return ()
      return (waitAction, unregisterFd_ mgr reg >> 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
      t <- IO ThreadId
    myThreadId
      eventManagerArray <- readIORef eventManager
      let r = IOArray Int (Maybe (ThreadId, EventManager)) -> (Int, Int)
    forall i e. IOArray i e -> (i, i)
    boundsIOArray IOArray Int (Maybe (ThreadId, EventManager))
    eventManagerArray
      (cap, _) <- threadCapability t
      -- It is possible that we've just increased the number of capabilities and the
      -- new EventManager has not yet been constructed by
      -- 'ioManagerCapabilitiesChanged'. We expect this to happen very rarely.
      -- T21561 exercises this.
      -- Two options to proceed:
      --  1) return the EventManager for capability 0. This is guaranteed to exist,
      --     and "shouldn't" cause any correctness issues.
      --  2) Busy wait, with or without a call to 'yield'. This can't deadlock,
      --     because we must be on a brand capability and there must be a call to
      --     'ioManagerCapabilitiesChanged' pending.
      --
      -- We take the second option, with the yield, judging it the most robust.
      if not (inRange r cap)
        then yield >> getSystemEventManager
        else fmap snd `fmap` readIOArray eventManagerArray cap

    getSystemEventManager_ :: IO EventManager
    getSystemEventManager_ :: IO EventManager
    getSystemEventManager_ = do
      Just mgr <- IO (Maybe EventManager)
    getSystemEventManager
      return mgr
    {-# INLINE getSystemEventManager_ #-}

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

    -- Note [The eventManager Array]
    -- ~~~~~~~~~~~~~~~~~~~~~~~~~~~~~
    -- A mutable array holding the current EventManager for each capability
    -- An entry is Nothing only while the eventmanagers are initialised, see
    -- 'startIOManagerThread' and 'ioManagerCapabilitiesChanged'.
    -- The 'ThreadId' at array position 'cap'  will have been 'forkOn'ed capability
    -- 'cap'.
    -- The array will be swapped with newer arrays when the number of capabilities
    -- changes(via 'setNumCapabilities'). However:
    --   * the size of the arrays will never decrease; and
    --   * The 'EventManager's in the array are not replaced with other
    --     'EventManager' constructors.
    --
    -- This is a similar strategy as the rts uses for it's
    -- capabilities array (n_capabilities is the size of the array,
    -- enabled_capabilities' is the number of active capabilities).
    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
        numCaps <- IO Int
    getNumCapabilities
        eventManagerArray <- newIOArray (0, numCaps - 1) Nothing
        em <- newIORef eventManagerArray
        sharedCAF em 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
    $ 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
       m <- () -> IO (MVar ())
    forall a. a -> IO (MVar a)
    newMVar ()
       sharedCAF m getOrSetSystemEventThreadIOManagerThreadStore

    getSystemTimerManager :: IO TM.TimerManager
    getSystemTimerManager :: IO TimerManager
    getSystemTimerManager =
      TimerManager -> Maybe TimerManager -> TimerManager
    forall a. a -> Maybe a -> a
    fromMaybe TimerManager
    forall {a}. a
    err (Maybe TimerManager -> TimerManager)
    -> IO (Maybe TimerManager) -> IO TimerManager
    forall a b. (a -> b) -> IO a -> IO b
    forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
    `fmap` IORef (Maybe TimerManager) -> IO (Maybe TimerManager)
    forall a. IORef a -> IO a
    readIORef IORef (Maybe TimerManager)
    timerManager
        where
          err :: a
    err = String -> a
    forall a. HasCallStack => String -> a
    error String
    "GHC.Internal.Event.Thread.getSystemTimerManager: the TimerManager requires linking against the threaded runtime"

    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
        em <- Maybe TimerManager -> IO (IORef (Maybe TimerManager))
    forall a. a -> IO (IORef a)
    newIORef Maybe TimerManager
    forall a. Maybe a
    Nothing
        sharedCAF em 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
       m <- Maybe ThreadId -> IO (MVar (Maybe ThreadId))
    forall a. a -> IO (MVar a)
    newMVar Maybe ThreadId
    forall a. Maybe a
    Nothing
       sharedCAF m getOrSetSystemTimerThreadIOManagerThreadStore

    ensureIOManagerIsRunning :: IO ()
    ensureIOManagerIsRunning :: IO ()
    ensureIOManagerIsRunning
      | Bool -> Bool
    not Bool
    threaded = () -> IO ()
    forall a. a -> IO a
    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
        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 (_, high) = boundsIOArray eventManagerArray
        mapM_ (startIOManagerThread eventManagerArray) [0..high]
        writeIORef numEnabledEventManagers (high+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
      !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
      labelThread t ("IOManager on cap " ++ show_int i)
      return 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
            !mgr <- IO EventManager
    new
            !t <- forkOn i $ do
                    c_setIOManagerControlFd
                      (fromIntegral i)
                      (fromIntegral $ controlWriteFd $ M.emControl mgr)
                    loop mgr
            labelThread t ("IOManager on cap " ++ show_int i)
            writeIOArray eventManagerArray i (Just (t,mgr))
      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 old of
        Maybe (ThreadId, EventManager)
    Nothing     -> IO ()
    create
        Just (ThreadId
    t,EventManager
    em) -> do
          s <- ThreadId -> IO ThreadStatus
    threadStatus ThreadId
    t
          case 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 a. a -> IO a
    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
            !mgr <- IO TimerManager
    TM.new
            c_setTimerManagerControlFd
              (fromIntegral $ controlWriteFd $ TM.emControl mgr)
            atomicWriteIORef timerManager $ Just mgr
            !t <- forkIO $ TM.loop mgr
            labelThread t "TimerManager"
            return $ Just t
      case Maybe ThreadId
    old of
        Maybe ThreadId
    Nothing            -> IO (Maybe ThreadId)
    create
        st :: Maybe ThreadId
    st@(Just ThreadId
    t) -> do
          s <- ThreadId -> IO ThreadStatus
    threadStatus ThreadId
    t
          case 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
              mem <- IORef (Maybe TimerManager) -> IO (Maybe TimerManager)
    forall a. IORef a -> IO a
    readIORef IORef (Maybe TimerManager)
    timerManager
              _ <- case mem of
                     Maybe TimerManager
    Nothing -> () -> IO ()
    forall a. a -> IO a
    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
              create
            ThreadStatus
    _other         -> Maybe ThreadId -> IO (Maybe ThreadId)
    forall a. a -> IO a
    forall (m :: * -> *) a. Monad m => a -> m a
    return Maybe ThreadId
    st

    foreign import ccall unsafe "rtsSupportsBoundThreads" threaded :: Bool

    ioManagerCapabilitiesChanged :: IO ()
    ioManagerCapabilitiesChanged :: IO ()
    ioManagerCapabilitiesChanged =
      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
        new_n_caps <- IO Int
    getNumCapabilities
        numEnabled <- readIORef numEnabledEventManagers
        writeIORef numEnabledEventManagers new_n_caps
        eventManagerArray <- readIORef eventManager
        let (_, high) = boundsIOArray eventManagerArray
        let old_n_caps = Int
    high Int -> Int -> Int
    forall a. Num a => a -> a -> a
    + Int
    1
        if new_n_caps > old_n_caps
          then do new_eventManagerArray <- newIOArray (0, new_n_caps - 1) Nothing

                  -- copy the existing values into the new array:
                  forM_ [0..high] $ \Int
    i -> do
                    Just (tid,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 i < numEnabled
                      then writeIOArray new_eventManagerArray i (Just (tid,mgr))
                      else do tid' <- restartPollLoop mgr i
                              writeIOArray new_eventManagerArray i (Just (tid',mgr))

                  -- create new IO managers for the new caps:
                  forM_ [old_n_caps..new_n_caps-1] $
                    startIOManagerThread new_eventManagerArray

                  -- update the event manager array reference:
                  atomicWriteIORef eventManager new_eventManagerArray
                  -- We need an atomic write here because 'eventManager' is accessed
                  -- unsynchronized in 'getSystemEventManager' and 'closeFdWith'
          else when (new_n_caps > numEnabled) $
                forM_ [numEnabled..new_n_caps-1] $ \Int
    i -> do
                  Just (_,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
                  tid <- restartPollLoop mgr i
                  writeIOArray eventManagerArray i (Just (tid,mgr))

    #if defined(wasm32_HOST_ARCH)
    c_setIOManagerControlFd :: CUInt -> CInt -> IO ()
    c_setIOManagerControlFd _ _ = pure ()

    c_setTimerManagerControlFd :: CInt -> IO ()
    c_setTimerManagerControlFd _ = pure ()
    #else
    -- 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 ()
    #endif

    #endif