monad-parallel 0.5.2 → 0.7
raw patch · 4 files changed
+170/−88 lines, 4 files
Files
- Control/Monad/Parallel.hs +58/−3
- Test/TestParallel.hs +110/−0
- TestParallel.hs +0/−83
- monad-parallel.cabal +2/−2
Control/Monad/Parallel.hs view
@@ -62,12 +62,19 @@ import Prelude () import Control.Concurrent (forkIO) import Control.Concurrent.MVar (newEmptyMVar, putMVar, takeMVar)-import Control.Monad (Monad, (>>=), return)+import Control.Monad (Monad, (>>=), return, liftM)+import Control.Monad.Trans.Identity (IdentityT(IdentityT, runIdentityT))+import Control.Monad.Trans.Maybe (MaybeT(MaybeT, runMaybeT))+import Control.Monad.Trans.Error (ErrorT(ErrorT, runErrorT), Error)+import Control.Monad.Trans.List (ListT(ListT, runListT))+import Control.Monad.Trans.Reader (ReaderT(ReaderT, runReaderT)) import Control.Parallel (par, pseq)+import Data.Either (Either(..))+import Data.Function (($), (.), const) import Data.Functor.Identity (Identity) import Data.Int (Int)-import Data.List (foldr, map, replicate)-import Data.Maybe (Maybe)+import Data.List ((++), foldr, map, replicate)+import Data.Maybe (Maybe(Just, Nothing)) import System.IO (IO) -- | Class of monads that can perform two computations in parallel and bind their results together.@@ -130,6 +137,11 @@ instance MonadParallel Maybe instance MonadParallel [] +instance MonadParallel ((->) r) where+ bindM2 f ma mb r = let a = ma r+ b = mb r+ in a `par` (b `pseq` f a b r)+ -- | IO is parallelizable by `forkIO`. instance MonadParallel IO where bindM2 f ma mb = do vb <- newEmptyMVar@@ -138,11 +150,54 @@ b <- takeMVar vb f a b +instance MonadParallel m => MonadParallel (IdentityT m) where+ bindM2 f ma mb = IdentityT (bindM2 f' (runIdentityT ma) (runIdentityT mb))+ where f' a b = runIdentityT (f a b)++instance MonadParallel m => MonadParallel (MaybeT m) where+ bindM2 f ma mb = MaybeT (bindM2 f' (runMaybeT ma) (runMaybeT mb))+ where f' (Just a) (Just b) = runMaybeT (f a b)+ f' _ _ = return Nothing++instance (MonadParallel m, Error e) => MonadParallel (ErrorT e m) where+ bindM2 f ma mb = ErrorT (bindM2 f' (runErrorT ma) (runErrorT mb))+ where f' (Right a) (Right b) = runErrorT (f a b)+ f' (Left e) _ = return (Left e)+ f' _ (Left e) = return (Left e)++instance MonadParallel m => MonadParallel (ListT m) where+ bindM2 f ma mb = ListT (bindM2 f' (runListT ma) (runListT mb))+ where f' as bs = foldr concat (return []) [runListT (f a b) | a <- as, b <- bs]+ concat m m' = do {x <- m; y <- m'; return (x ++ y)}++instance MonadParallel m => MonadParallel (ReaderT r m) where+ bindM2 f ma mb = ReaderT (\r-> bindM2 (f' r) (runReaderT ma r) (runReaderT mb r))+ where f' r a b = runReaderT (f a b) r+ instance MonadFork Maybe instance MonadFork [] +instance MonadFork ((->) r) where+ forkExec e = \r-> let result = e r+ in result `par` (return result)+ -- | IO is forkable by `forkIO`. instance MonadFork IO where forkExec ma = do v <- newEmptyMVar _ <- forkIO (ma >>= putMVar v) return (takeMVar v)++instance MonadFork m => MonadFork (IdentityT m) where+ forkExec ma = IdentityT (liftM IdentityT $ forkExec (runIdentityT ma))++instance MonadFork m => MonadFork (MaybeT m) where+ forkExec ma = MaybeT (liftM (Just . MaybeT) $ forkExec (runMaybeT ma))++instance (MonadFork m, Error e) => MonadFork (ErrorT e m) where+ forkExec ma = ErrorT (liftM (Right . ErrorT) $ forkExec (runErrorT ma))++instance MonadFork m => MonadFork (ListT m) where+ forkExec ma = ListT (liftM ((:[]) . ListT) $ forkExec (runListT ma))++instance MonadFork m => MonadFork (ReaderT r m) where+ forkExec ma = ReaderT (\r-> liftM (ReaderT . const) $ forkExec (runReaderT ma r))
+ Test/TestParallel.hs view
@@ -0,0 +1,110 @@+{- + Copyright 2010 Mario Blazevic++ This file is part of the Streaming Component Combinators (SCC) project.++ The SCC project is free software: you can redistribute it and/or modify it under the terms of the GNU General Public+ License as published by the Free Software Foundation, either version 3 of the License, or (at your option) any later+ version.++ SCC is distributed in the hope that it will be useful, but WITHOUT ANY WARRANTY; without even the implied warranty+ of MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE. See the GNU General Public License for more details.++ You should have received a copy of the GNU General Public License along with SCC. If not, see+ <http://www.gnu.org/licenses/>.+-}++-- | The "Control.Monad.Parallel" tests.++module Main where++import Prelude hiding (mapM)+import Control.Monad (liftM)+import Control.Monad.Trans.Identity (IdentityT(..))+import Control.Monad.Trans.Maybe (MaybeT(..))+import Control.Monad.Trans.Error (ErrorT(..))+import Control.Monad.Trans.List (ListT(..))+import Control.Monad.Trans.Reader (ReaderT(..))+import Control.Parallel (pseq)+import Data.Functor.Identity (runIdentity)+import Data.Maybe (fromJust)+import System.Environment (getArgs)++import Control.Monad.Parallel++parFib :: MonadParallel m => Int -> Int -> m Integer+parFib _ 0 = return 1+parFib _ 1 = return 1+parFib 1 n = applyM fib n+parFib k n = bindM2 (\a b-> return (a + b)) (parFib (mod k 2) (n - 1)) (parFib (mod (k + 1) 2) (n - 2))++forkFib :: MonadFork m => Int -> Int -> m Integer+forkFib _ 0 = return 1+forkFib _ 1 = return 1+forkFib 1 n = applyM fib n+forkFib k n = do mf1 <- forkExec (forkFib (mod k 2) (n - 1))+ f2 <- forkFib (mod (k + 1) 2) (n - 2)+ f1 <- mf1+ return (f1 + f2)++parSeqFib :: MonadParallel m => Int -> Int -> m Integer+parSeqFib t n = liftM sum $ mapM (applyM fib) (split t n)+ where split 1 n = [n]+ split k n | k > 1 = let (max : rest) = split (k - 1) n+ in rest ++ [max - 1, max - 2]++applyM f n = let result = f n in result `pseq` return result++fib 0 = 1+fib 1 = 1+fib n = fib (n - 2) + fib (n - 1)++main = do args <- getArgs+ if length args /= 5+ then putStr help+ else do let [taskName, method, monad, size, threads] = args+ task :: MonadFork m => Int -> Int -> m Integer+ task = case (method, taskName) of ("par", "fib") -> parFib+ ("fork", "fib") -> forkFib+ ("[par]", "fib") -> parSeqFib+ _ -> error (help ++ "Bad method or task.")+ parOnlyTask :: MonadParallel m => Int -> Int -> m Integer+ parOnlyTask = case (method, taskName) of ("par", "fib") -> parFib+ ("[par]", "fib") -> parSeqFib+ _ -> error ("Monad " ++ monad ++ " can't do "+ ++ method)+ result <- case monad of "Identity" -> return $ runIdentity $ parOnlyTask (read threads) (read size)+ "IdentityT-[]" -> return $ head $ runIdentityT + $ task (read threads) (read size)+ "IdentityT-IO" -> runIdentityT $ task (read threads) (read size)+ "Maybe" -> return $ fromJust $ task (read threads) (read size)+ "MaybeT-[]" -> return $ fromJust $ head $ runMaybeT+ $ task (read threads) (read size)+ "MaybeT-IO" -> liftM fromJust $ runMaybeT + $ task (read threads) (read size)+ "ErrorT-[]" -> return $ (either error id) $ head $ runErrorT+ $ task (read threads) (read size)+ "ErrorT-IO" -> liftM (either error id) $ runErrorT + $ task (read threads) (read size)+ "->" -> return $ ($ 0) $ task (read threads) (read size)+ "[]" -> return $ head $ task (read threads) (read size)+ "ListT-Maybe" -> return $ head $ fromJust $ runListT + $ task (read threads) (read size)+ "ListT-IO" -> liftM head $ runListT + $ task (read threads) (read size)+ "ReaderT-[]" -> return $ head + $ runReaderT (task (read threads) (read size)) ()+ "ReaderT-IO" -> runReaderT (task (read threads) (read size)) ()+ "IO" -> task (read threads) (read size)+ _ -> error (help ++ "Bad monad.")+ print result++help = "Usage: test-parallel <task> <method> <monad> <threads> <size>\n"+ ++ " where <task> is 'fib',\n"+ ++ " <method> is 'par', 'fork', or '[par]'\n"+ ++ " <monad> is 'Identity', 'Maybe', '->', '[]', "+ ++ " 'IdentityT-IO', 'IdentityT-[]', 'MaybeT-IO', 'MaybeT-[]'," + ++ " 'ErrorT-IO', 'ErrorT-[]', 'ListT-IO', 'ListT-Maybe',"+ ++ " 'ReaderT-IO', 'ReaderT-[]', or 'IO',\n"+ ++ " <threads> is the number of threads to launch,\n"+ ++ " and <size> is the size of the task.\n"
− TestParallel.hs
@@ -1,83 +0,0 @@-{- - Copyright 2010 Mario Blazevic-- This file is part of the Streaming Component Combinators (SCC) project.-- The SCC project is free software: you can redistribute it and/or modify it under the terms of the GNU General Public- License as published by the Free Software Foundation, either version 3 of the License, or (at your option) any later- version.-- SCC is distributed in the hope that it will be useful, but WITHOUT ANY WARRANTY; without even the implied warranty- of MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE. See the GNU General Public License for more details.-- You should have received a copy of the GNU General Public License along with SCC. If not, see- <http://www.gnu.org/licenses/>.--}---- | The "Control.Monad.Parallel" tests.--module Main where--import Prelude hiding (mapM)-import Control.Monad (liftM)-import Control.Parallel (pseq)-import Data.Functor.Identity (runIdentity)-import Data.Maybe (fromJust)-import System.Environment (getArgs)--import Control.Monad.Parallel--parFib :: MonadParallel m => Int -> Int -> m Integer-parFib _ 0 = return 1-parFib _ 1 = return 1-parFib 1 n = applyM fib n-parFib k n = bindM2 (\a b-> return (a + b)) (parFib (mod k 2) (n - 1)) (parFib (mod (k + 1) 2) (n - 2))--forkFib :: MonadFork m => Int -> Int -> m Integer-forkFib _ 0 = return 1-forkFib _ 1 = return 1-forkFib 1 n = applyM fib n-forkFib k n = do mf1 <- forkExec (forkFib (mod k 2) (n - 1))- f2 <- forkFib (mod (k + 1) 2) (n - 2)- f1 <- mf1- return (f1 + f2)--parSeqFib :: MonadParallel m => Int -> Int -> m Integer-parSeqFib t n = liftM sum $ mapM (applyM fib) (split t n)- where split 1 n = [n]- split k n | k > 1 = let (max : rest) = split (k - 1) n- in rest ++ [max - 1, max - 2]--applyM f n = let result = f n in result `pseq` return result--fib 0 = 1-fib 1 = 1-fib n = fib (n - 2) + fib (n - 1)--main = do args <- getArgs- if length args /= 5- then putStr help- else do let [taskName, method, monad, size, threads] = args- task :: MonadFork m => Int -> Int -> m Integer- task = case (method, taskName) of ("par", "fib") -> parFib- ("fork", "fib") -> forkFib- ("[par]", "fib") -> parSeqFib- _ -> error (help ++ "Bad method or task.")- parOnlyTask :: MonadParallel m => Int -> Int -> m Integer- parOnlyTask = case (method, taskName) of ("par", "fib") -> parFib- ("[par]", "fib") -> parSeqFib- _ -> error ("Monad " ++ monad ++ " can't do "- ++ method)- result <- case monad of "Maybe" -> return $ fromJust $ task (read threads) (read size)- "[]" -> return $ head $ task (read threads) (read size)- "Identity" -> return $ runIdentity $ parOnlyTask (read threads) (read size)- "IO" -> task (read threads) (read size)- _ -> error (help ++ "Bad monad.")- print result--help = "Usage: test-parallel <task> <method> <monad> <threads> <size>\n"- ++ " where <task> is 'fib',\n"- ++ " <method> is 'par', 'fork', or '[par]'\n"- ++ " <monad> is 'Identity', 'Maybe', '[]', or 'IO',\n"- ++ " <threads> is the number of threads to launch,\n"- ++ " and <size> is the size of the task.\n"
monad-parallel.cabal view
@@ -1,5 +1,5 @@ Name: monad-parallel-Version: 0.5.2+Version: 0.7 Cabal-Version: >= 1.2 Build-Type: Simple Synopsis: Parallel execution of monadic computations@@ -16,7 +16,7 @@ Author: Mario Blazevic Maintainer: blamario@yahoo.com Homepage: http://trac.haskell.org/SCC/wiki/monad-parallel-Extra-source-files: TestParallel.hs+Extra-source-files: Test/TestParallel.hs -- Source-repository head -- type: darcs -- location: http://code.haskell.org/SCC/