set-cover-0.0.1: example/Parallelism.hs

module Parallelism where

import qualified Control.Concurrent.MVar as MVar
import Control.Concurrent (forkIO, getNumCapabilities)
import Control.Exception (finally)

import Control.Functor.HT (void)
import Data.Foldable (forM_)


schedule :: [IO ()] -> IO ()
schedule acts = do
   n <- getNumCapabilities
   let (start, queue) = splitAt n acts
   mvar <- MVar.newEmptyMVar
   let newJob act = void $ forkIO $ finally act $ MVar.putMVar mvar ()
   mapM_ newJob start
   let loop [] = return ()
       loop (act:remain) = do
          MVar.takeMVar mvar
          newJob act
          loop remain
   loop queue
   forM_ start $ const $ MVar.takeMVar mvar

parallel :: [IO ()] -> IO ()
parallel acts =
   mapM_ MVar.takeMVar =<< mapM fork acts

fork :: IO () -> IO (MVar.MVar ())
fork act = do
   mvar <- MVar.newEmptyMVar
   void $ forkIO $ finally act $ MVar.putMVar mvar ()
   return mvar