    {-# LANGUAGE RankNTypes, NamedFieldPuns, BangPatterns,
                 ExistentialQuantification, CPP #-}
    {-# OPTIONS_GHC -Wall -fno-warn-name-shadowing -fno-warn-unused-do-bind #-}

    -- | This module exposes the internals of the @Par@ monad so that you
    -- can build your own scheduler or other extensions.  Do not use this
    -- module for purposes other than extending the @Par@ monad with new
    -- functionality.

    module Control.Monad.Par.Scheds.TraceInternal (
       Trace(..), Sched(..), Par(..),
       IVar(..), IVarContents(..),
       sched,
       runPar, runParIO, runParAsync,
       -- runParAsyncHelper,
       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)
    -- import Text.Printf

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

    -- | The main scheduler loop.
    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
    -- We could fork an extra thread here to keep numCapabilities workers
    -- even when the main thread returns to the runPar caller...
             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 ()
    -- But even if we don't we are not orphaning any work in this
    -- threads work-queue because it can be stolen by other threads.
    --       else return ()

        Yield parent :: Trace
    parent -> do
            -- Go to the end of the worklist:
            let Sched { IORef [Trace]
    workpool :: Sched -> IORef [Trace]
    workpool :: IORef [Trace]
    workpool } = Sched
    queue
            -- TODO: Perhaps consider Data.Seq here.
            -- This would also be a chance to steal and work from opposite ends of the 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

    -- | Process the next item on the work queue or, failing that, go into
    --   work-stealing mode.
    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

    -- RRN: Note -- NOT doing random work stealing breaks the traditional
    -- Cilk time/space bounds if one is running strictly nested (series
    -- parallel) programs.

    -- | Attempt to steal work or, failing that, give up and go idle.
    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
      -- printf "cpu %d stealing\n" my_no
      [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
                         -- printf "cpu %d initiating shutdown\n" my_no
                         (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
                             -- printf "cpu %d shutting down\n" my_no
                             () -> IO ()
    forall (m :: * -> *) a. Monad m => a -> m a
    return ()
                           else do
                             -- printf "cpu %d woken up\n" my_no
                             [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
                  -- printf "cpu %d got work from cpu %d\n" my_no (no x)
                  Bool -> Sched -> Trace -> IO ()
    sched Bool
    True Sched
    q Trace
    t
               Nothing -> [Sched] -> IO ()
    go [Sched]
    xs

    -- | If any worker is idle, wake one up and give it work to do.
    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 -- wake one up

    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] -- Global list of all per-thread workers.
        }
    --  deriving Show

    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

    -- | 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 :: (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))
    -- data IVar a = IVar (IORef (IVarContents a))

    -- | Equality for IVars is physical equality, as with other reference types.
    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
    _ = ()

    -- From outside the Par computation we can peek.  But this is nondeterministic.
    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 */
        --
        -- We create a thread on each CPU with forkOn.  The CPU on which
        -- the current thread is running will host the main thread; the
        -- other CPUs will host worker threads.
        --
        -- Note: GHC 7.1.20110301 is required for this to work, because that
        -- is when threadCapability was added.
        --
       (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
        --
        -- Lacking threadCapability, we always pick CPU #0 to run the main
        -- thread.  If the current thread is not running on CPU #0, this
        -- will require some data to be shipped over the memory bus, and
        -- hence will be slightly slower than the version above.
        --
       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"

    -- | Run a parallel, deterministic computation and return its result.
    --
    --   Note: you must NOT return an IVar in the output of the parallel
    --   computation.  This is unfortunately not enforced, as it is with
    --   `runST` or with newer libraries that export a Par monad, such as
    --   `lvish`.
    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

    -- | A version that avoids an internal `unsafePerformIO` for calling
    --   contexts that are already in the `IO` monad.
    --
    --   Returning any value containing IVar is still disallowed, as it
    --   can compromise type safety.
    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

    -- | An asynchronous version in which the main thread of control in a
    -- Par computation can return while forked computations still run in
    -- the background.
    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

    -- -----------------------------------------------------------------------------

    -- | Creates a new @IVar@
    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

    -- | Creates a new @IVar@ that contains a value
    newFull :: NFData a => a -> Par (IVar a)
    -- What are we doing here? We're manually raising the arity
    -- of newFull from 2 to 3, which seems like it's probably what
    -- we want most of the time. Notably, fmapping over the result
    -- gives really awful-looking Core if we don't do this.
    -- Regardless, I think we logically want to force the
    -- value when it's installed in the IVar rather than
    -- when we create the action to install it in the IVar.
    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

    -- | Creates a new @IVar@ that contains a value (head-strict only)
    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)

    -- | Read the value in an @IVar@.  The 'get' operation can only return when the
    -- value has been written by a prior or parallel @put@ to the same
    -- @IVar@.
    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

    -- | Like 'put', but only head-strict rather than fully-strict.
    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 a value into an @IVar@.  Multiple 'put's to the same @IVar@
    -- are not allowed, and result in a runtime error.
    --
    -- 'put' fully evaluates its argument, which therefore must be an
    -- instance of 'NFData'.  The idea is that this forces the work to
    -- happen when we expect it, rather than being passed to the consumer
    -- of the @IVar@ and performed later, which often results in less
    -- parallelism than expected.
    --
    -- Sometimes partial strictness is more appropriate: see 'put_'.
    --
    put :: NFData a => IVar a -> a -> Par ()
    -- Manually raise the arity, which seems likely to be what
    -- we want most of the time. We really want to force the
    -- value when it's installed in the IVar, not when we
    -- create the Par action to install it in the IVar.
    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 ())

    -- | Allows other parallel computations to progress.  (should not be
    -- necessary in most cases).
    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 ())