    {-# 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 -> 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

    -- | 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 = 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

    -- 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     = 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 = id
    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."
    -- 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