{-# LANGUAGE PackageImports, CPP, GeneralizedNewtypeDeriving,
             DeriveDataTypeable #-}

-- | Type definition and some helpers.  This is used mainly by
-- Direct.hs but can also be used by other modules that want access to
-- the internals of the scheduler (i.e. the private `Par` type constructor).

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)

-- Our monad stack looks like this:
--      ---------
--        ContT
--       ReaderT
--         IO
--      ---------
-- The ReaderT monad is there for retrieving the scheduler given the
-- fact that the API calls do not get it as an argument.
--
-- Note that the result type for continuations is unit.  Forked
-- computations return nothing.
--
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

-- | Take the monadic fixpoint of a 'Par' computation. This is
-- the definition of 'mfix' for 'Par'. Throws 'FixParException'
-- if the result is demanded strictly within the computation.
fixPar :: (a -> Par a) -> Par a
-- We do this IO-style, rather than ST-style, in order to get a
-- consistent exception type. Using the ST-style mfix, a strict
-- argument could lead us to *either* a <<loop>> exception *or*
-- (if the wrong sort of computation gets re-run) a "multiple-put"
-- error.
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

-- An ID along with a flag to signal completion:
data Session = Session SessionID (HotVar Bool)

data Sched = Sched
    {
      ---- Per worker ----
      Sched -> Int
no       :: {-# UNPACK #-} !Int,
      Sched -> WSDeque (Par ())
workpool :: WSDeque (Par ()),
      Sched -> HotVar GenIO
rng      :: HotVar Random.GenIO, -- Random number gen for work stealing.
      Sched -> Bool
isMain :: Bool, -- Are we the main/master thread?

      -- The stack of nested sessions that THIS worker is participating in.
      -- When a session finishes, the worker can return to its Haskell
      -- calling context (it's "real" continuation).
      Sched -> HotVar [Session]
sessions :: HotVar [Session],
      -- (1) This is always non-empty, containing at least the root
      --     session corresponding to the anonymous system workers.
      -- (2) The original invocation of runPar also counts as a session
      --     and pushes a second
      -- (3) Nested runPar invocations may push further sessions onto the stack.

      ---- Global data: ----
      Sched -> HotVar [MVar Bool]
idle     :: HotVar [MVar Bool], -- waiting idle workers
      Sched -> [Sched]
scheds   :: [Sched],            -- A global list of schedulers.

      -- Any thread that enters runPar (original or nested) registers
      -- itself in this global list.  When the list becomes null,
      -- worker threads may shut down or at least go idle.
      Sched -> HotVar (Set SessionID)
activeSessions :: HotVar (S.Set SessionID),

      -- A counter to support unique session IDs:
      Sched -> HotVar SessionID
sessionCounter :: HotVar SessionID
     }


--------------------------------------------------------------------------------
-- Helpers #1:  Atomic Variables
--------------------------------------------------------------------------------
-- TEMP: Experimental

#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
-- readHotVarRaw  :: HotVar a -> m a
-- writeHotVarRaw :: HotVar a -> m 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 = id
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."
-- This uses MVars that are always full with *something*
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 = id
-- We could in theory do this by taking the mvar to grab the lock.
-- But we'd need some temporary storage....
hotVarTransaction = error "Transactions not currently possible for MVars"
readHotVarRaw  = readHotVar
writeHotVarRaw = writeHotVar


#elif HOTVAR == 3
#warning "Using TVars for hot atomic variables."
-- Simon Marlow said he saw better scaling with TVars (surprise to me):
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