Skip to content

Embed URL

HTTPS clone URL

Subversion checkout URL

You can clone with
or
.
Download ZIP
Shake build system for the nofib benchmark suite.
{-# LANGUAGE RecordWildCards, DeriveDataTypeable #-}
module Main(main) where
-- Standard libraries
import Control.Concurrent
import Control.Exception
import Control.Monad
import Data.Char
import Data.List
import Data.Maybe
import Data.Time.Clock
import qualified System.Directory as IO
import System.Exit
import System.Info
import System.IO
import System.Process
-- CmdArgs - argument parsing
import System.Console.CmdArgs
-- Shake - build system
import Development.Shake
import Development.Shake.FilePath
---------------------------------------------------------------------
-- TEST CONFIGURATION - which tests are available to run
-- | These are directories that contain tests.
testRoots :: [String]
testRoots = words "imaginary spectral real parallel spectral/hartel"
-- | These are tests that are under testRoots, but should be skipped (all are skipped by the Makefile system)
disabledTests :: [String]
disabledTests = words "hartel last-piece secretary triangle ebnf2ps HMMS PolyGP rx cfd dcbm linsolv warshall"
-- | These tests are compiled by the Makefile system, but don't work for me (mostly GHC 7.4 breaks)
newlyDisabledTests :: [String]
newlyDisabledTests = words "power lift fulsom fluid"
-- | Directories containing tests that the system can run.
allTests :: IO [FilePath]
allTests = do
xs <- forM testRoots $ \x -> do
ys <- IO.getDirectoryContents x
return [x </> y | y <- ys, '.' `notElem` y, y `notElem` disabledTests, y `notElem` newlyDisabledTests]
fmap sort $ flip filterM (concat xs) $ \x -> do
b <- IO.doesDirectoryExist x
if not b then return False else
IO.doesFileExist $ x </> "Makefile"
---------------------------------------------------------------------
-- ARGUMENT PARSING - mostly based on CmdArgs
data Nofib
= Clean
| Build
{clean :: Bool
,tests :: [String]
,way :: [String]
,threads :: Int
,compiler :: String
,tag :: String
,output :: String
,run :: Maybe Speed
,rts :: [String]
,times :: Int
,skip_check :: Bool
}
deriving (Data,Typeable,Show)
data Speed = Fast | Norm | Slow
deriving (Data,Typeable,Show)
nofibMode :: Mode (CmdArgs Nofib)
nofibMode = cmdArgsMode $ modes
[Clean
&= help "Clean the build"
,Build
{clean = False &= groupname "Building" &= help "Clean before building"
,tests = [] &= args &= typ "TEST"
,way = [] &= help "Which way to build, defaults to -O1"
,threads = 1 &= name "j" &= typ "NUM" &= help "Number of threads, defaults to 1"
,compiler = "ghc" &= help "Compiler to use, defaults to ghc"
,tag = "" &= help "Tag to name the compiler, defaults to compiler --version"
,output = "" &= help "Where to put created files under _make, defaults to tag/way"
,run = Nothing &= groupname "Running" &= opt "norm" &= help "Run the results (Fast,Norm,Slow)"
,times = 1 &= help "Number of times to run each test"
,rts = [] &= help "Which RTS options to pass when running"
,skip_check = False &= help "Skip checking the results of the tests"
} &= auto &= help "Build"
&= help "Build and run"
]
&= summary "Nofib benchmark suite"
-- | Create a clean set of arguments, with any defaults filled in
nofibArgs :: IO Nofib
nofibArgs = do
args <- cmdArgsRun nofibMode
case args of
Clean -> return args
Build{..} -> do
way <- return $ let xs = concatMap words way in if null xs then ["-O1"] else xs
tag <- if tag == "" then compilerTag compiler else return tag
tests <- resolveTests tests
output <- return $ "_make" </> (if null output then tag </> intercalate "_" way else output)
return Build{..}
-- | Given the tests the user asked for, expand them out, e.g. real is the full real suite.
resolveTests :: [String] -> IO [String]
resolveTests [] = allTests
resolveTests finds = do
let slash1 x = "/" ++ map (\i -> if i == '\\' then '/' else i) x
slash2 x = slash1 x ++ "/"
tests <- allTests
let whole = filter (\test -> any (\find -> slash2 find `isInfixOf` slash2 test) finds) tests -- whole matches
let prefix = filter (\test -> any (\find -> slash1 find `isInfixOf` slash2 test) finds) tests -- prefix matches
let res = if null whole then prefix else whole
when (null res) $
error $ "The targets failed to match any programs: " ++ unwords finds
return res
-- | Find the default compiler string, e.g. ghc-7.4.1
compilerTag :: String -> IO String
compilerTag compiler = do
(_,stdout,_) <- readProcessWithExitCode compiler ["--version"] ""
let ver = takeWhile (\x -> isDigit x || x == '.') $ dropWhile (not . isDigit) stdout
return $ if null ver then "unknown" else ver
---------------------------------------------------------------------
-- MAIN DRIVER
-- | Main program, just interpret the arguments and dispatch the tasks.
main = do
args <- nofibArgs
case args of
Clean -> removeDirectoryRecursive "_make"
Build{..} -> do
when clean $
removeDirectoryRecursive output
linker <- newResource "ghc linker" 1
shake shakeOptions
{shakeThreads=threads
,shakeFiles=output ++ "/"
,shakeReport=Just $ output ++ "/shake_report.html"
,shakeVerbosity=Development.Shake.Loud} $
buildRules linker args
putStrLn "Build completed"
when (isJust run) $ do
ns <- mapM (runTest args) tests
let tot = length ns
bad = length $ filter not ns
t i = if i == 1 then "1 test" else show i ++ " tests"
if bad == 0 then
putStrLn $ "Ran " ++ t tot ++ " successfully"
else
putStrLn $ "WARNING: " ++ t bad ++ " failed, out of " ++ t tot
-- | Rules to build the given tests. For each test, there are three files
-- we care about:
--
-- * config.txt - a cleaned up version of the configuration out of Makefile,
-- created by convertConfig. Also contains "MAIN" which points at the name
-- of the Main module.
--
-- * Main.exe - the actual binary, produced by ghc linking everything.
--
-- * Main.deps - the files that Main.exe depends on, ghc -M.
--
-- * .hi/.o - files produced by ghc -c.
--
-- Most complication comes from modules not named Main, which still produce
-- Main.o object files (I think ghc -M gets these wrong).
buildRules :: Resource -> Nofib -> Rules ()
buildRules r Build{..} = do
let unoutput x =
let f x = if hasExtension x then f $ takeDirectory x else x
in f $ takeDirectory $ drop (length output + 1) x
want $ concat
[ [s </> "Main" <.> exe, s </> "config.txt"] | t <- tests, let s = output </> t]
"//config.txt" *> \out -> do
let dir = unoutput out
src <- readFileLines $ dir </> "Makefile"
let poss = ["Main.hs","Main.lhs",takeFileName dir <.> "hs",takeFileName dir <.> "lhs"]
bs <- filterM (doesFileExist . (dir </>)) poss
let mainMod = case bs of
[] -> error $ "Could not find Main file for " ++ dir
x:_ -> "MAIN = " ++ x
writeFileLines out $ mainMod : convertConfig src
("//Main" <.> exe) *> \out -> do
deps <- readFile' $ replaceExtension out "deps"
let os = nub [ if isLower $ head $ takeFileName x then replaceExtension out "o" else output </> x
| x <- words deps, takeExtension x == ".o"]
need os
config <- readConfig' $ takeDirectory out </> "config.txt"
let dir = unoutput out
obj = takeDirectory out
name = takeFileName dir
putNormal $ "==nofib== " ++ name ++ " : time to link " ++ name ++ " follows..."
withResource r 1 $
system' compiler $ ["-Rghc-timing","-rtsopts","-o"++out] ++ os ++ way ++ words (config "SRC_HC_OPTS")
putNormal $ "==nofib== " ++ name ++ ": size of " ++ name ++ " follows..."
system' "size" [out]
["//*.o","//*.hi"] *>> \[o,hi] -> do
let dir = unoutput o
obj = output </> dir
config <- readConfig' $ obj </> "config.txt"
let mod = let x = dropExtension $ drop (length obj + 1) o
in if x == "Main" then dropExtension $ config "MAIN" else x
src <- do b <- doesFileExist $ dir </> mod <.> "hs"
return $ dir </> mod <.> (if b then "hs" else "lhs")
deps <- readFileLines $ obj </> "Main.deps"
need [ if takeExtension r `elem` [".h",".hs",".lhs"] then r else output </> r
| lhs:":":rhs <- map words $ deps, dir </> mod <.> "o" == lhs, r <- rhs]
let name = takeFileName dir
putNormal $ "==nofib== " ++ name ++ " : time to compile " ++ mod ++ " follows..."
system' compiler $ ["-Rghc-timing","-c",src,"-w","-i"++obj,"-odir="++obj,"-hidir="++obj] ++
way ++ words (config "SRC_HC_OPTS")
putNormal $ "==nofib== " ++ name ++ ": size of " ++ takeFileName o ++ " follows..."
system' "size" [o]
"//Main.deps" *> \out -> do
let dir = unoutput out
config <- readConfig' $ takeDirectory out </> "config.txt"
system' compiler $ ["-w","-M",dir </> config "MAIN","-i" ++ dir,"-dep-makefile=" ++ out] ++
words (config "SRC_HC_OPTS")
src <- liftIO $ readFile out
need [x | x <- words src, takeExtension x `elem` [".hs",".lhs",".h"]]
-- | Run a test, checking stdout/stderr are as expected, and reporting time.
-- Return True if the test passes.
runTest :: Nofib -> String -> IO Bool
runTest Build{run=Just speed,..} test = do
putStrLn $ "==nofib== " ++ takeDirectory1 test ++ ": time to run " ++ takeDirectory1 test ++ " follows..."
config <- readConfig $ output </> test </> "config.txt"
let args = words (config "PROG_ARGS") ++ words (config $ map toUpper (show speed) ++ "_OPTS")
stdin <- let s = config "STDIN_FILE" in if s == "" then grab "stdin" else readFile $ test </> s
stats <- IO.canonicalizePath $ output </> test </> "stat.txt"
fmap and $ replicateM times $ do
start <- getCurrentTime
(code,stdout,stderr) <- readProcessWithExitCodeAndWorkingDirectory
test (output </> test </> "Main" <.> exe) (args++"+RTS":rts++["-t"++stats]) stdin
end <- getCurrentTime
stdoutWant <- grab "stdout"
stderrWant <- grab "stderr"
writeFile (output </> test </> "stdout") stdout
writeFile (output </> test </> "stderr") stderr
putStrLn $ show (floor $ fromRational (toRational $ end `diffUTCTime` start) * 1000) ++ "ms"
putStr =<< readFile stats
err <- return $
if not skip_check && stderr /= stderrWant then "FAILED STDERR\nWANTED: " ++ snip stderrWant ++ "\nGOT: " ++ snip stderr
else if not skip_check && stdout /= stdoutWant then "FAILED STDOUT\nWANTED: " ++ snip stdoutWant ++ "\nGOT: " ++ snip stdout
else if not skip_check && code /= ExitSuccess then "FAILED EXIT CODE " ++ show code
else ""
if null err then return True else putStrLn err >> return False
where
snip x = if length x > 200 then take 200 x ++ "..." else x
grab ext = do
let s = [test </> takeFileName test <.> map toLower (show speed) ++ ext
,test </> takeFileName test <.> ext]
ss <- filterM IO.doesFileExist s
maybe (return "") readFile $ listToMaybe ss
---------------------------------------------------------------------
-- CONFIGURATION UTILITIES
-- The Makefile's are slurped for configuration, to produce a cleaned-up config file
-- | Given the source of a Makefile, slurp out the configuration strings.
convertConfig :: [String] -> [String]
convertConfig xs = [remap a ++ " = " ++ b | x <- xs, let (a,b) = separate x, a `elem` keep]
where
keep = words "PROG_ARGS SRC_HC_OPTS SRC_RUNTEST_OPTS SLOW_OPTS NORM_OPTS FAST_OPTS STDIN_FILE"
remap "SRC_RUNTEST_OPTS" = "PROG_ARGS"
remap x = x
separate x = (name,rest)
where (name,x2) = span (\x -> isAlpha x || x == '_') x
rest = dropWhile isSpace $ dropWhile (`elem` "+=") $ dropWhile isSpace x2
-- | Read a configuration file (new format) into a function supplying options.
readConfig :: FilePath -> IO (String -> String)
readConfig x = do
src <- readFile x
let res = [ (reverse $ dropWhile isSpace $ reverse a, dropWhile isSpace $ drop 1 b)
| y <- lines src, let (a,b) = break (== '=') y]
return $ \x -> fromMaybe "" $ lookup x res
-- | readConfig lifted into the Action monad.
readConfig' :: FilePath -> Action (String -> String)
readConfig' x = do
need [x]
liftIO $ readConfig x
---------------------------------------------------------------------
-- GENERAL UTILITIES
-- | The executable extension on this platform.
exe :: String
exe = if os == "mingw32" then "exe" else ""
-- | Like the standard removeDirectoryRecursive, but doesn't fail if the path is missing.
removeDirectoryRecursive :: FilePath -> IO ()
removeDirectoryRecursive x = do
b <- IO.doesDirectoryExist x
when b $ IO.removeDirectoryRecursive x
-- | Source for readProcessWithExitCode, plus addition of cwd
readProcessWithExitCodeAndWorkingDirectory
:: FilePath -- ^ directory to use
-> FilePath -- ^ command to run
-> [String] -- ^ any arguments
-> String -- ^ standard input
-> IO (ExitCode,String,String) -- ^ exitcode, stdout, stderr
readProcessWithExitCodeAndWorkingDirectory cwd cmd args input = do
(Just inh, Just outh, Just errh, pid) <-
createProcess (proc cmd args){ cwd = Just cwd,
std_in = CreatePipe,
std_out = CreatePipe,
std_err = CreatePipe }
outMVar <- newEmptyMVar
out <- hGetContents outh
_ <- forkIO $ evaluate (length out) >> putMVar outMVar ()
err <- hGetContents errh
_ <- forkIO $ evaluate (length err) >> putMVar outMVar ()
when (not (null input)) $ do hPutStr inh input; hFlush inh
hClose inh
takeMVar outMVar
takeMVar outMVar
hClose outh
hClose errh
ex <- waitForProcess pid
return (ex, out, err)
Sign up for free to join this conversation on GitHub. Already have an account? Sign in to comment
Something went wrong with that request. Please try again.