{-# LANGUAGE Trustworthy #-}{-# LANGUAGE BangPatterns, NoImplicitPrelude #-}moduleGHC.Event.Thread(getSystemEventManager ,getSystemTimerManager ,ensureIOManagerIsRunning ,ioManagerCapabilitiesChanged ,threadWaitRead ,threadWaitWrite ,threadWaitReadSTM ,threadWaitWriteSTM ,closeFdWith ,threadDelay ,registerDelay ,blockedOnBadFD -- used by RTS)whereimportControl.Exception (finally ,SomeException ,toException )importData.Foldable (forM_ ,mapM_ ,sequence_ )importData.IORef (IORef ,newIORef ,readIORef ,writeIORef )importData.Tuple (snd )importForeign.C.Error (eBADF ,errnoToIOError )importForeign.C.Types (CInt (..),CUInt (..))importForeign.Ptr (Ptr )importGHC.Base importGHC.List (zipWith ,zipWith3 )importGHC.Conc.Sync (TVar ,ThreadId ,ThreadStatus (..),atomically ,forkIO ,labelThread ,modifyMVar_ ,withMVar ,newTVar ,sharedCAF ,getNumCapabilities ,threadCapability ,myThreadId ,forkOn ,threadStatus ,writeTVar ,newTVarIO ,readTVar ,retry ,throwSTM ,STM )importGHC.IO (mask_ ,onException )importGHC.IO.Exception (ioError )importGHC.IOArray (IOArray ,newIOArray ,readIOArray ,writeIOArray ,boundsIOArray )importGHC.MVar (MVar ,newEmptyMVar ,newMVar ,putMVar ,takeMVar )importGHC.Event.Control (controlWriteFd )importGHC.Event.Internal (eventIs ,evtClose )importGHC.Event.Manager (Event ,EventManager ,evtRead ,evtWrite ,loop ,new ,registerFd ,unregisterFd_ )importqualifiedGHC.Event.Manager asMimportqualifiedGHC.Event.TimerManager asTMimportGHC.Num ((-),(+) )importGHC.Real (fromIntegral )importGHC.Show (showSignedInt )importSystem.IO.Unsafe (unsafePerformIO )importSystem.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 usecs :: Int usecs =IO () -> IO () forall a. IO a -> IO a mask_ (IO () -> IO ()) -> IO () -> IO () forall a b. (a -> b) -> a -> b $ doTimerManager 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 usecs :: Int usecs =doTVar 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 FalseTimerManager 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 TrueTVar 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 {-# INLINEthreadWaitRead #-}-- | 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 {-# INLINEthreadWaitWrite #-}-- | 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 close :: Fd -> IO () close fd :: Fd fd =doIOArray 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(low :: Int low ,high :: 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 $ \i :: Int i ->doJust (_,!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 $ \mgr :: 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 (\mgr :: EventManager mgr table :: 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 )wherefinish :: EventManager -> IntTable [FdData] -> IO b -> IO b finish mgr :: EventManager mgr table :: IntTable [FdData] table cbApp :: 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 f :: a -> b -> m a f xs :: [a] xs ys :: [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 evt :: Event evt fd :: Fd fd =IO () -> IO () forall a. IO a -> IO a mask_ (IO () -> IO ()) -> IO () -> IO () forall a b. (a -> b) -> a -> b $ doMVar 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 (\_e :: 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 ifEvent evt' Event -> Event -> Bool `eventIs` Event evtClose thenIOError -> 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 "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 backendblockedOnBadFD ::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 "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 evt :: Event evt fd :: 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 $ doTVar (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 (\_e :: 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 letwaitAction :: STM () waitAction =doMaybe Event mevt <-TVar (Maybe Event) -> STM (Maybe Event) forall a. TVar a -> STM a readTVar TVar (Maybe Event) m caseMaybe Event mevt ofNothing ->STM () forall a. STM a retry Just evt' :: Event evt' ->ifEvent evt' Event -> Event -> Bool `eventIs` Event evtClose thenIOError -> 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 "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 {-# INLINEthreadWaitReadSTM #-}-- | 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 {-# INLINEthreadWaitWriteSTM #-}-- | 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 =doThreadId t <-IO ThreadId myThreadId (cap :: Int cap ,_)<-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_ ::IOEventManager getSystemEventManager_ :: IO EventManager getSystemEventManager_ =doJust mgr :: EventManager mgr <-IO (Maybe EventManager) getSystemEventManager EventManager -> IO EventManager forall (m :: * -> *) a. Monad m => a -> m a return EventManager mgr {-# INLINEgetSystemEventManager_ #-}foreignimportccallunsafe"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 $ doInt 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 (0,Int numCaps Int -> Int -> Int forall a. Num a => a -> a -> a - 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 {-# NOINLINEeventManager #-}numEnabledEventManagers ::IORef IntnumEnabledEventManagers :: 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 $ doInt -> IO (IORef Int) forall a. a -> IO (IORef a) newIORef 0{-# NOINLINEnumEnabledEventManagers #-}foreignimportccallunsafe"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.{-# NOINLINEioManagerLock #-}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 $ doMVar () 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 ::IOTM.TimerManager getSystemTimerManager :: IO TimerManager getSystemTimerManager =doJust mgr :: 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 foreignimportccallunsafe"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 $ doIORef (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 {-# NOINLINEtimerManager #-}foreignimportccallunsafe"getOrSetSystemTimerThreadIOManagerThreadStore"getOrSetSystemTimerThreadIOManagerThreadStore ::Ptr a ->IO(Ptr a ){-# NOINLINEtimerManagerThreadVar #-}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 $ doMVar (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 notBool threaded =() -> IO () forall (m :: * -> *) a. Monad m => a -> m a return ()|Bool otherwise =doIO () 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 $ \_->doIOArray 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(_,high :: 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 )[0..Int high ]IORef Int -> Int -> IO () forall a. IORef a -> a -> IO () writeIORef IORef Int numEnabledEventManagers (Int high Int -> Int -> Int forall a. Num a => a -> a -> a + 1)show_int ::Int->String show_int :: Int -> String show_int i :: Int i =Int -> Int -> ShowS showSignedInt 0Int i ""restartPollLoop ::EventManager ->Int->IOThreadId restartPollLoop :: EventManager -> Int -> IO ThreadId restartPollLoop mgr :: EventManager mgr i :: Int i =doEventManager -> 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 ("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 eventManagerArray :: IOArray Int (Maybe (ThreadId, EventManager)) eventManagerArray i :: Int i =doletcreate :: 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 $ doCUInt -> 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 ("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 caseMaybe (ThreadId, EventManager) old ofNothing ->IO () create Just (t :: ThreadId t ,em :: EventManager em )->doThreadStatus s <-ThreadId -> IO ThreadStatus threadStatus ThreadId t caseThreadStatus s ofThreadFinished ->IO () create ThreadDied ->do-- Sanity check: if the thread has died, there is a chance-- that event manager is still alive. This could happend during-- the fork, for example. In this case we should clean up-- open pipes and everything else related to the event manager.-- See #4449CUInt -> CInt -> IO () c_setIOManagerControlFd (Int -> CUInt forall a b. (Integral a, Num b) => a -> b fromIntegral Int i )(-1)EventManager -> IO () M.cleanup EventManager em IO () create _other :: 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 $ \old :: Maybe ThreadId old ->doletcreate :: 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 "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 caseMaybe ThreadId old ofNothing ->IO (Maybe ThreadId) create st :: Maybe ThreadId st @(Just t :: ThreadId t )->doThreadStatus s <-ThreadId -> IO ThreadStatus threadStatus ThreadId t caseThreadStatus s ofThreadFinished ->IO (Maybe ThreadId) create ThreadDied ->do-- Sanity check: if the thread has died, there is a chance-- that event manager is still alive. This could happend during-- the fork, for example. In this case we should clean up-- open pipes and everything else related to the event manager.-- See #4449Maybe TimerManager mem <-IORef (Maybe TimerManager) -> IO (Maybe TimerManager) forall a. IORef a -> IO a readIORef IORef (Maybe TimerManager) timerManager () _<-caseMaybe TimerManager mem ofNothing ->() -> IO () forall (m :: * -> *) a. Monad m => a -> m a return ()Just em :: TimerManager em ->doCInt -> IO () c_setTimerManagerControlFd (-1)TimerManager -> IO () TM.cleanup TimerManager em IO (Maybe ThreadId) create _other :: ThreadStatus _other ->Maybe ThreadId -> IO (Maybe ThreadId) forall (m :: * -> *) a. Monad m => a -> m a return Maybe ThreadId st foreignimportccallunsafe"rtsSupportsBoundThreads"threaded ::BoolioManagerCapabilitiesChanged ::IO()ioManagerCapabilitiesChanged :: IO () ioManagerCapabilitiesChanged =doMVar () -> (() -> 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 $ \_->doInt 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(_,high :: Int high )=IOArray Int (Maybe (ThreadId, EventManager)) -> (Int, Int) forall i e. IOArray i e -> (i, i) boundsIOArray IOArray Int (Maybe (ThreadId, EventManager)) eventManagerArray letold_n_caps :: Int old_n_caps =Int high Int -> Int -> Int forall a. Num a => a -> a -> a + 1ifInt new_n_caps Int -> Int -> Bool forall a. Ord a => a -> a -> Bool >Int old_n_caps thendoIOArray 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 (0,Int new_n_caps Int -> Int -> Int forall a. Num a => a -> a -> a - 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_ [0..Int high ]((Int -> IO ()) -> IO ()) -> (Int -> IO ()) -> IO () forall a b. (a -> b) -> a -> b $ \i :: Int i ->doJust (tid :: ThreadId tid ,mgr :: 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 ifInt i Int -> Int -> Bool forall a. Ord a => a -> a -> Bool <Int numEnabled thenIOArray 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 ))elsedoThreadId 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_caps Int -> Int -> Int forall a. Num a => a -> a -> a - 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 elseBool -> 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_caps Int -> Int -> Int forall a. Num a => a -> a -> a - 1]((Int -> IO ()) -> IO ()) -> (Int -> IO ()) -> IO () forall a b. (a -> b) -> a -> b $ \i :: Int i ->doJust (_,mgr :: 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.foreignimportccallunsafe"setIOManagerControlFd"c_setIOManagerControlFd ::CUInt ->CInt ->IO()foreignimportccallunsafe"setTimerManagerControlFd"c_setTimerManagerControlFd ::CInt ->IO()