{-# LANGUAGE Trustworthy #-}
{-# LANGUAGE BangPatterns, NoImplicitPrelude #-}
module GHC.Event.Thread
( getSystemEventManager
, getSystemTimerManager
, ensureIOManagerIsRunning
, ioManagerCapabilitiesChanged
, threadWaitRead
, threadWaitWrite
, threadWaitReadSTM
, threadWaitWriteSTM
, closeFdWith
, threadDelay
, registerDelay
, blockedOnBadFD
) where
import Control.Exception (finally, SomeException, toException)
import Data.Foldable (forM_, mapM_, sequence_)
import Data.IORef (IORef, newIORef, readIORef, writeIORef, atomicWriteIORef)
import Data.Maybe (fromMaybe)
import Data.Tuple (snd)
import Foreign.C.Error (eBADF, errnoToIOError)
import Foreign.C.Types (CInt(..), CUInt(..))
import Foreign.Ptr (Ptr)
import GHC.Base
import GHC.List (zipWith, zipWith3)
import GHC.Conc.Sync (TVar, ThreadId, ThreadStatus(..), atomically, forkIO,
labelThread, modifyMVar_, withMVar, newTVar, sharedCAF,
getNumCapabilities, threadCapability, myThreadId, forkOn,
threadStatus, writeTVar, newTVarIO, readTVar, retry,
throwSTM, STM, yield)
import GHC.IO (mask_, uninterruptibleMask_, onException)
import GHC.IO.Exception (ioError)
import GHC.IOArray (IOArray, newIOArray, readIOArray, writeIOArray,
boundsIOArray)
import GHC.MVar (MVar, newEmptyMVar, newMVar, putMVar, takeMVar)
import GHC.Event.Control (controlWriteFd)
import GHC.Event.Internal (eventIs, evtClose)
import GHC.Event.Manager (Event, EventManager, evtRead, evtWrite, loop,
new, registerFd, unregisterFd_)
import qualified GHC.Event.Manager as M
import qualified GHC.Event.TimerManager as TM
import GHC.Ix (inRange)
import GHC.Num ((-), (+))
import GHC.Real (fromIntegral)
import GHC.Show (showSignedInt)
import System.IO.Unsafe (unsafePerformIO)
import System.Posix.Types (Fd)
threadDelay :: Int -> IO ()
threadDelay :: Int -> IO ()
threadDelay Int
usecs = forall a. IO a -> IO a
mask_ forall a b. (a -> b) -> a -> b
$ do
TimerManager
mgr <- IO TimerManager
getSystemTimerManager
MVar ()
m <- forall a. IO (MVar a)
newEmptyMVar
TimeoutKey
reg <- TimerManager -> Int -> IO () -> IO TimeoutKey
TM.registerTimeout TimerManager
mgr Int
usecs (forall a. MVar a -> a -> IO ()
putMVar MVar ()
m ())
forall a. MVar a -> IO a
takeMVar MVar ()
m forall a b. IO a -> IO b -> IO a
`onException` TimerManager -> TimeoutKey -> IO ()
TM.unregisterTimeout TimerManager
mgr TimeoutKey
reg
registerDelay :: Int -> IO (TVar Bool)
registerDelay :: Int -> IO (TVar Bool)
registerDelay Int
usecs = do
TVar Bool
t <- forall a. STM a -> IO a
atomically forall a b. (a -> b) -> a -> b
$ 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 forall b c a. (b -> c) -> (a -> b) -> a -> c
. forall a. STM a -> IO a
atomically forall a b. (a -> b) -> a -> b
$ forall a. TVar a -> a -> STM ()
writeTVar TVar Bool
t Bool
True
forall (m :: * -> *) a. Monad m => a -> m a
return TVar Bool
t
threadWaitRead :: Fd -> IO ()
threadWaitRead :: Fd -> IO ()
threadWaitRead = Event -> Fd -> IO ()
threadWait Event
evtRead
{-# INLINE threadWaitRead #-}
threadWaitWrite :: Fd -> IO ()
threadWaitWrite :: Fd -> IO ()
threadWaitWrite = Event -> Fd -> IO ()
threadWait Event
evtWrite
{-# INLINE threadWaitWrite #-}
closeFdWith :: (Fd -> IO ())
-> Fd
-> 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 = forall a. MVar a -> a -> IO ()
putMVar (EventManager -> Fd -> MVar (IntTable [FdData])
M.callbackTableVar EventManager
mgr Fd
fd) IntTable [FdData]
table 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 = forall (m :: * -> *) a. Monad m => [m a] -> m [a]
sequence (forall a b c. (a -> b -> c) -> [a] -> [b] -> [c]
zipWith a -> b -> m a
f [a]
xs [b]
ys)
close_loop :: IO ()
close_loop = do
IOArray Int (Maybe (ThreadId, EventManager))
eventManagerArray <- forall a. IORef a -> IO a
readIORef IORef (IOArray Int (Maybe (ThreadId, EventManager)))
eventManager
let ema_bounds :: (Int, Int)
ema_bounds@(Int
low, Int
high) = forall i e. IOArray i e -> (i, i)
boundsIOArray IOArray Int (Maybe (ThreadId, EventManager))
eventManagerArray
[EventManager]
mgrs <- forall a b c. (a -> b -> c) -> b -> a -> c
flip forall (m :: * -> *) a b. Monad m => (a -> m b) -> [a] -> m [b]
mapM [Int
low..Int
high] forall a b. (a -> b) -> a -> b
$ \Int
i -> do
Just (ThreadId
_,!EventManager
mgr) <- forall i e. Ix i => IOArray i e -> i -> IO e
readIOArray IOArray Int (Maybe (ThreadId, EventManager))
eventManagerArray Int
i
forall (m :: * -> *) a. Monad m => a -> m a
return EventManager
mgr
forall (m :: * -> *) a. Monad m => m (m a) -> m a
join forall a b. (a -> b) -> a -> b
$ forall a. IO a -> IO a
uninterruptibleMask_ forall a b. (a -> b) -> a -> b
$ do
[IntTable [FdData]]
tables <- forall a b c. (a -> b -> c) -> b -> a -> c
flip forall (m :: * -> *) a b. Monad m => (a -> m b) -> [a] -> m [b]
mapM [EventManager]
mgrs forall a b. (a -> b) -> a -> b
$ \EventManager
mgr -> forall a. MVar a -> IO a
takeMVar forall a b. (a -> b) -> a -> b
$ EventManager -> Fd -> MVar (IntTable [FdData])
M.callbackTableVar EventManager
mgr Fd
fd
(Int, Int)
new_ema_bounds <- forall i e. IOArray i e -> (i, i)
boundsIOArray forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
`fmap` forall a. IORef a -> IO a
readIORef IORef (IOArray Int (Maybe (ThreadId, EventManager)))
eventManager
if (Int, Int)
new_ema_bounds forall a. Eq a => a -> a -> Bool
/= (Int, Int)
ema_bounds
then do
forall (t :: * -> *) (m :: * -> *) a.
(Foldable t, Monad m) =>
t (m a) -> m ()
sequence_ forall a b. (a -> b) -> a -> b
$ forall a b c. (a -> b -> c) -> [a] -> [b] -> [c]
zipWith (\EventManager
mgr IntTable [FdData]
table -> forall {b}. EventManager -> IntTable [FdData] -> IO b -> IO b
finish EventManager
mgr IntTable [FdData]
table (forall (f :: * -> *) a. Applicative f => a -> f a
pure ())) [EventManager]
mgrs [IntTable [FdData]]
tables
forall (f :: * -> *) a. Applicative f => a -> f a
pure IO ()
close_loop
else do
[IO ()]
cbApps <- 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 forall a b. IO a -> IO b -> IO a
`finally` forall (t :: * -> *) (m :: * -> *) a.
(Foldable t, Monad m) =>
t (m a) -> m ()
sequence_ (forall a b c d. (a -> b -> c -> d) -> [a] -> [b] -> [c] -> [d]
zipWith3 forall {b}. EventManager -> IntTable [FdData] -> IO b -> IO b
finish [EventManager]
mgrs [IntTable [FdData]]
tables [IO ()]
cbApps)
forall (f :: * -> *) a. Applicative f => a -> f a
pure (forall (f :: * -> *) a. Applicative f => a -> f a
pure ())
threadWait :: Event -> Fd -> IO ()
threadWait :: Event -> Fd -> IO ()
threadWait Event
evt Fd
fd = forall a. IO a -> IO a
mask_ forall a b. (a -> b) -> a -> b
$ do
MVar Event
m <- 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 -> forall a. MVar a -> a -> IO ()
putMVar MVar Event
m Event
e) Fd
fd Event
evt Lifetime
M.OneShot
Event
evt' <- forall a. MVar a -> IO a
takeMVar MVar Event
m forall a b. IO a -> IO b -> IO a
`onException` EventManager -> FdKey -> IO Bool
unregisterFd_ EventManager
mgr FdKey
reg
if Event
evt' Event -> Event -> Bool
`eventIs` Event
evtClose
then forall a. IOError -> IO a
ioError forall a b. (a -> b) -> a -> b
$ String -> Errno -> Maybe Handle -> Maybe String -> IOError
errnoToIOError String
"threadWait" Errno
eBADF forall a. Maybe a
Nothing forall a. Maybe a
Nothing
else forall (m :: * -> *) a. Monad m => a -> m a
return ()
blockedOnBadFD :: SomeException
blockedOnBadFD :: SomeException
blockedOnBadFD = forall e. Exception e => e -> SomeException
toException forall a b. (a -> b) -> a -> b
$ String -> Errno -> Maybe Handle -> Maybe String -> IOError
errnoToIOError String
"awaitEvent" Errno
eBADF forall a. Maybe a
Nothing forall a. Maybe a
Nothing
threadWaitSTM :: Event -> Fd -> IO (STM (), IO ())
threadWaitSTM :: Event -> Fd -> IO (STM (), IO ())
threadWaitSTM Event
evt Fd
fd = forall a. IO a -> IO a
mask_ forall a b. (a -> b) -> a -> b
$ do
TVar (Maybe Event)
m <- forall a. a -> IO (TVar a)
newTVarIO 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 -> forall a. STM a -> IO a
atomically (forall a. TVar a -> a -> STM ()
writeTVar TVar (Maybe Event)
m (forall a. a -> Maybe a
Just Event
e))) Fd
fd Event
evt Lifetime
M.OneShot
let waitAction :: STM ()
waitAction =
do Maybe Event
mevt <- forall a. TVar a -> STM a
readTVar TVar (Maybe Event)
m
case Maybe Event
mevt of
Maybe Event
Nothing -> forall a. STM a
retry
Just Event
evt' ->
if Event
evt' Event -> Event -> Bool
`eventIs` Event
evtClose
then forall e a. Exception e => e -> STM a
throwSTM forall a b. (a -> b) -> a -> b
$ String -> Errno -> Maybe Handle -> Maybe String -> IOError
errnoToIOError String
"threadWaitSTM" Errno
eBADF forall a. Maybe a
Nothing forall a. Maybe a
Nothing
else forall (m :: * -> *) a. Monad m => a -> m a
return ()
forall (m :: * -> *) a. Monad m => a -> m a
return (STM ()
waitAction, EventManager -> FdKey -> IO Bool
unregisterFd_ EventManager
mgr FdKey
reg forall (m :: * -> *) a b. Monad m => m a -> m b -> m b
>> forall (m :: * -> *) a. Monad m => a -> m a
return ())
threadWaitReadSTM :: Fd -> IO (STM (), IO ())
threadWaitReadSTM :: Fd -> IO (STM (), IO ())
threadWaitReadSTM = Event -> Fd -> IO (STM (), IO ())
threadWaitSTM Event
evtRead
{-# INLINE threadWaitReadSTM #-}
threadWaitWriteSTM :: Fd -> IO (STM (), IO ())
threadWaitWriteSTM :: Fd -> IO (STM (), IO ())
threadWaitWriteSTM = Event -> Fd -> IO (STM (), IO ())
threadWaitSTM Event
evtWrite
{-# INLINE threadWaitWriteSTM #-}
getSystemEventManager :: IO (Maybe EventManager)
getSystemEventManager :: IO (Maybe EventManager)
getSystemEventManager = do
ThreadId
t <- IO ThreadId
myThreadId
IOArray Int (Maybe (ThreadId, EventManager))
eventManagerArray <- forall a. IORef a -> IO a
readIORef IORef (IOArray Int (Maybe (ThreadId, EventManager)))
eventManager
let r :: (Int, Int)
r = 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
if Bool -> Bool
not (forall a. Ix a => (a, a) -> a -> Bool
inRange (Int, Int)
r Int
cap)
then IO ()
yield forall (m :: * -> *) a b. Monad m => m a -> m b -> m b
>> IO (Maybe EventManager)
getSystemEventManager
else forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
fmap forall a b. (a, b) -> b
snd forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
`fmap` 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_ = do
Just EventManager
mgr <- IO (Maybe EventManager)
getSystemEventManager
forall (m :: * -> *) a. Monad m => a -> m a
return EventManager
mgr
{-# INLINE getSystemEventManager_ #-}
foreign import ccall unsafe "getOrSetSystemEventThreadEventManagerStore"
getOrSetSystemEventThreadEventManagerStore :: Ptr a -> IO (Ptr a)
eventManager :: IORef (IOArray Int (Maybe (ThreadId, EventManager)))
eventManager :: IORef (IOArray Int (Maybe (ThreadId, EventManager)))
eventManager = forall a. IO a -> a
unsafePerformIO forall a b. (a -> b) -> a -> b
$ do
Int
numCaps <- IO Int
getNumCapabilities
IOArray Int (Maybe (ThreadId, EventManager))
eventManagerArray <- forall i e. Ix i => (i, i) -> e -> IO (IOArray i e)
newIOArray (Int
0, Int
numCaps forall a. Num a => a -> a -> a
- Int
1) forall a. Maybe a
Nothing
IORef (IOArray Int (Maybe (ThreadId, EventManager)))
em <- forall a. a -> IO (IORef a)
newIORef IOArray Int (Maybe (ThreadId, EventManager))
eventManagerArray
forall a. a -> (Ptr a -> IO (Ptr a)) -> IO a
sharedCAF IORef (IOArray Int (Maybe (ThreadId, EventManager)))
em forall a. Ptr a -> IO (Ptr a)
getOrSetSystemEventThreadEventManagerStore
{-# NOINLINE eventManager #-}
numEnabledEventManagers :: IORef Int
numEnabledEventManagers :: IORef Int
numEnabledEventManagers = forall a. IO a -> a
unsafePerformIO forall a b. (a -> b) -> a -> b
$ forall a. a -> IO (IORef a)
newIORef Int
0
{-# NOINLINE numEnabledEventManagers #-}
foreign import ccall unsafe "getOrSetSystemEventThreadIOManagerThreadStore"
getOrSetSystemEventThreadIOManagerThreadStore :: Ptr a -> IO (Ptr a)
{-# NOINLINE ioManagerLock #-}
ioManagerLock :: MVar ()
ioManagerLock :: MVar ()
ioManagerLock = forall a. IO a -> a
unsafePerformIO forall a b. (a -> b) -> a -> b
$ do
MVar ()
m <- forall a. a -> IO (MVar a)
newMVar ()
forall a. a -> (Ptr a -> IO (Ptr a)) -> IO a
sharedCAF MVar ()
m forall a. Ptr a -> IO (Ptr a)
getOrSetSystemEventThreadIOManagerThreadStore
getSystemTimerManager :: IO TM.TimerManager
getSystemTimerManager :: IO TimerManager
getSystemTimerManager =
forall a. a -> Maybe a -> a
fromMaybe forall {a}. a
err forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
`fmap` forall a. IORef a -> IO a
readIORef IORef (Maybe TimerManager)
timerManager
where
err :: a
err = forall a. HasCallStack => String -> a
error String
"GHC.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 = forall a. IO a -> a
unsafePerformIO forall a b. (a -> b) -> a -> b
$ do
IORef (Maybe TimerManager)
em <- forall a. a -> IO (IORef a)
newIORef forall a. Maybe a
Nothing
forall a. a -> (Ptr a -> IO (Ptr a)) -> IO a
sharedCAF IORef (Maybe TimerManager)
em forall a. Ptr a -> IO (Ptr a)
getOrSetSystemTimerThreadEventManagerStore
{-# NOINLINE timerManager #-}
foreign import ccall unsafe "getOrSetSystemTimerThreadIOManagerThreadStore"
getOrSetSystemTimerThreadIOManagerThreadStore :: Ptr a -> IO (Ptr a)
{-# NOINLINE timerManagerThreadVar #-}
timerManagerThreadVar :: MVar (Maybe ThreadId)
timerManagerThreadVar :: MVar (Maybe ThreadId)
timerManagerThreadVar = forall a. IO a -> a
unsafePerformIO forall a b. (a -> b) -> a -> b
$ do
MVar (Maybe ThreadId)
m <- forall a. a -> IO (MVar a)
newMVar forall a. Maybe a
Nothing
forall a. a -> (Ptr a -> IO (Ptr a)) -> IO a
sharedCAF MVar (Maybe ThreadId)
m forall a. Ptr a -> IO (Ptr a)
getOrSetSystemTimerThreadIOManagerThreadStore
ensureIOManagerIsRunning :: IO ()
ensureIOManagerIsRunning :: IO ()
ensureIOManagerIsRunning
| Bool -> Bool
not Bool
threaded = forall (m :: * -> *) a. Monad m => a -> m a
return ()
| Bool
otherwise = do
IO ()
startIOManagerThreads
IO ()
startTimerManagerThread
startIOManagerThreads :: IO ()
startIOManagerThreads :: IO ()
startIOManagerThreads =
forall a b. MVar a -> (a -> IO b) -> IO b
withMVar MVar ()
ioManagerLock forall a b. (a -> b) -> a -> b
$ \()
_ -> do
IOArray Int (Maybe (ThreadId, EventManager))
eventManagerArray <- forall a. IORef a -> IO a
readIORef IORef (IOArray Int (Maybe (ThreadId, EventManager)))
eventManager
let (Int
_, Int
high) = forall i e. IOArray i e -> (i, i)
boundsIOArray IOArray Int (Maybe (ThreadId, EventManager))
eventManagerArray
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]
forall a. IORef a -> a -> IO ()
writeIORef IORef Int
numEnabledEventManagers (Int
highforall a. Num a => a -> a -> a
+Int
1)
show_int :: Int -> String
show_int :: Int -> String
show_int Int
i = Int -> Int -> ShowS
showSignedInt Int
0 Int
i String
""
restartPollLoop :: EventManager -> Int -> IO ThreadId
restartPollLoop :: EventManager -> Int -> IO ThreadId
restartPollLoop EventManager
mgr Int
i = do
EventManager -> IO ()
M.release EventManager
mgr
!ThreadId
t <- Int -> IO () -> IO ThreadId
forkOn Int
i forall a b. (a -> b) -> a -> b
$ EventManager -> IO ()
loop EventManager
mgr
ThreadId -> String -> IO ()
labelThread ThreadId
t (String
"IOManager on cap " forall a. [a] -> [a] -> [a]
++ Int -> String
show_int Int
i)
forall (m :: * -> *) a. Monad m => a -> m a
return ThreadId
t
startIOManagerThread :: IOArray Int (Maybe (ThreadId, EventManager))
-> Int
-> IO ()
startIOManagerThread :: IOArray Int (Maybe (ThreadId, EventManager)) -> Int -> IO ()
startIOManagerThread IOArray Int (Maybe (ThreadId, EventManager))
eventManagerArray Int
i = do
let create :: IO ()
create = do
!EventManager
mgr <- IO EventManager
new
!ThreadId
t <- Int -> IO () -> IO ThreadId
forkOn Int
i forall a b. (a -> b) -> a -> b
$ do
CUInt -> CInt -> IO ()
c_setIOManagerControlFd
(forall a b. (Integral a, Num b) => a -> b
fromIntegral Int
i)
(forall a b. (Integral a, Num b) => a -> b
fromIntegral forall a b. (a -> b) -> a -> b
$ Control -> Fd
controlWriteFd 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 " forall a. [a] -> [a] -> [a]
++ Int -> String
show_int Int
i)
forall i e. Ix i => IOArray i e -> i -> e -> IO ()
writeIOArray IOArray Int (Maybe (ThreadId, EventManager))
eventManagerArray Int
i (forall a. a -> Maybe a
Just (ThreadId
t,EventManager
mgr))
Maybe (ThreadId, EventManager)
old <- forall i e. Ix i => IOArray i e -> i -> IO e
readIOArray IOArray Int (Maybe (ThreadId, EventManager))
eventManagerArray Int
i
case Maybe (ThreadId, EventManager)
old of
Maybe (ThreadId, EventManager)
Nothing -> IO ()
create
Just (ThreadId
t,EventManager
em) -> do
ThreadStatus
s <- ThreadId -> IO ThreadStatus
threadStatus ThreadId
t
case ThreadStatus
s of
ThreadStatus
ThreadFinished -> IO ()
create
ThreadStatus
ThreadDied -> do
CUInt -> CInt -> IO ()
c_setIOManagerControlFd (forall a b. (Integral a, Num b) => a -> b
fromIntegral Int
i) (-CInt
1)
EventManager -> IO ()
M.cleanup EventManager
em
IO ()
create
ThreadStatus
_other -> forall (m :: * -> *) a. Monad m => a -> m a
return ()
startTimerManagerThread :: IO ()
startTimerManagerThread :: IO ()
startTimerManagerThread = forall a. MVar a -> (a -> IO a) -> IO ()
modifyMVar_ MVar (Maybe ThreadId)
timerManagerThreadVar forall a b. (a -> b) -> a -> b
$ \Maybe ThreadId
old -> do
let create :: IO (Maybe ThreadId)
create = do
!TimerManager
mgr <- IO TimerManager
TM.new
CInt -> IO ()
c_setTimerManagerControlFd
(forall a b. (Integral a, Num b) => a -> b
fromIntegral forall a b. (a -> b) -> a -> b
$ Control -> Fd
controlWriteFd forall a b. (a -> b) -> a -> b
$ TimerManager -> Control
TM.emControl TimerManager
mgr)
forall a. IORef a -> a -> IO ()
writeIORef IORef (Maybe TimerManager)
timerManager forall a b. (a -> b) -> a -> b
$ forall a. a -> Maybe a
Just TimerManager
mgr
!ThreadId
t <- IO () -> IO ThreadId
forkIO forall a b. (a -> b) -> a -> b
$ TimerManager -> IO ()
TM.loop TimerManager
mgr
ThreadId -> String -> IO ()
labelThread ThreadId
t String
"TimerManager"
forall (m :: * -> *) a. Monad m => a -> m a
return forall a b. (a -> b) -> a -> b
$ forall a. a -> Maybe a
Just ThreadId
t
case Maybe ThreadId
old of
Maybe ThreadId
Nothing -> IO (Maybe ThreadId)
create
st :: Maybe ThreadId
st@(Just ThreadId
t) -> do
ThreadStatus
s <- ThreadId -> IO ThreadStatus
threadStatus ThreadId
t
case ThreadStatus
s of
ThreadStatus
ThreadFinished -> IO (Maybe ThreadId)
create
ThreadStatus
ThreadDied -> do
Maybe TimerManager
mem <- forall a. IORef a -> IO a
readIORef IORef (Maybe TimerManager)
timerManager
()
_ <- case Maybe TimerManager
mem of
Maybe TimerManager
Nothing -> forall (m :: * -> *) a. Monad m => a -> m a
return ()
Just TimerManager
em -> do CInt -> IO ()
c_setTimerManagerControlFd (-CInt
1)
TimerManager -> IO ()
TM.cleanup TimerManager
em
IO (Maybe ThreadId)
create
ThreadStatus
_other -> forall (m :: * -> *) a. Monad m => a -> m a
return Maybe ThreadId
st
foreign import ccall unsafe "rtsSupportsBoundThreads" threaded :: Bool
ioManagerCapabilitiesChanged :: IO ()
ioManagerCapabilitiesChanged :: IO ()
ioManagerCapabilitiesChanged =
forall a b. MVar a -> (a -> IO b) -> IO b
withMVar MVar ()
ioManagerLock forall a b. (a -> b) -> a -> b
$ \()
_ -> do
Int
new_n_caps <- IO Int
getNumCapabilities
Int
numEnabled <- forall a. IORef a -> IO a
readIORef IORef Int
numEnabledEventManagers
forall a. IORef a -> a -> IO ()
writeIORef IORef Int
numEnabledEventManagers Int
new_n_caps
IOArray Int (Maybe (ThreadId, EventManager))
eventManagerArray <- forall a. IORef a -> IO a
readIORef IORef (IOArray Int (Maybe (ThreadId, EventManager)))
eventManager
let (Int
_, Int
high) = forall i e. IOArray i e -> (i, i)
boundsIOArray IOArray Int (Maybe (ThreadId, EventManager))
eventManagerArray
let old_n_caps :: Int
old_n_caps = Int
high forall a. Num a => a -> a -> a
+ Int
1
if Int
new_n_caps forall a. Ord a => a -> a -> Bool
> Int
old_n_caps
then do IOArray Int (Maybe (ThreadId, EventManager))
new_eventManagerArray <- forall i e. Ix i => (i, i) -> e -> IO (IOArray i e)
newIOArray (Int
0, Int
new_n_caps forall a. Num a => a -> a -> a
- Int
1) forall a. Maybe a
Nothing
forall (t :: * -> *) (m :: * -> *) a b.
(Foldable t, Monad m) =>
t a -> (a -> m b) -> m ()
forM_ [Int
0..Int
high] forall a b. (a -> b) -> a -> b
$ \Int
i -> do
Just (ThreadId
tid,EventManager
mgr) <- forall i e. Ix i => IOArray i e -> i -> IO e
readIOArray IOArray Int (Maybe (ThreadId, EventManager))
eventManagerArray Int
i
if Int
i forall a. Ord a => a -> a -> Bool
< Int
numEnabled
then forall i e. Ix i => IOArray i e -> i -> e -> IO ()
writeIOArray IOArray Int (Maybe (ThreadId, EventManager))
new_eventManagerArray Int
i (forall a. a -> Maybe a
Just (ThreadId
tid,EventManager
mgr))
else do ThreadId
tid' <- EventManager -> Int -> IO ThreadId
restartPollLoop EventManager
mgr Int
i
forall i e. Ix i => IOArray i e -> i -> e -> IO ()
writeIOArray IOArray Int (Maybe (ThreadId, EventManager))
new_eventManagerArray Int
i (forall a. a -> Maybe a
Just (ThreadId
tid',EventManager
mgr))
forall (t :: * -> *) (m :: * -> *) a b.
(Foldable t, Monad m) =>
t a -> (a -> m b) -> m ()
forM_ [Int
old_n_caps..Int
new_n_capsforall a. Num a => a -> a -> a
-Int
1] forall a b. (a -> b) -> a -> b
$
IOArray Int (Maybe (ThreadId, EventManager)) -> Int -> IO ()
startIOManagerThread IOArray Int (Maybe (ThreadId, EventManager))
new_eventManagerArray
forall a. IORef a -> a -> IO ()
atomicWriteIORef IORef (IOArray Int (Maybe (ThreadId, EventManager)))
eventManager IOArray Int (Maybe (ThreadId, EventManager))
new_eventManagerArray
else forall (f :: * -> *). Applicative f => Bool -> f () -> f ()
when (Int
new_n_caps forall a. Ord a => a -> a -> Bool
> Int
numEnabled) forall a b. (a -> b) -> a -> b
$
forall (t :: * -> *) (m :: * -> *) a b.
(Foldable t, Monad m) =>
t a -> (a -> m b) -> m ()
forM_ [Int
numEnabled..Int
new_n_capsforall a. Num a => a -> a -> a
-Int
1] forall a b. (a -> b) -> a -> b
$ \Int
i -> do
Just (ThreadId
_,EventManager
mgr) <- 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
forall i e. Ix i => IOArray i e -> i -> e -> IO ()
writeIOArray IOArray Int (Maybe (ThreadId, EventManager))
eventManagerArray Int
i (forall a. a -> Maybe a
Just (ThreadId
tid,EventManager
mgr))
foreign import ccall unsafe "setIOManagerControlFd"
c_setIOManagerControlFd :: CUInt -> CInt -> IO ()
foreign import ccall unsafe "setTimerManagerControlFd"
c_setTimerManagerControlFd :: CInt -> IO ()