{-# LANGUAGE CPP #-}
{-# LANGUAGE ForeignFunctionInterface #-}
{-# LANGUAGE MagicHash #-}
{-# LANGUAGE ScopedTypeVariables #-}
{-# LANGUAGE UnliftedFFITypes #-}

-- | Basic Thread operations.
module Util.Thread (

   ThreadId,

   -- thread creation

   forkIODebug, -- :: IO () -> IO ThreadId
      -- Try to be more helpful about catching exceptions.


   forkIOquiet,
      -- ALMOST identical with standard action.
      -- The differences are (a) that it takes an extra string argument
      -- (which goes first); (b) if the thread fails because of
      -- "BlockedOnMVar" nothing is printed, but we output a
      -- message to "debug" which includes the label.
      -- NB.  This function no longer seems to be necessary in recent
      -- versions of GHC (current is 6.02.1) so please don't use it.
   goesQuietly,
   -- :: IO () -> IO ()
   -- This wraps an action so that if killed nothing is printed and it
   -- just returns.  This is useful for Expect and other things which
   -- get rid of a redundant thread by killing it.
   -- Now changed so that it also prints nothing for BlockedOnMVar


   -- delay thread execution
   Duration,
   mins,
   secs,
   msecs,
   usecs,
   delay,
   after,
   every,

   mapMConcurrent,
   mapMConcurrent_,
      -- evaluate a list of IO actions concurrently.
   mapMConcurrentExcep,
      -- evaluate a list of IO actions concurrently, also propagating
      -- exceptions properly.
   )
where

import qualified GHC.Conc
import qualified GHC.Base

import Control.Exception
import Control.Concurrent
import Control.Monad
import Data.Int

import Util.Computation

import Util.Debug(debug)
import Util.ExtendedPrelude

-- --------------------------------------------------------------------------
-- Delay Thread Execution
-- --------------------------------------------------------------------------

type Duration = Int -- time in microseconds

delay :: Duration -> IO ()
delay :: Duration -> IO ()
delay Duration
d =
   if Duration
dDuration -> Duration -> Bool
forall a. Ord a => a -> a -> Bool
<Duration
0
      then
         [Char] -> IO ()
forall a. Show a => a -> IO ()
debug([Char]
"Thread.delay - delay time of " [Char] -> [Char] -> [Char]
forall a. [a] -> [a] -> [a]
++ Duration -> [Char]
forall a. Show a => a -> [Char]
show Duration
d)
      else
         Duration -> IO ()
threadDelay Duration
d
{-# INLINE delay #-}

after :: Duration -> IO a -> IO a
after :: Duration -> IO a -> IO a
after Duration
d IO a
c = do {Duration -> IO ()
delay Duration
d; IO a
c}

every :: Duration -> IO a -> IO ()
every :: Duration -> IO a -> IO ()
every Duration
d IO a
c = IO a -> IO ()
forall (f :: * -> *) a b. Applicative f => f a -> f b
forever (Duration -> IO a -> IO a
forall a. Duration -> IO a -> IO a
after Duration
d IO a
c)

mins  :: Double -> Duration
secs  :: Double -> Duration
msecs :: Double -> Duration
usecs :: Double -> Duration

usecs :: Double -> Duration
usecs Double
x = Double -> Duration
forall a b. (RealFrac a, Integral b) => a -> b
round(Double
x)
msecs :: Double -> Duration
msecs Double
x = Double -> Duration
forall a b. (RealFrac a, Integral b) => a -> b
round(Double
xDouble -> Double -> Double
forall a. Num a => a -> a -> a
*Double
1000.0)
secs :: Double -> Duration
secs Double
x  = Double -> Duration
forall a b. (RealFrac a, Integral b) => a -> b
round(Double
xDouble -> Double -> Double
forall a. Num a => a -> a -> a
*Double
1000000.0)
mins :: Double -> Duration
mins Double
x  = Double -> Duration
forall a b. (RealFrac a, Integral b) => a -> b
round(Double
xDouble -> Double -> Double
forall a. Num a => a -> a -> a
*Double
60000000.0)

-- --------------------------------------------------------------------------
-- goesQuietly
-- --------------------------------------------------------------------------

goesQuietly :: IO () -> IO ()
goesQuietly :: IO () -> IO ()
goesQuietly IO ()
action =
   do
      Either () ()
result <-
         (SomeException -> Maybe ()) -> IO () -> IO (Either () ())
forall e b a.
Exception e =>
(e -> Maybe b) -> IO a -> IO (Either b a)
tryJust
            (\ SomeException
exception -> case SomeException -> Maybe AsyncException
forall e. Exception e => SomeException -> Maybe e
fromException SomeException
exception of
               Just AsyncException
ThreadKilled -> () -> Maybe ()
forall a. a -> Maybe a
Just ()
               Maybe AsyncException
_ -> case SomeException -> Maybe BlockedIndefinitelyOnMVar
forall e. Exception e => SomeException -> Maybe e
fromException SomeException
exception of
#if __GLASGOW_HASKELL__ >= 612
                 Just BlockedIndefinitelyOnMVar
BlockedIndefinitelyOnMVar -> () -> Maybe ()
forall a. a -> Maybe a
Just ()
#else
                 Just BlockedOnDeadMVar -> Just ()
#endif
                 Maybe BlockedIndefinitelyOnMVar
_ -> Maybe ()
forall a. Maybe a
Nothing
               )
            IO ()
action
      case Either () ()
result of
         Left () -> () -> IO ()
forall (m :: * -> *) a. Monad m => a -> m a
return ()
         Right () -> () -> IO ()
forall (m :: * -> *) a. Monad m => a -> m a
return ()

-- --------------------------------------------------------------------------
-- forkIOSafe
-- --------------------------------------------------------------------------

forkIODebug :: IO () -> IO ThreadId
forkIODebug :: IO () -> IO ThreadId
forkIODebug = IO () -> IO ThreadId
forkIO (IO () -> IO ThreadId) -> (IO () -> IO ()) -> IO () -> IO ThreadId
forall b c a. (b -> c) -> (a -> b) -> a -> c
. IO () -> IO ()
forall a. IO a -> IO a
errorOurExceps

-- --------------------------------------------------------------------------
-- forkIOquiet
-- --------------------------------------------------------------------------

forkIOquiet :: String -> IO () -> IO ThreadId
forkIOquiet :: [Char] -> IO () -> IO ThreadId
forkIOquiet [Char]
label IO ()
action =
   do
      let
         newAction :: IO ()
newAction =
            do
               Either () ()
error <- (SomeException -> Maybe ()) -> IO () -> IO (Either () ())
forall e b a.
Exception e =>
(e -> Maybe b) -> IO a -> IO (Either b a)
tryJust
                  (\ SomeException
exception -> case SomeException -> Maybe BlockedIndefinitelyOnMVar
forall e. Exception e => SomeException -> Maybe e
fromException SomeException
exception of
#if __GLASGOW_HASKELL__ >= 612
                     Just BlockedIndefinitelyOnMVar
BlockedIndefinitelyOnMVar -> () -> Maybe ()
forall a. a -> Maybe a
Just ()
#else
                     Just BlockedOnDeadMVar -> Just ()
#endif
                     Maybe BlockedIndefinitelyOnMVar
_ -> Maybe ()
forall a. Maybe a
Nothing
                     )
                  IO ()
action
               case Either () ()
error of
                  Right () -> IO ()
forall (m :: * -> *). Monad m => m ()
done -- success
                  Left () ->
                     do
                        [Char] -> IO ()
forall a. Show a => a -> IO ()
debug ([Char]
"Thread.forkIOquiet: "[Char] -> [Char] -> [Char]
forall a. [a] -> [a] -> [a]
++[Char]
label)
      IO () -> IO ThreadId
forkIO IO ()
newAction


-- --------------------------------------------------------------------------
-- mapMConcurrent
-- --------------------------------------------------------------------------

mapMConcurrent :: (a -> IO b) -> [a] -> IO [b]
mapMConcurrent :: (a -> IO b) -> [a] -> IO [b]
mapMConcurrent a -> IO b
mapFn [] = [b] -> IO [b]
forall (m :: * -> *) a. Monad m => a -> m a
return []
mapMConcurrent a -> IO b
mapFn [a
a] =
   do
      b
b <- a -> IO b
mapFn a
a
      [b] -> IO [b]
forall (m :: * -> *) a. Monad m => a -> m a
return [b
b]
mapMConcurrent a -> IO b
mapFn [a]
as =
   do
      ([MVar b]
mVars :: [MVar b]) <- (a -> IO (MVar b)) -> [a] -> IO [MVar b]
forall (t :: * -> *) (m :: * -> *) a b.
(Traversable t, Monad m) =>
(a -> m b) -> t a -> m (t b)
mapM
         (\ a
a ->
            do
               MVar b
mVar <- IO (MVar b)
forall a. IO (MVar a)
newEmptyMVar
               let
                  act :: IO ()
act =
                     do
                        b
b <- a -> IO b
mapFn a
a
                        MVar b -> b -> IO ()
forall a. MVar a -> a -> IO ()
putMVar MVar b
mVar b
b
               IO () -> IO ThreadId
forkIO IO ()
act
               MVar b -> IO (MVar b)
forall (m :: * -> *) a. Monad m => a -> m a
return MVar b
mVar
            )
         [a]
as
      (MVar b -> IO b) -> [MVar b] -> IO [b]
forall (t :: * -> *) (m :: * -> *) a b.
(Traversable t, Monad m) =>
(a -> m b) -> t a -> m (t b)
mapM MVar b -> IO b
forall a. MVar a -> IO a
takeMVar [MVar b]
mVars

-- this version is careful to propagate exceptions, at a slight cost.
mapMConcurrentExcep :: forall a b . (a -> IO b) -> [a] -> IO [b]
mapMConcurrentExcep :: (a -> IO b) -> [a] -> IO [b]
mapMConcurrentExcep a -> IO b
mapFn [] = [b] -> IO [b]
forall (m :: * -> *) a. Monad m => a -> m a
return []
mapMConcurrentExcep a -> IO b
mapFn [a
a] =
   do
      b
b <- a -> IO b
mapFn a
a
      [b] -> IO [b]
forall (m :: * -> *) a. Monad m => a -> m a
return [b
b]
mapMConcurrentExcep a -> IO b
mapFn [a]
as =
   do
      ([MVar (Either SomeException b)]
mVars :: [MVar (Either SomeException b)]) <- (a -> IO (MVar (Either SomeException b)))
-> [a] -> IO [MVar (Either SomeException b)]
forall (t :: * -> *) (m :: * -> *) a b.
(Traversable t, Monad m) =>
(a -> m b) -> t a -> m (t b)
mapM
         (\ a
a ->
            do
               MVar (Either SomeException b)
mVar <- IO (MVar (Either SomeException b))
forall a. IO (MVar a)
newEmptyMVar
               let
                  act :: IO ()
act =
                     do
                        Either SomeException b
bAnswer <- IO b -> IO (Either SomeException b)
forall e a. Exception e => IO a -> IO (Either e a)
Control.Exception.try (a -> IO b
mapFn a
a)
                        MVar (Either SomeException b) -> Either SomeException b -> IO ()
forall a. MVar a -> a -> IO ()
putMVar MVar (Either SomeException b)
mVar Either SomeException b
bAnswer
               IO () -> IO ThreadId
forkIO IO ()
act
               MVar (Either SomeException b) -> IO (MVar (Either SomeException b))
forall (m :: * -> *) a. Monad m => a -> m a
return MVar (Either SomeException b)
mVar
            )
         [a]
as
      (MVar (Either SomeException b) -> IO b)
-> [MVar (Either SomeException b)] -> IO [b]
forall (t :: * -> *) (m :: * -> *) a b.
(Traversable t, Monad m) =>
(a -> m b) -> t a -> m (t b)
mapM
         (\ MVar (Either SomeException b)
mVar ->
            do
               Either SomeException b
bAnswer <- MVar (Either SomeException b) -> IO (Either SomeException b)
forall a. MVar a -> IO a
takeMVar MVar (Either SomeException b)
mVar
               Either SomeException b -> IO b
forall a. Answer a -> IO a
propagate Either SomeException b
bAnswer
            )
         [MVar (Either SomeException b)]
mVars



mapMConcurrent_ :: (a -> IO ()) -> [a] -> IO ()
mapMConcurrent_ :: (a -> IO ()) -> [a] -> IO ()
mapMConcurrent_ a -> IO ()
mapFn [a]
as = (a -> IO ThreadId) -> [a] -> IO ()
forall (t :: * -> *) (m :: * -> *) a b.
(Foldable t, Monad m) =>
(a -> m b) -> t a -> m ()
mapM_ (\ a
a -> IO () -> IO ThreadId
forkIO (a -> IO ()
mapFn a
a)) [a]
as