    {-
    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