{-# LANGUAGE PackageImports, CPP, GeneralizedNewtypeDeriving,
DeriveDataTypeable #-}
module Control.Monad.Par.Scheds.DirectInternal where
#if !MIN_VERSION_base(4,6,0)
import Prelude hiding (catch)
#endif
import Control.Applicative
import "mtl" Control.Monad.Cont as C
import qualified "mtl" Control.Monad.Reader as RD
import "mtl" Control.Monad.Trans (liftIO)
import qualified System.Random.MWC as Random
import Control.Concurrent hiding (yield)
import GHC.Conc
import Data.IORef
import qualified Data.Set as S
import Data.Word (Word64)
import Data.Concurrent.Deque.Class (WSDeque)
import Control.Monad.Fix (MonadFix (mfix))
#if MIN_VERSION_base(4,9,0)
import GHC.IO.Unsafe (unsafeDupableInterleaveIO)
#else
import System.IO.Unsafe (unsafeInterleaveIO)
#endif
#ifdef USE_CHASELEV
#warning "Note: using Chase-Lev lockfree workstealing deques..."
import Data.Concurrent.Deque.ChaseLev.DequeInstance
import Data.Concurrent.Deque.ChaseLev as R
#endif
import Data.Typeable (Typeable)
import Control.Exception (Exception, throwIO, BlockedIndefinitelyOnMVar (..),
catch)
newtype Par a = Par { forall a. Par a -> ContT () ROnly a
unPar :: C.ContT () ROnly a }
deriving ((forall a b. (a -> b) -> Par a -> Par b)
-> (forall a b. a -> Par b -> Par a) -> Functor Par
forall a b. a -> Par b -> Par a
forall a b. (a -> b) -> Par a -> Par b
forall (f :: * -> *).
(forall a b. (a -> b) -> f a -> f b)
-> (forall a b. a -> f b -> f a) -> Functor f
$cfmap :: forall a b. (a -> b) -> Par a -> Par b
fmap :: forall a b. (a -> b) -> Par a -> Par b
$c<$ :: forall a b. a -> Par b -> Par a
<$ :: forall a b. a -> Par b -> Par a
Functor, Functor Par
Functor Par =>
(forall a. a -> Par a)
-> (forall a b. Par (a -> b) -> Par a -> Par b)
-> (forall a b c. (a -> b -> c) -> Par a -> Par b -> Par c)
-> (forall a b. Par a -> Par b -> Par b)
-> (forall a b. Par a -> Par b -> Par a)
-> Applicative Par
forall a. a -> Par a
forall a b. Par a -> Par b -> Par a
forall a b. Par a -> Par b -> Par b
forall a b. Par (a -> b) -> Par a -> Par b
forall a b c. (a -> b -> c) -> Par a -> Par b -> Par c
forall (f :: * -> *).
Functor f =>
(forall a. a -> f a)
-> (forall a b. f (a -> b) -> f a -> f b)
-> (forall a b c. (a -> b -> c) -> f a -> f b -> f c)
-> (forall a b. f a -> f b -> f b)
-> (forall a b. f a -> f b -> f a)
-> Applicative f
$cpure :: forall a. a -> Par a
pure :: forall a. a -> Par a
$c<*> :: forall a b. Par (a -> b) -> Par a -> Par b
<*> :: forall a b. Par (a -> b) -> Par a -> Par b
$cliftA2 :: forall a b c. (a -> b -> c) -> Par a -> Par b -> Par c
liftA2 :: forall a b c. (a -> b -> c) -> Par a -> Par b -> Par c
$c*> :: forall a b. Par a -> Par b -> Par b
*> :: forall a b. Par a -> Par b -> Par b
$c<* :: forall a b. Par a -> Par b -> Par a
<* :: forall a b. Par a -> Par b -> Par a
Applicative, Applicative Par
Applicative Par =>
(forall a b. Par a -> (a -> Par b) -> Par b)
-> (forall a b. Par a -> Par b -> Par b)
-> (forall a. a -> Par a)
-> Monad Par
forall a. a -> Par a
forall a b. Par a -> Par b -> Par b
forall a b. Par a -> (a -> Par b) -> Par b
forall (m :: * -> *).
Applicative m =>
(forall a b. m a -> (a -> m b) -> m b)
-> (forall a b. m a -> m b -> m b)
-> (forall a. a -> m a)
-> Monad m
$c>>= :: forall a b. Par a -> (a -> Par b) -> Par b
>>= :: forall a b. Par a -> (a -> Par b) -> Par b
$c>> :: forall a b. Par a -> Par b -> Par b
>> :: forall a b. Par a -> Par b -> Par b
$creturn :: forall a. a -> Par a
return :: forall a. a -> Par a
Monad, Monad Par
Monad Par =>
(forall a b. ((a -> Par b) -> Par a) -> Par a) -> MonadCont Par
forall a b. ((a -> Par b) -> Par a) -> Par a
forall (m :: * -> *).
Monad m =>
(forall a b. ((a -> m b) -> m a) -> m a) -> MonadCont m
$ccallCC :: forall a b. ((a -> Par b) -> Par a) -> Par a
callCC :: forall a b. ((a -> Par b) -> Par a) -> Par a
MonadCont, RD.MonadReader Sched)
type ROnly = RD.ReaderT Sched IO
instance MonadFix Par where
mfix :: forall a. (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 :: forall a. (a -> Par a) -> Par a
fixPar a -> Par a
f = ContT () ROnly a -> Par a
forall a. ContT () ROnly a -> Par a
Par (ContT () ROnly a -> Par a) -> ContT () ROnly a -> Par a
forall a b. (a -> b) -> a -> b
$ ((a -> ROnly ()) -> ROnly ()) -> ContT () ROnly a
forall {k} (r :: k) (m :: k -> *) a.
((a -> m r) -> m r) -> ContT r m a
ContT (((a -> ROnly ()) -> ROnly ()) -> ContT () ROnly a)
-> ((a -> ROnly ()) -> ROnly ()) -> ContT () ROnly a
forall a b. (a -> b) -> a -> b
$ \a -> ROnly ()
ar -> (Sched -> IO ()) -> ROnly ()
forall r (m :: * -> *) a. (r -> m a) -> ReaderT r m a
RD.ReaderT ((Sched -> IO ()) -> ROnly ()) -> (Sched -> IO ()) -> ROnly ()
forall a b. (a -> b) -> a -> b
$ \Sched
sched -> 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)
(ROnly () -> Sched -> IO ()) -> Sched -> ROnly () -> IO ()
forall a b c. (a -> b -> c) -> b -> a -> c
flip ROnly () -> Sched -> IO ()
forall r (m :: * -> *) a. ReaderT r m a -> r -> m a
RD.runReaderT Sched
sched (ROnly () -> IO ()) -> ROnly () -> IO ()
forall a b. (a -> b) -> a -> b
$
ContT () ROnly a -> (a -> ROnly ()) -> ROnly ()
forall {k} (r :: k) (m :: k -> *) a.
ContT r m a -> (a -> m r) -> m r
runContT (Par a -> ContT () ROnly a
forall a. Par a -> ContT () ROnly a
unPar (a -> Par a
f a
ans)) ((a -> ROnly ()) -> ROnly ()) -> (a -> ROnly ()) -> ROnly ()
forall a b. (a -> b) -> a -> b
$ \a
a -> IO () -> ROnly ()
forall a. IO a -> ReaderT Sched IO a
forall (m :: * -> *) a. MonadIO m => IO a -> m a
liftIO (MVar a -> a -> IO ()
forall a. MVar a -> a -> IO ()
putMVar MVar a
mv a
a) ROnly () -> ROnly () -> ROnly ()
forall a b.
ReaderT Sched IO a -> ReaderT Sched IO b -> ReaderT Sched IO b
forall (m :: * -> *) a b. Monad m => m a -> m b -> m b
>> a -> ROnly ()
ar a
a
#if !MIN_VERSION_base(4,9,0)
unsafeDupableInterleaveIO :: IO a -> IO a
unsafeDupableInterleaveIO = unsafeInterleaveIO
#endif
data FixParException = FixParException deriving (Int -> FixParException -> ShowS
[FixParException] -> ShowS
FixParException -> String
(Int -> FixParException -> ShowS)
-> (FixParException -> String)
-> ([FixParException] -> ShowS)
-> Show FixParException
forall a.
(Int -> a -> ShowS) -> (a -> String) -> ([a] -> ShowS) -> Show a
$cshowsPrec :: Int -> FixParException -> ShowS
showsPrec :: Int -> FixParException -> ShowS
$cshow :: FixParException -> String
show :: FixParException -> String
$cshowList :: [FixParException] -> ShowS
showList :: [FixParException] -> ShowS
Show, Typeable)
instance Exception FixParException
type SessionID = Word64
data Session = Session SessionID (HotVar Bool)
data Sched = Sched
{
Sched -> Int
no :: {-# UNPACK #-} !Int,
Sched -> WSDeque (Par ())
workpool :: WSDeque (Par ()),
Sched -> HotVar GenIO
rng :: HotVar Random.GenIO,
Sched -> Bool
isMain :: Bool,
Sched -> HotVar [Session]
sessions :: HotVar [Session],
Sched -> HotVar [MVar Bool]
idle :: HotVar [MVar Bool],
Sched -> [Sched]
scheds :: [Sched],
Sched -> HotVar (Set SessionID)
activeSessions :: HotVar (S.Set SessionID),
Sched -> HotVar SessionID
sessionCounter :: HotVar SessionID
}
#ifndef HOTVAR
#define HOTVAR 1
#endif
newHotVar :: a -> IO (HotVar a)
modifyHotVar :: HotVar a -> (a -> (a,b)) -> IO b
modifyHotVar_ :: HotVar a -> (a -> a) -> IO ()
writeHotVar :: HotVar a -> a -> IO ()
readHotVar :: HotVar a -> IO a
{-# INLINE newHotVar #-}
{-# INLINE modifyHotVar #-}
{-# INLINE modifyHotVar_ #-}
{-# INLINE readHotVar #-}
{-# INLINE writeHotVar #-}
#if HOTVAR == 1
type HotVar a = IORef a
newHotVar :: forall a. a -> IO (HotVar a)
newHotVar = a -> IO (IORef a)
forall a. a -> IO (HotVar a)
newIORef
modifyHotVar :: forall a b. HotVar a -> (a -> (a, b)) -> IO b
modifyHotVar = IORef a -> (a -> (a, b)) -> IO b
forall a b. HotVar a -> (a -> (a, b)) -> IO b
atomicModifyIORef
modifyHotVar_ :: forall a. HotVar a -> (a -> a) -> IO ()
modifyHotVar_ HotVar a
v a -> a
fn = HotVar a -> (a -> (a, ())) -> IO ()
forall a b. HotVar a -> (a -> (a, b)) -> IO b
atomicModifyIORef HotVar a
v (\a
a -> (a -> a
fn a
a, ()))
readHotVar :: forall a. HotVar a -> IO a
readHotVar = IORef a -> IO a
forall a. HotVar a -> IO a
readIORef
writeHotVar :: forall a. HotVar a -> a -> IO ()
writeHotVar = IORef a -> a -> IO ()
forall a. HotVar a -> a -> IO ()
writeIORef
instance Show (IORef a) where
show :: IORef a -> String
show IORef a
_ref = String
"<ioref>"
writeHotVarRaw :: HotVar a -> a -> IO ()
hotVarTransaction :: a
hotVarTransaction = String -> a
forall a. HasCallStack => String -> a
error String
"Transactions not currently possible for IO refs"
readHotVarRaw :: HotVar a -> IO a
readHotVarRaw :: forall a. HotVar a -> IO a
readHotVarRaw = HotVar a -> IO a
forall a. HotVar a -> IO a
readHotVar
writeHotVarRaw :: forall a. HotVar a -> a -> IO ()
writeHotVarRaw = HotVar a -> a -> IO ()
forall a. HotVar a -> a -> IO ()
writeHotVar
#elif HOTVAR == 2
#warning "Using MVars for hot atomic variables."
type HotVar a = MVar a
newHotVar x = do v <- newMVar; putMVar v x; return v
modifyHotVar v fn = modifyMVar v (return . fn)
modifyHotVar_ v fn = modifyMVar_ v (return . fn)
readHotVar = readMVar
writeHotVar v x = do swapMVar v x; return ()
instance Show (MVar a) where
show _ref = "<mvar>"
hotVarTransaction = error "Transactions not currently possible for MVars"
readHotVarRaw = readHotVar
writeHotVarRaw = writeHotVar
#elif HOTVAR == 3
#warning "Using TVars for hot atomic variables."
type HotVar a = TVar a
newHotVar = newTVarIO
modifyHotVar tv fn = atomically (do x <- readTVar tv
let (x2,b) = fn x
writeTVar tv x2
return b)
modifyHotVar_ tv fn = atomically (do x <- readTVar tv; writeTVar tv (fn x))
readHotVar x = atomically $ readTVar x
writeHotVar v x = atomically $ writeTVar v x
instance Show (TVar a) where
show ref = "<tvar>"
hotVarTransaction = atomically
readHotVarRaw = readTVar
writeHotVarRaw = writeTVar
#endif