From 9a05384228660e62cf98e47747802101efef9872 Mon Sep 17 00:00:00 2001
From: David Feuer <David.Feuer@gmail.com>
Date: Sun, 17 Jun 2018 00:21:42 -0400
Subject: [PATCH] Embed ST actions in Eval
---
Control/Parallel/Strategies.hs | 27 +++++++++++++++++++++++++++
1 file changed, 27 insertions(+)
diff --git a/Control/Parallel/Strategies.hs b/Control/Parallel/Strategies.hs
index 63f1394a..02924835 100644
--- a/Control/Parallel/Strategies.hs
+++ b/Control/Parallel/Strategies.hs
@@ -1,5 +1,6 @@
{-# LANGUAGE BangPatterns, CPP, MagicHash, UnboxedTuples #-}
{-# LANGUAGE GeneralizedNewtypeDeriving #-}
+{-# LANGUAGE RankNTypes #-}
-----------------------------------------------------------------------------
-- |
-- Module : Control.Parallel.Strategies
@@ -118,6 +119,7 @@ module Control.Parallel.Strategies (
, Eval -- instances: Monad, Functor, Applicative
, runEval -- :: Eval a -> a
, runEvalIO -- :: Eval a -> IO a
+ , stToEval -- :: (forall s. ST s a) -> Eval a
,
-- * API History
@@ -150,6 +152,12 @@ import Control.Applicative
import Control.Parallel
import Control.DeepSeq (NFData(rnf))
+#if __GLASGOW_HASKELL__ >= 702
+import Control.Monad.ST.Strict (ST, stToIO)
+#else
+import Control.Monad.ST.Strict (ST, runST)
+#endif
+
#if MIN_VERSION_base(4,4,0)
import System.IO.Unsafe (unsafeDupablePerformIO)
import Control.Exception (evaluate)
@@ -224,6 +232,16 @@ runEval = unsafePerformIO . unEval_
runEvalIO :: Eval a -> IO a
runEvalIO = unEval_
+-- | Run an 'ST' computation in the 'Eval' monad.
+--
+-- > stToEval m = runST (pure <$> m)
+stToEval :: (forall s. ST s a) -> Eval a
+-- Do not be tempted to allow non-closed ST computations (i.e., to
+-- drop the forall). ST computations using the same mutable
+-- references and arrays could end up running in parallel, stepping
+-- on each other's toes.
+stToEval m = Eval (stToIO m)
+
#else
data Eval a = Done a
@@ -237,6 +255,15 @@ runEval (Done x) = x
runEvalIO :: Eval a -> IO a
runEvalIO (Done x) = return x
+-- | Run an 'ST' computation in the 'Eval' monad.
+--
+-- > stToEval m = runST (pure <$> m)
+stToEval :: (forall s. ST s a) -> Eval a
+-- It must be runST (Eval <$> m) and not Eval (runST m). The
+-- latter will delay the ST computation until its result is
+-- forced to WHNF. We want to run it immediately.
+stToEval m = runST (pure <$> m)
+
instance Functor Eval where
fmap = liftM