diff --git a/Control/Parallel/Strategies.hs b/Control/Parallel/Strategies.hs index 631f1629a67f1554ac572b9d54a76beab0a90463..5ca739d2100f072717380cb6f377a47db7ca12ce 100644 --- a/Control/Parallel/Strategies.hs +++ b/Control/Parallel/Strategies.hs @@ -116,6 +116,7 @@ module Control.Parallel.Strategies ( -- * For Strategy programmers , Eval -- instances: Monad, Functor, Applicative + , parEval -- :: Eval a -> Eval a , runEval -- :: Eval a -> a , runEvalIO -- :: Eval a -> IO a , @@ -490,15 +491,31 @@ rpar x = case (par# x) of { _ -> Done x } -- that does precisely nothing. No real parallelism is added, but there -- is a bit of extra work to do nothing. rparWith :: Strategy a -> Strategy a +rparWith strat = parEval . strat + +-- | 'parEval' sparks the computation of its argument for evaluation in +-- parallel. Unlike @'rpar' . 'runEval'@, 'parEval' +-- +-- * does not exit the `Eval` monad +-- +-- * does not have a built-in `rseq`, so for example @'parEval' ('r0' x)@ +-- behaves as you might expect (it creates a spark that does no +-- evaluation). +-- +-- It is related to 'rparWith' by the following equality: +-- +-- > parEval . strat = rparWith strat +-- +parEval :: Eval a -> Eval a -- The intermediate `Lift` box is necessary, in order to avoid a built-in --- `rseq` in `rparWith`. In particular, we want rparWith r0 = r0, not --- rparWith r0 = rpar. -rparWith s a = do +-- `rseq` in `parEval`. In particular, we want @parEval . r0 = r0@, not +-- @parEval . r0 = rpar@. +parEval m = do l <- rpar r return (case l of Lift x -> x) where - r = runEval (Lift <$> s a) + r = runEval (Lift <$> m) data Lift a = Lift a diff --git a/tests/all.T b/tests/all.T index 7058076912fb8628395089f4f71f165eae05f50a..bf46e6332a4495d38dbbb52eab2af081e6b11c77 100644 --- a/tests/all.T +++ b/tests/all.T @@ -15,3 +15,6 @@ test('T2185', [when(fast(), skip), reqlib('parallel'), test('rparWith_r0', only_ways(['threaded1', 'threaded2']), compile_and_run, ['-package parallel']) + +test('pareval', only_ways(['threaded1', 'threaded2']), + compile_and_run, ['-package parallel']) diff --git a/tests/pareval.hs b/tests/pareval.hs new file mode 100644 index 0000000000000000000000000000000000000000..4db6f6b553ddddcaef8c4a1a1e312adeabc043e9 --- /dev/null +++ b/tests/pareval.hs @@ -0,0 +1,25 @@ +module Main (main) where + +import Control.Concurrent (threadDelay) +import System.IO.Unsafe (unsafePerformIO) + +import Control.Parallel.Strategies + +printOnEvaluation :: String -> Eval () +printOnEvaluation = return . unsafePerformIO . putStrLn + +main :: IO Int +main = do + nils <- runEvalIO $ do + plast <- parEval $ printOnEvaluation "Printed last" + _ <- parEval $ printOnEvaluation "Must not be printed" + p1 <- parEval . rseq =<< printOnEvaluation "Printed 1st" + return [plast, p1] + + -- wait for sparks + threadDelay $ 10 ^ (5::Int) + + _ <- runEvalIO $ evalList rseq nils + + return 0 + diff --git a/tests/pareval.stdout b/tests/pareval.stdout new file mode 100644 index 0000000000000000000000000000000000000000..8c2d1f5e4ab3c72188d9f0f456eb5dda1176abc3 --- /dev/null +++ b/tests/pareval.stdout @@ -0,0 +1,2 @@ +Printed 1st +Printed last