{-# 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 -> 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
<$ :: forall a b. a -> Par b -> Par a
$c<$ :: forall a b. a -> Par b -> Par a
fmap :: forall a b. (a -> b) -> Par a -> Par b
$cfmap :: forall a b. (a -> b) -> Par a -> Par b
Functor, Functor 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
<* :: forall a b. Par a -> Par b -> Par a
$c<* :: forall a b. Par a -> Par b -> Par a
*> :: forall a b. Par a -> Par b -> Par b
$c*> :: forall a b. Par a -> Par b -> Par b
liftA2 :: forall a b c. (a -> b -> c) -> Par a -> Par b -> Par c
$cliftA2 :: forall a b c. (a -> b -> c) -> Par a -> Par b -> Par c
<*> :: forall a b. Par (a -> b) -> Par a -> Par b
$c<*> :: forall a b. Par (a -> b) -> Par a -> Par b
pure :: forall a. a -> Par a
$cpure :: forall a. a -> Par a
Applicative, Applicative 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
return :: forall a. a -> Par a
$creturn :: forall a. a -> Par a
>> :: forall a b. Par a -> Par b -> Par b
$c>> :: forall a b. Par a -> Par b -> Par b
>>= :: forall a b. Par a -> (a -> Par b) -> Par b
$c>>= :: forall a b. Par a -> (a -> Par b) -> Par b
Monad, Monad 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
callCC :: forall a b. ((a -> Par b) -> Par a) -> Par a
$ccallCC :: 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 = 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 = forall a. ContT () ROnly a -> Par a
Par forall a b. (a -> b) -> a -> b
$ forall {k} (r :: k) (m :: k -> *) a.
((a -> m r) -> m r) -> ContT r m a
ContT forall a b. (a -> b) -> a -> b
$ \a -> ROnly ()
ar -> forall r (m :: * -> *) a. (r -> m a) -> ReaderT r m a
RD.ReaderT forall a b. (a -> b) -> a -> b
$ \Sched
sched -> do
MVar a
mv <- forall a. IO (MVar a)
newEmptyMVar
a
ans <- forall a. IO a -> IO a
unsafeDupableInterleaveIO (forall a. MVar a -> IO a
readMVar MVar a
mv forall e a. Exception e => IO a -> (e -> IO a) -> IO a
`catch`
\ ~BlockedIndefinitelyOnMVar
BlockedIndefinitelyOnMVar -> forall e a. Exception e => e -> IO a
throwIO FixParException
FixParException)
forall a b c. (a -> b -> c) -> b -> a -> c
flip forall r (m :: * -> *) a. ReaderT r m a -> r -> m a
RD.runReaderT Sched
sched forall a b. (a -> b) -> a -> b
$
forall {k} (r :: k) (m :: k -> *) a.
ContT r m a -> (a -> m r) -> m r
runContT (forall a. Par a -> ContT () ROnly a
unPar (a -> Par a
f a
ans)) forall a b. (a -> b) -> a -> b
$ \a
a -> forall (m :: * -> *) a. MonadIO m => IO a -> m a
liftIO (forall a. MVar a -> a -> IO ()
putMVar MVar a
mv a
a) 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
forall a.
(Int -> a -> ShowS) -> (a -> String) -> ([a] -> ShowS) -> Show a
showList :: [FixParException] -> ShowS
$cshowList :: [FixParException] -> ShowS
show :: FixParException -> String
$cshow :: FixParException -> String
showsPrec :: Int -> FixParException -> ShowS
$cshowsPrec :: Int -> 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 = forall a. a -> IO (HotVar a)
newIORef
modifyHotVar :: forall a b. HotVar a -> (a -> (a, b)) -> IO b
modifyHotVar = 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 = 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 = forall a. HotVar a -> IO a
readIORef
writeHotVar :: forall a. HotVar a -> a -> IO ()
writeHotVar = 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 = 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 = forall a. HotVar a -> IO a
readHotVar
writeHotVarRaw :: forall a. HotVar a -> a -> IO ()
writeHotVarRaw = 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