Run build steps in parallel

We can now run the build steps in parallel to speed the
overall collection of results. To support parallel builds we
now depend on the parallel-io package that provides a
thread pool for executing IO actions. To control the number
of threads used, you must pass the rts flags such as:

  $ fibon-run +RTS -N2 -RTS

This commit also introduces a dependency on the unix
package. We had to use this to install our own signal
handler to get CTRL-C to be correctly handled so that it
immediatly shuts down the program. Without the custom signal
handler it only kills one thread and so it is very difficult
to have an early termination of the program.

fibon.cabal

@@ -89,7 +89,7 @@ Flag nofib
 
 Executable fibon-run
   main-is:          Fibon/Run/Main.hs
-  ghc-options: -Wall -threaded
+  ghc-options: -Wall -threaded -rtsopts
   include-dirs: config
   hs-source-dirs: tools/fibon-run
                   lib
@@ -110,6 +110,8 @@ Executable fibon-run
                 , bytestring  == 0.9.*
                 , cereal      == 0.3.*
                 , syb         >= 0.1 && < 0.4
+                , parallel-io >= 0.3 && < 0.4
+                , unix
 
 Executable fibon-init
   main-is:        Main.hs

tools/fibon-run/Fibon/Run/Actions.hs

@@ -81,7 +81,6 @@ runAction Sanity = do
   sanityCheck
   return SanityComplete
 runAction Build = do
-  prepConfigure
   runConfigure
   r <- runBuild
   return $ BuildComplete r
@@ -127,13 +126,6 @@ checkForExpectedOutFiles = do
   diffFiles =
     catMaybes . map (\o -> case o of (_, Diff f) -> Just f ; _ -> Nothing)
 
-prepConfigure :: FibonRunMonad ()
-prepConfigure = do
-  bb <- ask
-  let ud = (workDir bb) </> (unique bb)
-  udExists <- io $ doesDirectoryExist ud
-  unless udExists (io $ createDirectory ud)
-
 runConfigure :: FibonRunMonad ()
 runConfigure = do
   _ <- runCabalCommand "configure" configureFlags

tools/fibon-run/Fibon/Run/Main.hs

@@ -4,6 +4,7 @@ module Main (
 where 
 import Control.Monad
 import Control.Exception
+import qualified Control.Concurrent.ParallelIO as P
 import qualified Data.ByteString as B
 import Data.Char
 import Data.List
@@ -24,13 +25,15 @@ import System.Directory
 import System.Exit
 import System.Environment
 import System.Locale(defaultTimeLocale)
+import System.Posix(installHandler, Handler(Default), sigINT)
 import System.FilePath
 import Text.Printf
 
 
 main :: IO ()
 main = do
   opts <- parseArgsOrDie
+  installSignalHandlers
   currentDir <- getCurrentDirectory
   initConfig  <- selectConfig (optConfig opts)
   let runConfig  = mergeConfigOpts initConfig opts
@@ -83,16 +86,20 @@ runOnlyStep Run    bundles = runRunSteps (zip (repeat noBuildData) bundles)
  -- Run a specific step over a list of bundles and filter out failing results
  ------------------------------------------------------------------------------}
 runSanitySteps :: [BenchmarkBundle] -> IO [BenchmarkBundle]
-runSanitySteps = runSteps runSanityStep
+runSanitySteps = runParSteps runSanityStep
 
 runBuildSteps :: [BenchmarkBundle] -> IO [(BuildData, BenchmarkBundle)]
-runBuildSteps = runSteps runBuildStep
+runBuildSteps = runParSteps runBuildStep
 
 runRunSteps :: [(BuildData, BenchmarkBundle)] -> IO [FibonResult]
-runRunSteps = runSteps runRunStep
+runRunSteps = runSeqSteps runRunStep
 
-runSteps :: (a -> IO (Maybe b)) -> [a] -> IO [b]
-runSteps act bs = catMaybes `liftM` mapM act bs
+runParSteps, runSeqSteps :: (a -> IO (Maybe b)) -> [a] -> IO [b]
+runParSteps  = runSteps P.parallel
+runSeqSteps  = runSteps sequence
+
+runSteps :: ([IO (Maybe b)] -> IO [Maybe b]) -> (a -> IO (Maybe b)) -> [a] -> IO [b]
+runSteps runner act bs = catMaybes `liftM` runner (map act bs)
 
 {------------------------------------------------------------------------------
  -- Run a specific step over a single bundle
@@ -182,8 +189,7 @@ expandBenchList = concatMap expand
 chooseUniqueNames :: FilePath -> ConfigId -> ReuseDir -> IO (String, String)
 chooseUniqueNames workingDir configName mbReuseId = do
   checkReuseDir workingDir mbReuseId
-  wdExists <- doesDirectoryExist workingDir
-  unless wdExists (createDirectory workingDir)
+  createUnlessExists workingDir
   dirs  <- getDirectoryContents workingDir
   time  <- getZonedTime
   let numbered = filter (\x -> length x > 0) $ map (takeWhile isDigit) dirs
@@ -194,10 +200,14 @@ chooseUniqueNames workingDir configName mbReuseId = do
           _  -> (format . (+1) . read . last . sort) numbered
       logUniq = maybe nextAvailableUniq (++"."++timestamp) mbReuseId
       runUniq = maybe nextAvailableUniq (id) mbReuseId
+  mapM_ createUnlessExists (map (workingDir </>) [logUniq, runUniq])
   return (logUniq, runUniq)
   where
   format :: Int -> String
   format d = printf "%03d.%s" d configName
+  createUnlessExists dir = do
+    exists <- doesDirectoryExist dir
+    unless exists (createDirectory dir)
 
 -- Make sure that the directory where we are trying to reuse the build results
 -- actually exists
@@ -262,3 +272,13 @@ parseArgsOrDie = do
       case optHelpMsg opts of
         Just msg -> putStrLn msg >> exitSuccess
         Nothing  -> return opts
+
+{------------------------------------------------------------------------------
+ -- Signal handling
+ --
+ -- We need to install a Ctrl-C signal handler to promptly shutdown the
+ -- program. Without this handler the parallel rts will swallow our signals when
+ -- used with the ParallelIO.parallel thread pool.
+ ------------------------------------------------------------------------------}
+installSignalHandlers :: IO ()
+installSignalHandlers = installHandler sigINT Default Nothing >> return ()