{-# LANGUAGE RankNTypes, NamedFieldPuns, BangPatterns,
ExistentialQuantification, CPP #-}
{-# OPTIONS_GHC -Wall -fno-warn-name-shadowing -fno-warn-unused-do-bind #-}
module Control.Monad.Par.Scheds.TraceInternal (
Trace(..), Sched(..), Par(..),
IVar(..), IVarContents(..),
sched,
runPar, runParIO, runParAsync,
new, newFull, newFull_, get, put_, put,
pollIVar, yield, fixPar, FixParException (..)
) where
import Control.Monad as M hiding (mapM, sequence, join)
import Prelude hiding (mapM, sequence, head,tail)
import Data.IORef
import System.IO.Unsafe
#if MIN_VERSION_base(4,4,0)
import GHC.IO.Unsafe (unsafeDupableInterleaveIO)
#else
import GHC.IO.Unsafe (unsafeInterleaveIO)
#endif
import Control.Concurrent hiding (yield)
import GHC.Conc (numCapabilities)
import Control.DeepSeq
import Control.Monad.Fix (MonadFix (mfix))
import Control.Exception (Exception, throwIO, BlockedIndefinitelyOnMVar (..),
catch)
#if !MIN_VERSION_base(4,8,0)
import Control.Applicative
#endif
#if __GLASGOW_HASKELL__ <= 700
import GHC.Conc (forkOnIO)
forkOn = forkOnIO
#endif
data Trace = forall a . Get (IVar a) (a -> Trace)
| forall a . Put (IVar a) a Trace
| forall a . New (IVarContents a) (IVar a -> Trace)
| Fork Trace Trace
| Done
| Yield Trace
| forall a . LiftIO (IO a) (a -> Trace)
sched :: Bool -> Sched -> Trace -> IO ()
sched :: Bool -> Sched -> Trace -> IO ()
sched _doSync :: Bool
_doSync queue :: Sched
queue t :: Trace
t = Trace -> IO ()
loop Trace
t
where
loop :: Trace -> IO ()
loop t :: Trace
t = case Trace
t of
New a :: IVarContents a
a f :: IVar a -> Trace
f -> do
IORef (IVarContents a)
r <- IVarContents a -> IO (IORef (IVarContents a))
forall a. a -> IO (IORef a)
newIORef IVarContents a
a
Trace -> IO ()
loop (IVar a -> Trace
f (IORef (IVarContents a) -> IVar a
forall a. IORef (IVarContents a) -> IVar a
IVar IORef (IVarContents a)
r))
Get (IVar v :: IORef (IVarContents a)
v) c :: a -> Trace
c -> do
IVarContents a
e <- IORef (IVarContents a) -> IO (IVarContents a)
forall a. IORef a -> IO a
readIORef IORef (IVarContents a)
v
case IVarContents a
e of
Full a :: a
a -> Trace -> IO ()
loop (a -> Trace
c a
a)
_other :: IVarContents a
_other -> do
IO ()
r <- IORef (IVarContents a)
-> (IVarContents a -> (IVarContents a, IO ())) -> IO (IO ())
forall a b. IORef a -> (a -> (a, b)) -> IO b
atomicModifyIORef IORef (IVarContents a)
v ((IVarContents a -> (IVarContents a, IO ())) -> IO (IO ()))
-> (IVarContents a -> (IVarContents a, IO ())) -> IO (IO ())
forall a b. (a -> b) -> a -> b
$ \e :: IVarContents a
e -> case IVarContents a
e of
Empty -> ([a -> Trace] -> IVarContents a
forall a. [a -> Trace] -> IVarContents a
Blocked [a -> Trace
c], Sched -> IO ()
reschedule Sched
queue)
Full a :: a
a -> (a -> IVarContents a
forall a. a -> IVarContents a
Full a
a, Trace -> IO ()
loop (a -> Trace
c a
a))
Blocked cs :: [a -> Trace]
cs -> ([a -> Trace] -> IVarContents a
forall a. [a -> Trace] -> IVarContents a
Blocked (a -> Trace
c(a -> Trace) -> [a -> Trace] -> [a -> Trace]
forall a. a -> [a] -> [a]
:[a -> Trace]
cs), Sched -> IO ()
reschedule Sched
queue)
IO ()
r
Put (IVar v :: IORef (IVarContents a)
v) a :: a
a t :: Trace
t -> do
[a -> Trace]
cs <- IORef (IVarContents a)
-> (IVarContents a -> (IVarContents a, [a -> Trace]))
-> IO [a -> Trace]
forall a b. IORef a -> (a -> (a, b)) -> IO b
atomicModifyIORef IORef (IVarContents a)
v ((IVarContents a -> (IVarContents a, [a -> Trace]))
-> IO [a -> Trace])
-> (IVarContents a -> (IVarContents a, [a -> Trace]))
-> IO [a -> Trace]
forall a b. (a -> b) -> a -> b
$ \e :: IVarContents a
e -> case IVarContents a
e of
Empty -> (a -> IVarContents a
forall a. a -> IVarContents a
Full a
a, [])
Full _ -> [Char] -> (IVarContents a, [a -> Trace])
forall a. HasCallStack => [Char] -> a
error "multiple put"
Blocked cs :: [a -> Trace]
cs -> (a -> IVarContents a
forall a. a -> IVarContents a
Full a
a, [a -> Trace]
cs)
((a -> Trace) -> IO ()) -> [a -> Trace] -> IO ()
forall (t :: * -> *) (m :: * -> *) a b.
(Foldable t, Monad m) =>
(a -> m b) -> t a -> m ()
mapM_ (Sched -> Trace -> IO ()
pushWork Sched
queue(Trace -> IO ())
-> ((a -> Trace) -> Trace) -> (a -> Trace) -> IO ()
forall b c a. (b -> c) -> (a -> b) -> a -> c
. ((a -> Trace) -> a -> Trace
forall a b. (a -> b) -> a -> b
$a
a)) [a -> Trace]
cs
Trace -> IO ()
loop Trace
t
Fork child :: Trace
child parent :: Trace
parent -> do
Sched -> Trace -> IO ()
pushWork Sched
queue Trace
child
Trace -> IO ()
loop Trace
parent
Done ->
if Bool
_doSync
then Sched -> IO ()
reschedule Sched
queue
else do [Char] -> IO ()
putStrLn " [par] Forking replacement thread..\n"
IO () -> IO ThreadId
forkIO (Sched -> IO ()
reschedule Sched
queue); () -> IO ()
forall (m :: * -> *) a. Monad m => a -> m a
return ()
Yield parent :: Trace
parent -> do
let Sched { IORef [Trace]
workpool :: Sched -> IORef [Trace]
workpool :: IORef [Trace]
workpool } = Sched
queue
IORef [Trace] -> ([Trace] -> ([Trace], ())) -> IO ()
forall a b. IORef a -> (a -> (a, b)) -> IO b
atomicModifyIORef IORef [Trace]
workpool (([Trace] -> ([Trace], ())) -> IO ())
-> ([Trace] -> ([Trace], ())) -> IO ()
forall a b. (a -> b) -> a -> b
$ \ts :: [Trace]
ts -> ([Trace]
ts[Trace] -> [Trace] -> [Trace]
forall a. [a] -> [a] -> [a]
++[Trace
parent], ())
Sched -> IO ()
reschedule Sched
queue
LiftIO io :: IO a
io c :: a -> Trace
c -> do
a
r <- IO a
io
Trace -> IO ()
loop (a -> Trace
c a
r)
data FixParException = FixParException deriving Int -> FixParException -> ShowS
[FixParException] -> ShowS
FixParException -> [Char]
(Int -> FixParException -> ShowS)
-> (FixParException -> [Char])
-> ([FixParException] -> ShowS)
-> Show FixParException
forall a.
(Int -> a -> ShowS) -> (a -> [Char]) -> ([a] -> ShowS) -> Show a
showList :: [FixParException] -> ShowS
$cshowList :: [FixParException] -> ShowS
show :: FixParException -> [Char]
$cshow :: FixParException -> [Char]
showsPrec :: Int -> FixParException -> ShowS
$cshowsPrec :: Int -> FixParException -> ShowS
Show
instance Exception FixParException
reschedule :: Sched -> IO ()
reschedule :: Sched -> IO ()
reschedule queue :: Sched
queue@Sched{ IORef [Trace]
workpool :: IORef [Trace]
workpool :: Sched -> IORef [Trace]
workpool } = do
Maybe Trace
e <- IORef [Trace]
-> ([Trace] -> ([Trace], Maybe Trace)) -> IO (Maybe Trace)
forall a b. IORef a -> (a -> (a, b)) -> IO b
atomicModifyIORef IORef [Trace]
workpool (([Trace] -> ([Trace], Maybe Trace)) -> IO (Maybe Trace))
-> ([Trace] -> ([Trace], Maybe Trace)) -> IO (Maybe Trace)
forall a b. (a -> b) -> a -> b
$ \ts :: [Trace]
ts ->
case [Trace]
ts of
[] -> ([], Maybe Trace
forall a. Maybe a
Nothing)
(t :: Trace
t:ts' :: [Trace]
ts') -> ([Trace]
ts', Trace -> Maybe Trace
forall a. a -> Maybe a
Just Trace
t)
case Maybe Trace
e of
Nothing -> Sched -> IO ()
steal Sched
queue
Just t :: Trace
t -> Bool -> Sched -> Trace -> IO ()
sched Bool
True Sched
queue Trace
t
steal :: Sched -> IO ()
steal :: Sched -> IO ()
steal q :: Sched
q@Sched{ IORef [MVar Bool]
idle :: Sched -> IORef [MVar Bool]
idle :: IORef [MVar Bool]
idle, [Sched]
scheds :: Sched -> [Sched]
scheds :: [Sched]
scheds, no :: Sched -> Int
no=Int
my_no } = do
[Sched] -> IO ()
go [Sched]
scheds
where
go :: [Sched] -> IO ()
go [] = do MVar Bool
m <- IO (MVar Bool)
forall a. IO (MVar a)
newEmptyMVar
[MVar Bool]
r <- IORef [MVar Bool]
-> ([MVar Bool] -> ([MVar Bool], [MVar Bool])) -> IO [MVar Bool]
forall a b. IORef a -> (a -> (a, b)) -> IO b
atomicModifyIORef IORef [MVar Bool]
idle (([MVar Bool] -> ([MVar Bool], [MVar Bool])) -> IO [MVar Bool])
-> ([MVar Bool] -> ([MVar Bool], [MVar Bool])) -> IO [MVar Bool]
forall a b. (a -> b) -> a -> b
$ \is :: [MVar Bool]
is -> (MVar Bool
mMVar Bool -> [MVar Bool] -> [MVar Bool]
forall a. a -> [a] -> [a]
:[MVar Bool]
is, [MVar Bool]
is)
if [MVar Bool] -> Int
forall (t :: * -> *) a. Foldable t => t a -> Int
length [MVar Bool]
r Int -> Int -> Bool
forall a. Eq a => a -> a -> Bool
== Int
numCapabilities Int -> Int -> Int
forall a. Num a => a -> a -> a
- 1
then do
(MVar Bool -> IO ()) -> [MVar Bool] -> IO ()
forall (t :: * -> *) (m :: * -> *) a b.
(Foldable t, Monad m) =>
(a -> m b) -> t a -> m ()
mapM_ (\m :: MVar Bool
m -> MVar Bool -> Bool -> IO ()
forall a. MVar a -> a -> IO ()
putMVar MVar Bool
m Bool
True) [MVar Bool]
r
else do
Bool
done <- MVar Bool -> IO Bool
forall a. MVar a -> IO a
takeMVar MVar Bool
m
if Bool
done
then do
() -> IO ()
forall (m :: * -> *) a. Monad m => a -> m a
return ()
else do
[Sched] -> IO ()
go [Sched]
scheds
go (x :: Sched
x:xs :: [Sched]
xs)
| Sched -> Int
no Sched
x Int -> Int -> Bool
forall a. Eq a => a -> a -> Bool
== Int
my_no = [Sched] -> IO ()
go [Sched]
xs
| Bool
otherwise = do
Maybe Trace
r <- IORef [Trace]
-> ([Trace] -> ([Trace], Maybe Trace)) -> IO (Maybe Trace)
forall a b. IORef a -> (a -> (a, b)) -> IO b
atomicModifyIORef (Sched -> IORef [Trace]
workpool Sched
x) (([Trace] -> ([Trace], Maybe Trace)) -> IO (Maybe Trace))
-> ([Trace] -> ([Trace], Maybe Trace)) -> IO (Maybe Trace)
forall a b. (a -> b) -> a -> b
$ \ ts :: [Trace]
ts ->
case [Trace]
ts of
[] -> ([], Maybe Trace
forall a. Maybe a
Nothing)
(x :: Trace
x:xs :: [Trace]
xs) -> ([Trace]
xs, Trace -> Maybe Trace
forall a. a -> Maybe a
Just Trace
x)
case Maybe Trace
r of
Just t :: Trace
t -> do
Bool -> Sched -> Trace -> IO ()
sched Bool
True Sched
q Trace
t
Nothing -> [Sched] -> IO ()
go [Sched]
xs
pushWork :: Sched -> Trace -> IO ()
pushWork :: Sched -> Trace -> IO ()
pushWork Sched { IORef [Trace]
workpool :: IORef [Trace]
workpool :: Sched -> IORef [Trace]
workpool, IORef [MVar Bool]
idle :: IORef [MVar Bool]
idle :: Sched -> IORef [MVar Bool]
idle } t :: Trace
t = do
IORef [Trace] -> ([Trace] -> ([Trace], ())) -> IO ()
forall a b. IORef a -> (a -> (a, b)) -> IO b
atomicModifyIORef IORef [Trace]
workpool (([Trace] -> ([Trace], ())) -> IO ())
-> ([Trace] -> ([Trace], ())) -> IO ()
forall a b. (a -> b) -> a -> b
$ \ts :: [Trace]
ts -> (Trace
tTrace -> [Trace] -> [Trace]
forall a. a -> [a] -> [a]
:[Trace]
ts, ())
[MVar Bool]
idles <- IORef [MVar Bool] -> IO [MVar Bool]
forall a. IORef a -> IO a
readIORef IORef [MVar Bool]
idle
Bool -> IO () -> IO ()
forall (f :: * -> *). Applicative f => Bool -> f () -> f ()
when (Bool -> Bool
not ([MVar Bool] -> Bool
forall (t :: * -> *) a. Foldable t => t a -> Bool
null [MVar Bool]
idles)) (IO () -> IO ()) -> IO () -> IO ()
forall a b. (a -> b) -> a -> b
$ do
IO ()
r <- IORef [MVar Bool]
-> ([MVar Bool] -> ([MVar Bool], IO ())) -> IO (IO ())
forall a b. IORef a -> (a -> (a, b)) -> IO b
atomicModifyIORef IORef [MVar Bool]
idle (\is :: [MVar Bool]
is -> case [MVar Bool]
is of
[] -> ([], () -> IO ()
forall (m :: * -> *) a. Monad m => a -> m a
return ())
(i :: MVar Bool
i:is :: [MVar Bool]
is) -> ([MVar Bool]
is, MVar Bool -> Bool -> IO ()
forall a. MVar a -> a -> IO ()
putMVar MVar Bool
i Bool
False))
IO ()
r
data Sched = Sched
{ Sched -> Int
no :: {-# UNPACK #-} !Int,
Sched -> IORef [Trace]
workpool :: IORef [Trace],
Sched -> IORef [MVar Bool]
idle :: IORef [MVar Bool],
Sched -> [Sched]
scheds :: [Sched]
}
newtype Par a = Par {
Par a -> (a -> Trace) -> Trace
runCont :: (a -> Trace) -> Trace
}
instance Functor Par where
fmap :: (a -> b) -> Par a -> Par b
fmap f :: a -> b
f m :: Par a
m = ((b -> Trace) -> Trace) -> Par b
forall a. ((a -> Trace) -> Trace) -> Par a
Par (((b -> Trace) -> Trace) -> Par b)
-> ((b -> Trace) -> Trace) -> Par b
forall a b. (a -> b) -> a -> b
$ \c :: b -> Trace
c -> Par a -> (a -> Trace) -> Trace
forall a. Par a -> (a -> Trace) -> Trace
runCont Par a
m (b -> Trace
c (b -> Trace) -> (a -> b) -> a -> Trace
forall b c a. (b -> c) -> (a -> b) -> a -> c
. a -> b
f)
instance Monad Par where
return :: a -> Par a
return = a -> Par a
forall (f :: * -> *) a. Applicative f => a -> f a
pure
m :: Par a
m >>= :: Par a -> (a -> Par b) -> Par b
>>= k :: a -> Par b
k = ((b -> Trace) -> Trace) -> Par b
forall a. ((a -> Trace) -> Trace) -> Par a
Par (((b -> Trace) -> Trace) -> Par b)
-> ((b -> Trace) -> Trace) -> Par b
forall a b. (a -> b) -> a -> b
$ \c :: b -> Trace
c -> Par a -> (a -> Trace) -> Trace
forall a. Par a -> (a -> Trace) -> Trace
runCont Par a
m ((a -> Trace) -> Trace) -> (a -> Trace) -> Trace
forall a b. (a -> b) -> a -> b
$ \a :: a
a -> Par b -> (b -> Trace) -> Trace
forall a. Par a -> (a -> Trace) -> Trace
runCont (a -> Par b
k a
a) b -> Trace
c
instance Applicative Par where
<*> :: Par (a -> b) -> Par a -> Par b
(<*>) = Par (a -> b) -> Par a -> Par b
forall (m :: * -> *) a b. Monad m => m (a -> b) -> m a -> m b
ap
pure :: a -> Par a
pure a :: a
a = ((a -> Trace) -> Trace) -> Par a
forall a. ((a -> Trace) -> Trace) -> Par a
Par ((a -> Trace) -> a -> Trace
forall a b. (a -> b) -> a -> b
$ a
a)
instance MonadFix Par where
mfix :: (a -> Par a) -> Par a
mfix = (a -> Par a) -> Par a
forall a. (a -> Par a) -> Par a
fixPar
fixPar :: (a -> Par a) -> Par a
fixPar :: (a -> Par a) -> Par a
fixPar f :: a -> Par a
f = ((a -> Trace) -> Trace) -> Par a
forall a. ((a -> Trace) -> Trace) -> Par a
Par (((a -> Trace) -> Trace) -> Par a)
-> ((a -> Trace) -> Trace) -> Par a
forall a b. (a -> b) -> a -> b
$ \ c :: a -> Trace
c ->
IO Trace -> (Trace -> Trace) -> Trace
forall a. IO a -> (a -> Trace) -> Trace
LiftIO (do
MVar a
mv <- IO (MVar a)
forall a. IO (MVar a)
newEmptyMVar
a
ans <- IO a -> IO a
forall a. IO a -> IO a
unsafeDupableInterleaveIO (MVar a -> IO a
forall a. MVar a -> IO a
readMVar MVar a
mv
IO a -> (BlockedIndefinitelyOnMVar -> IO a) -> IO a
forall e a. Exception e => IO a -> (e -> IO a) -> IO a
`catch` \ ~BlockedIndefinitelyOnMVar
BlockedIndefinitelyOnMVar -> FixParException -> IO a
forall e a. Exception e => e -> IO a
throwIO FixParException
FixParException)
case a -> Par a
f a
ans of
Par q :: (a -> Trace) -> Trace
q -> Trace -> IO Trace
forall (f :: * -> *) a. Applicative f => a -> f a
pure (Trace -> IO Trace) -> Trace -> IO Trace
forall a b. (a -> b) -> a -> b
$ (a -> Trace) -> Trace
q ((a -> Trace) -> Trace) -> (a -> Trace) -> Trace
forall a b. (a -> b) -> a -> b
$ \a :: a
a -> IO () -> (() -> Trace) -> Trace
forall a. IO a -> (a -> Trace) -> Trace
LiftIO (MVar a -> a -> IO ()
forall a. MVar a -> a -> IO ()
putMVar MVar a
mv a
a) (\ ~() -> a -> Trace
c a
a)) Trace -> Trace
forall a. a -> a
id
#if !MIN_VERSION_base(4,4,0)
unsafeDupableInterleaveIO :: IO a -> IO a
unsafeDupableInterleaveIO = unsafeInterleaveIO
#endif
newtype IVar a = IVar (IORef (IVarContents a))
instance Eq (IVar a) where
(IVar r1 :: IORef (IVarContents a)
r1) == :: IVar a -> IVar a -> Bool
== (IVar r2 :: IORef (IVarContents a)
r2) = IORef (IVarContents a)
r1 IORef (IVarContents a) -> IORef (IVarContents a) -> Bool
forall a. Eq a => a -> a -> Bool
== IORef (IVarContents a)
r2
instance NFData (IVar a) where
rnf :: IVar a -> ()
rnf !IVar a
_ = ()
pollIVar :: IVar a -> IO (Maybe a)
pollIVar :: IVar a -> IO (Maybe a)
pollIVar (IVar ref :: IORef (IVarContents a)
ref) =
do IVarContents a
contents <- IORef (IVarContents a) -> IO (IVarContents a)
forall a. IORef a -> IO a
readIORef IORef (IVarContents a)
ref
case IVarContents a
contents of
Full x :: a
x -> Maybe a -> IO (Maybe a)
forall (m :: * -> *) a. Monad m => a -> m a
return (a -> Maybe a
forall a. a -> Maybe a
Just a
x)
_ -> Maybe a -> IO (Maybe a)
forall (m :: * -> *) a. Monad m => a -> m a
return (Maybe a
forall a. Maybe a
Nothing)
data IVarContents a = Full a | Empty | Blocked [a -> Trace]
{-# INLINE runPar_internal #-}
runPar_internal :: Bool -> Par a -> IO a
runPar_internal :: Bool -> Par a -> IO a
runPar_internal _doSync :: Bool
_doSync x :: Par a
x = do
[IORef [Trace]]
workpools <- Int -> IO (IORef [Trace]) -> IO [IORef [Trace]]
forall (m :: * -> *) a. Applicative m => Int -> m a -> m [a]
replicateM Int
numCapabilities (IO (IORef [Trace]) -> IO [IORef [Trace]])
-> IO (IORef [Trace]) -> IO [IORef [Trace]]
forall a b. (a -> b) -> a -> b
$ [Trace] -> IO (IORef [Trace])
forall a. a -> IO (IORef a)
newIORef []
IORef [MVar Bool]
idle <- [MVar Bool] -> IO (IORef [MVar Bool])
forall a. a -> IO (IORef a)
newIORef []
let states :: [Sched]
states = [ $WSched :: Int -> IORef [Trace] -> IORef [MVar Bool] -> [Sched] -> Sched
Sched { no :: Int
no=Int
x, workpool :: IORef [Trace]
workpool=IORef [Trace]
wp, IORef [MVar Bool]
idle :: IORef [MVar Bool]
idle :: IORef [MVar Bool]
idle, scheds :: [Sched]
scheds=[Sched]
states }
| (x :: Int
x,wp :: IORef [Trace]
wp) <- [Int] -> [IORef [Trace]] -> [(Int, IORef [Trace])]
forall a b. [a] -> [b] -> [(a, b)]
zip [0..] [IORef [Trace]]
workpools ]
#if __GLASGOW_HASKELL__ >= 701 /* 20110301 */
(main_cpu :: Int
main_cpu, _) <- ThreadId -> IO (Int, Bool)
threadCapability (ThreadId -> IO (Int, Bool)) -> IO ThreadId -> IO (Int, Bool)
forall (m :: * -> *) a b. Monad m => (a -> m b) -> m a -> m b
=<< IO ThreadId
myThreadId
#else
let main_cpu = 0
#endif
MVar (IVarContents a)
m <- IO (MVar (IVarContents a))
forall a. IO (MVar a)
newEmptyMVar
[(Int, Sched)] -> ((Int, Sched) -> IO ThreadId) -> IO ()
forall (t :: * -> *) (m :: * -> *) a b.
(Foldable t, Monad m) =>
t a -> (a -> m b) -> m ()
forM_ ([Int] -> [Sched] -> [(Int, Sched)]
forall a b. [a] -> [b] -> [(a, b)]
zip [0..] [Sched]
states) (((Int, Sched) -> IO ThreadId) -> IO ())
-> ((Int, Sched) -> IO ThreadId) -> IO ()
forall a b. (a -> b) -> a -> b
$ \(cpu :: Int
cpu,state :: Sched
state) ->
Int -> IO () -> IO ThreadId
forkOn Int
cpu (IO () -> IO ThreadId) -> IO () -> IO ThreadId
forall a b. (a -> b) -> a -> b
$
if (Int
cpu Int -> Int -> Bool
forall a. Eq a => a -> a -> Bool
/= Int
main_cpu)
then Sched -> IO ()
reschedule Sched
state
else do
IORef (IVarContents a)
rref <- IVarContents a -> IO (IORef (IVarContents a))
forall a. a -> IO (IORef a)
newIORef IVarContents a
forall a. IVarContents a
Empty
Bool -> Sched -> Trace -> IO ()
sched Bool
_doSync Sched
state (Trace -> IO ()) -> Trace -> IO ()
forall a b. (a -> b) -> a -> b
$ Par () -> (() -> Trace) -> Trace
forall a. Par a -> (a -> Trace) -> Trace
runCont (Par a
x Par a -> (a -> Par ()) -> Par ()
forall (m :: * -> *) a b. Monad m => m a -> (a -> m b) -> m b
>>= IVar a -> a -> Par ()
forall a. IVar a -> a -> Par ()
put_ (IORef (IVarContents a) -> IVar a
forall a. IORef (IVarContents a) -> IVar a
IVar IORef (IVarContents a)
rref)) (Trace -> () -> Trace
forall a b. a -> b -> a
const Trace
Done)
IORef (IVarContents a) -> IO (IVarContents a)
forall a. IORef a -> IO a
readIORef IORef (IVarContents a)
rref IO (IVarContents a) -> (IVarContents a -> IO ()) -> IO ()
forall (m :: * -> *) a b. Monad m => m a -> (a -> m b) -> m b
>>= MVar (IVarContents a) -> IVarContents a -> IO ()
forall a. MVar a -> a -> IO ()
putMVar MVar (IVarContents a)
m
IVarContents a
r <- MVar (IVarContents a) -> IO (IVarContents a)
forall a. MVar a -> IO a
takeMVar MVar (IVarContents a)
m
case IVarContents a
r of
Full a :: a
a -> a -> IO a
forall (m :: * -> *) a. Monad m => a -> m a
return a
a
_ -> [Char] -> IO a
forall a. HasCallStack => [Char] -> a
error "no result"
runPar :: Par a -> a
runPar :: Par a -> a
runPar = IO a -> a
forall a. IO a -> a
unsafePerformIO (IO a -> a) -> (Par a -> IO a) -> Par a -> a
forall b c a. (b -> c) -> (a -> b) -> a -> c
. Bool -> Par a -> IO a
forall a. Bool -> Par a -> IO a
runPar_internal Bool
True
runParIO :: Par a -> IO a
runParIO :: Par a -> IO a
runParIO = Bool -> Par a -> IO a
forall a. Bool -> Par a -> IO a
runPar_internal Bool
True
runParAsync :: Par a -> a
runParAsync :: Par a -> a
runParAsync = IO a -> a
forall a. IO a -> a
unsafePerformIO (IO a -> a) -> (Par a -> IO a) -> Par a -> a
forall b c a. (b -> c) -> (a -> b) -> a -> c
. Bool -> Par a -> IO a
forall a. Bool -> Par a -> IO a
runPar_internal Bool
False
new :: Par (IVar a)
new :: Par (IVar a)
new = ((IVar a -> Trace) -> Trace) -> Par (IVar a)
forall a. ((a -> Trace) -> Trace) -> Par a
Par (((IVar a -> Trace) -> Trace) -> Par (IVar a))
-> ((IVar a -> Trace) -> Trace) -> Par (IVar a)
forall a b. (a -> b) -> a -> b
$ IVarContents a -> (IVar a -> Trace) -> Trace
forall a. IVarContents a -> (IVar a -> Trace) -> Trace
New IVarContents a
forall a. IVarContents a
Empty
newFull :: NFData a => a -> Par (IVar a)
newFull :: a -> Par (IVar a)
newFull x :: a
x = ((IVar a -> Trace) -> Trace) -> Par (IVar a)
forall a. ((a -> Trace) -> Trace) -> Par a
Par (((IVar a -> Trace) -> Trace) -> Par (IVar a))
-> ((IVar a -> Trace) -> Trace) -> Par (IVar a)
forall a b. (a -> b) -> a -> b
$ \c :: IVar a -> Trace
c -> a
x a -> Trace -> Trace
forall a b. NFData a => a -> b -> b
`deepseq` IVarContents a -> (IVar a -> Trace) -> Trace
forall a. IVarContents a -> (IVar a -> Trace) -> Trace
New (a -> IVarContents a
forall a. a -> IVarContents a
Full a
x) IVar a -> Trace
c
newFull_ :: a -> Par (IVar a)
newFull_ :: a -> Par (IVar a)
newFull_ !a
x = ((IVar a -> Trace) -> Trace) -> Par (IVar a)
forall a. ((a -> Trace) -> Trace) -> Par a
Par (((IVar a -> Trace) -> Trace) -> Par (IVar a))
-> ((IVar a -> Trace) -> Trace) -> Par (IVar a)
forall a b. (a -> b) -> a -> b
$ IVarContents a -> (IVar a -> Trace) -> Trace
forall a. IVarContents a -> (IVar a -> Trace) -> Trace
New (a -> IVarContents a
forall a. a -> IVarContents a
Full a
x)
get :: IVar a -> Par a
get :: IVar a -> Par a
get v :: IVar a
v = ((a -> Trace) -> Trace) -> Par a
forall a. ((a -> Trace) -> Trace) -> Par a
Par (((a -> Trace) -> Trace) -> Par a)
-> ((a -> Trace) -> Trace) -> Par a
forall a b. (a -> b) -> a -> b
$ \c :: a -> Trace
c -> IVar a -> (a -> Trace) -> Trace
forall a. IVar a -> (a -> Trace) -> Trace
Get IVar a
v a -> Trace
c
put_ :: IVar a -> a -> Par ()
put_ :: IVar a -> a -> Par ()
put_ v :: IVar a
v !a
a = ((() -> Trace) -> Trace) -> Par ()
forall a. ((a -> Trace) -> Trace) -> Par a
Par (((() -> Trace) -> Trace) -> Par ())
-> ((() -> Trace) -> Trace) -> Par ()
forall a b. (a -> b) -> a -> b
$ \c :: () -> Trace
c -> IVar a -> a -> Trace -> Trace
forall a. IVar a -> a -> Trace -> Trace
Put IVar a
v a
a (() -> Trace
c ())
put :: NFData a => IVar a -> a -> Par ()
put :: IVar a -> a -> Par ()
put v :: IVar a
v a :: a
a = ((() -> Trace) -> Trace) -> Par ()
forall a. ((a -> Trace) -> Trace) -> Par a
Par (((() -> Trace) -> Trace) -> Par ())
-> ((() -> Trace) -> Trace) -> Par ()
forall a b. (a -> b) -> a -> b
$ \c :: () -> Trace
c -> a
a a -> Trace -> Trace
forall a b. NFData a => a -> b -> b
`deepseq` IVar a -> a -> Trace -> Trace
forall a. IVar a -> a -> Trace -> Trace
Put IVar a
v a
a (() -> Trace
c ())
yield :: Par ()
yield :: Par ()
yield = ((() -> Trace) -> Trace) -> Par ()
forall a. ((a -> Trace) -> Trace) -> Par a
Par (((() -> Trace) -> Trace) -> Par ())
-> ((() -> Trace) -> Trace) -> Par ()
forall a b. (a -> b) -> a -> b
$ \c :: () -> Trace
c -> Trace -> Trace
Yield (() -> Trace
c ())