{-# LANGUAGE Trustworthy #-}{-# LANGUAGE BangPatterns, NoImplicitPrelude #-}moduleGHC.Event.Thread(getSystemEventManager ,getSystemTimerManager ,ensureIOManagerIsRunning ,ioManagerCapabilitiesChanged ,threadWaitRead ,threadWaitWrite ,threadWaitReadSTM ,threadWaitWriteSTM ,closeFdWith ,threadDelay ,registerDelay ,blockedOnBadFD -- used by RTS)where-- TODO: Use new Windows I/O managerimportControl.Exception (finally ,SomeException ,toException )importData.Foldable (forM_ ,mapM_ ,sequence_ )importData.IORef (IORef ,newIORef ,readIORef ,writeIORef ,atomicWriteIORef )importData.Maybe (fromMaybe )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 ,yield )importGHC.IO (mask_ ,uninterruptibleMask_ ,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.Ix (inRange )importGHC.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 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 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 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 a. a -> IO a 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 Fd -> IO () close Fd fd =IO () close_loop wherefinish :: 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 :: (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 )-- 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 againclose_loop :: IO () close_loop =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 letema_bounds :: (Int, Int) ema_bounds @(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 ->doJust (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 a. a -> IO a forall (m :: * -> *) a. Monad m => a -> m a return EventManager 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.IO (IO ()) -> IO () forall (m :: * -> *) a. Monad m => m (m a) -> m a join (IO (IO ()) -> IO ()) -> IO (IO ()) -> IO () forall a b. (a -> b) -> a -> b $ IO (IO ()) -> IO (IO ()) forall a. IO a -> IO a uninterruptibleMask_ (IO (IO ()) -> IO (IO ())) -> 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 (Int, Int) new_ema_bounds <-IOArray Int (Maybe (ThreadId, EventManager)) -> (Int, Int) forall i e. IOArray i e -> (i, i) boundsIOArray (IOArray Int (Maybe (ThreadId, EventManager)) -> (Int, Int)) -> IO (IOArray Int (Maybe (ThreadId, EventManager))) -> IO (Int, Int) forall a b. (a -> b) -> IO a -> IO b forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b `fmap` 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 -- Here we exploit Note [The eventManager Array]if(Int, Int) new_ema_bounds (Int, Int) -> (Int, Int) -> Bool forall a. Eq a => a -> a -> Bool /= (Int, Int) ema_bounds thendo-- 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[IO ()] -> IO () forall (t :: * -> *) (m :: * -> *) a. (Foldable t, Monad m) => t (m a) -> m () sequence_ ([IO ()] -> IO ()) -> [IO ()] -> IO () forall a b. (a -> b) -> a -> b $ (EventManager -> IntTable [FdData] -> IO ()) -> [EventManager] -> [IntTable [FdData]] -> [IO ()] forall a b c. (a -> b -> c) -> [a] -> [b] -> [c] 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 ()))[EventManager] mgrs [IntTable [FdData]] tables IO () -> IO (IO ()) forall a. a -> IO a forall (f :: * -> *) a. Applicative f => a -> f a pure IO () close_loop elsedo-- 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.[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 )IO () -> IO (IO ()) forall a. a -> IO a forall (f :: * -> *) a. Applicative f => a -> f a pure (() -> IO () forall a. a -> IO a forall (f :: * -> *) a. Applicative f => a -> f a pure ())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 $ 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 (\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 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 String "threadWait"Errno eBADF Maybe Handle forall a. Maybe a Nothing Maybe String forall a. Maybe a Nothing else() -> IO () forall a. a -> IO a 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 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 $ 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 (\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 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 ofMaybe Event Nothing ->STM () forall a. STM a retry Just 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 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 ()(STM (), IO ()) -> IO (STM (), IO ()) forall a. a -> IO a 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 a b. IO a -> IO b -> IO b forall (m :: * -> *) a b. Monad m => m a -> m b -> m b >> () -> IO () forall a. a -> IO a 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 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 letr :: (Int, Int) r =IOArray Int (Maybe (ThreadId, EventManager)) -> (Int, Int) forall i e. IOArray i e -> (i, i) boundsIOArray IOArray Int (Maybe (ThreadId, EventManager)) eventManagerArray (Int cap ,Bool _)<-ThreadId -> IO (Int, Bool) threadCapability ThreadId 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.ifBool -> Bool not ((Int, Int) -> Int -> Bool forall a. Ix a => (a, a) -> a -> Bool inRange (Int, Int) r Int cap )thenIO () yield IO () -> IO (Maybe EventManager) -> IO (Maybe EventManager) forall a b. IO a -> IO b -> IO b forall (m :: * -> *) a b. Monad m => m a -> m b -> m b >> IO (Maybe EventManager) getSystemEventManager else((ThreadId, EventManager) -> EventManager) -> Maybe (ThreadId, EventManager) -> Maybe EventManager forall a b. (a -> b) -> Maybe a -> Maybe b 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) -> Maybe EventManager) -> IO (Maybe (ThreadId, EventManager)) -> IO (Maybe EventManager) forall a b. (a -> b) -> IO a -> IO b forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b `fmap` 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 getSystemEventManager_ ::IO EventManager getSystemEventManager_ :: IO EventManager getSystemEventManager_ =doJust EventManager mgr <-IO (Maybe EventManager) getSystemEventManager EventManager -> IO EventManager forall a. a -> IO a forall (m :: * -> *) a. Monad m => a -> m a return EventManager mgr {-# INLINEgetSystemEventManager_ #-}foreignimportccallunsafe"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 capabality-- '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 $ 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 (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 {-# NOINLINEeventManager #-}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{-# 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 ::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 whereerr :: a err =String -> a forall a. HasCallStack => String -> a error String "GHC.Event.Thread.getSystemTimerManager: the TimerManager requires linking against the threaded runtime"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 not Bool threaded =() -> IO () forall a. a -> IO a 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(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 high Int -> 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 0Int i String ""restartPollLoop ::EventManager ->Int ->IO ThreadId restartPollLoop :: EventManager -> Int -> IO ThreadId restartPollLoop EventManager mgr 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 (String "IOManager on cap "String -> ShowS forall a. [a] -> [a] -> [a] ++ Int -> String show_int Int i )ThreadId -> IO ThreadId forall a. a -> IO a 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 =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 (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 caseMaybe (ThreadId, EventManager) old ofMaybe (ThreadId, EventManager) Nothing ->IO () create Just (ThreadId t ,EventManager em )->doThreadStatus s <-ThreadId -> IO ThreadStatus threadStatus ThreadId t caseThreadStatus s ofThreadStatus 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 #4449CUInt -> 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 ->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 String "TimerManager"Maybe ThreadId -> IO (Maybe ThreadId) forall a. a -> IO a 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 ofMaybe ThreadId Nothing ->IO (Maybe ThreadId) create st :: Maybe ThreadId st @(Just ThreadId t )->doThreadStatus s <-ThreadId -> IO ThreadStatus threadStatus ThreadId t caseThreadStatus s ofThreadStatus 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 #4449Maybe TimerManager mem <-IORef (Maybe TimerManager) -> IO (Maybe TimerManager) forall a. IORef a -> IO a readIORef IORef (Maybe TimerManager) timerManager () _<-caseMaybe TimerManager mem ofMaybe TimerManager Nothing ->() -> IO () forall a. a -> IO a forall (m :: * -> *) a. Monad m => a -> m a return ()Just TimerManager em ->doCInt -> IO () c_setTimerManagerControlFd (-CInt 1)TimerManager -> IO () TM.cleanup TimerManager em IO (Maybe ThreadId) 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 foreignimportccallunsafe"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 $ \() _->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(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 letold_n_caps :: Int old_n_caps =Int high Int -> Int -> Int forall a. Num a => a -> a -> a + Int 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 (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 ->doJust (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 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 - 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 () atomicWriteIORef IORef (IOArray Int (Maybe (ThreadId, EventManager))) eventManager IOArray Int (Maybe (ThreadId, EventManager)) new_eventManagerArray -- We need an atomic write here because 'eventManager' is accessed-- unsynchronized in 'getSystemEventManager' and 'closeFdWith'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 - Int 1]((Int -> IO ()) -> IO ()) -> (Int -> IO ()) -> IO () forall a b. (a -> b) -> a -> b $ \Int i ->doJust (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.foreignimportccallunsafe"setIOManagerControlFd"c_setIOManagerControlFd ::CUInt ->CInt ->IO ()foreignimportccallunsafe"setTimerManagerControlFd"c_setTimerManagerControlFd ::CInt ->IO ()