{-
The parallel function (specialised to lists) is equivalent to:

import Control.Parallel.Strategies
parallel :: [IO [a]] -> IO [[a]]
parallel = pure . withStrategy (parList $ seqList r0) . map unsafePerformIO

However, this version performs about 10% slower with 2 processors in GHC 6.12.1
-}

module Parallel(parallel) where

import System.IO.Unsafe
import Control.Concurrent
import Control.Exception
import Control.Monad


parallel :: Int -> [IO a] -> IO [a]
parallel :: forall a. Int -> [IO a] -> IO [a]
parallel Int
j = if Int
j Int -> Int -> Bool
forall a. Ord a => a -> a -> Bool
<= Int
1 then [IO a] -> IO [a]
forall a. [IO a] -> IO [a]
parallel1 else Int -> [IO a] -> IO [a]
forall a. Int -> [IO a] -> IO [a]
parallelN Int
j


parallel1 :: [IO a] -> IO [a]
parallel1 :: forall a. [IO a] -> IO [a]
parallel1 [] = [a] -> IO [a]
forall a. a -> IO a
forall (f :: * -> *) a. Applicative f => a -> f a
pure []
parallel1 (IO a
x:[IO a]
xs) = do
    x2 <- IO a
x
    xs2 <- unsafeInterleaveIO $ parallel1 xs
    pure $ x2:xs2


parallelN :: Int -> [IO a] -> IO [a]
parallelN :: forall a. Int -> [IO a] -> IO [a]
parallelN Int
j [IO a]
xs = do
    ms <- (IO a -> IO (MVar (Either SomeException a)))
-> [IO a] -> IO [MVar (Either SomeException a)]
forall (t :: * -> *) (m :: * -> *) a b.
(Traversable t, Monad m) =>
(a -> m b) -> t a -> m (t b)
forall (m :: * -> *) a b. Monad m => (a -> m b) -> [a] -> m [b]
mapM (IO (MVar (Either SomeException a))
-> IO a -> IO (MVar (Either SomeException a))
forall a b. a -> b -> a
const IO (MVar (Either SomeException a))
forall a. IO (MVar a)
newEmptyMVar) [IO a]
xs
    chan <- newChan
    mapM_ (writeChan chan . Just) $ zip ms xs
    replicateM_ j (writeChan chan Nothing >> forkIO (f chan))
    let throwE SomeException
x = SomeException -> a
forall a e. (HasCallStack, Exception e) => e -> a
throw (SomeException
x :: SomeException)
    parallel1 $ map (fmap (either throwE id) . takeMVar) ms
    where
        f :: Chan (Maybe (MVar (Either e a), IO a)) -> IO ()
f Chan (Maybe (MVar (Either e a), IO a))
chan = do
            v <- Chan (Maybe (MVar (Either e a), IO a))
-> IO (Maybe (MVar (Either e a), IO a))
forall a. Chan a -> IO a
readChan Chan (Maybe (MVar (Either e a), IO a))
chan
            case v of
                Maybe (MVar (Either e a), IO a)
Nothing -> () -> IO ()
forall a. a -> IO a
forall (f :: * -> *) a. Applicative f => a -> f a
pure ()
                Just (MVar (Either e a)
m,IO a
x) -> do
                    MVar (Either e a) -> Either e a -> IO ()
forall a. MVar a -> a -> IO ()
putMVar MVar (Either e a)
m (Either e a -> IO ()) -> IO (Either e a) -> IO ()
forall (m :: * -> *) a b. Monad m => (a -> m b) -> m a -> m b
=<< IO a -> IO (Either e a)
forall e a. Exception e => IO a -> IO (Either e a)
try IO a
x
                    Chan (Maybe (MVar (Either e a), IO a)) -> IO ()
f Chan (Maybe (MVar (Either e a), IO a))
chan