module Util.Thread (
ThreadId,
hashThreadId,
forkIODebug,
forkIOquiet,
goesQuietly,
Duration,
mins,
secs,
msecs,
usecs,
delay,
after,
every,
mapMConcurrent,
mapMConcurrent_,
mapMConcurrentExcep,
)
where
import qualified GHC.Conc
import qualified GHC.Base
import Control.Exception
import Control.Concurrent
import Control.Monad
import Data.HashTable
import Data.Int
import Util.Computation
import Util.Debug(debug)
import Util.ExtendedPrelude
type Duration = Int
delay :: Duration -> IO ()
delay d =
if d<0
then
debug("Thread.delay - delay time of " ++ show d)
else
threadDelay d
after :: Duration -> IO a -> IO a
after d c = do {delay d; c}
every :: Duration -> IO a -> IO ()
every d c = forever (after d c)
mins :: Double -> Duration
secs :: Double -> Duration
msecs :: Double -> Duration
usecs :: Double -> Duration
usecs x = round(x)
msecs x = round(x*1000.0)
secs x = round(x*1000000.0)
mins x = round(x*60000000.0)
goesQuietly :: IO () -> IO ()
goesQuietly action =
do
result <-
tryJust
(\ exception -> case fromException exception of
Just ThreadKilled -> Just ()
_ -> case fromException exception of
#if __GLASGOW_HASKELL__ >= 612
Just BlockedIndefinitelyOnMVar -> Just ()
#else
Just BlockedOnDeadMVar -> Just ()
#endif
_ -> Nothing
)
action
case result of
Left () -> return ()
Right () -> return ()
forkIODebug :: IO () -> IO ThreadId
forkIODebug = forkIO . errorOurExceps
forkIOquiet :: String -> IO () -> IO ThreadId
forkIOquiet label action =
do
let
newAction =
do
error <- tryJust
(\ exception -> case fromException exception of
#if __GLASGOW_HASKELL__ >= 612
Just BlockedIndefinitelyOnMVar -> Just ()
#else
Just BlockedOnDeadMVar -> Just ()
#endif
_ -> Nothing
)
action
case error of
Right () -> done
Left () ->
do
debug ("Thread.forkIOquiet: "++label)
forkIO newAction
mapMConcurrent :: (a -> IO b) -> [a] -> IO [b]
mapMConcurrent mapFn [] = return []
mapMConcurrent mapFn [a] =
do
b <- mapFn a
return [b]
mapMConcurrent mapFn as =
do
(mVars :: [MVar b]) <- mapM
(\ a ->
do
mVar <- newEmptyMVar
let
act =
do
b <- mapFn a
putMVar mVar b
forkIO act
return mVar
)
as
mapM takeMVar mVars
mapMConcurrentExcep :: forall a b . (a -> IO b) -> [a] -> IO [b]
mapMConcurrentExcep mapFn [] = return []
mapMConcurrentExcep mapFn [a] =
do
b <- mapFn a
return [b]
mapMConcurrentExcep mapFn as =
do
(mVars :: [MVar (Either SomeException b)]) <- mapM
(\ a ->
do
mVar <- newEmptyMVar
let
act =
do
bAnswer <- Control.Exception.try (mapFn a)
putMVar mVar bAnswer
forkIO act
return mVar
)
as
mapM
(\ mVar ->
do
bAnswer <- takeMVar mVar
propagate bAnswer
)
mVars
mapMConcurrent_ :: (a -> IO ()) -> [a] -> IO ()
mapMConcurrent_ mapFn as = mapM_ (\ a -> forkIO (mapFn a)) as
hashThreadId :: ThreadId -> Int32
hashThreadId (GHC.Conc.ThreadId ti) = hashInt (getThreadId ti)
foreign import ccall unsafe "rts_getThreadId" getThreadId
:: GHC.Base.ThreadId# -> Int