public
Created

Shake build system for the nofib benchmark suite.

  • Download Gist
Nofib.hs
Haskell
1 2 3 4 5 6 7 8 9 10 11 12 13 14 15 16 17 18 19 20 21 22 23 24 25 26 27 28 29 30 31 32 33 34 35 36 37 38 39 40 41 42 43 44 45 46 47 48 49 50 51 52 53 54 55 56 57 58 59 60 61 62 63 64 65 66 67 68 69 70 71 72 73 74 75 76 77 78 79 80 81 82 83 84 85 86 87 88 89 90 91 92 93 94 95 96 97 98 99 100 101 102 103 104 105 106 107 108 109 110 111 112 113 114 115 116 117 118 119 120 121 122 123 124 125 126 127 128 129 130 131 132 133 134 135 136 137 138 139 140 141 142 143 144 145 146 147 148 149 150 151 152 153 154 155 156 157 158 159 160 161 162 163 164 165 166 167 168 169 170 171 172 173 174 175 176 177 178 179 180 181 182 183 184 185 186 187 188 189 190 191 192 193 194 195 196 197 198 199 200 201 202 203 204 205 206 207 208 209 210 211 212 213 214 215 216 217 218 219 220 221 222 223 224 225 226 227 228 229 230 231 232 233 234 235 236 237 238 239 240 241 242 243 244 245 246 247 248 249 250 251 252 253 254 255 256 257 258 259 260 261 262 263 264 265 266 267 268 269 270 271 272 273 274 275 276 277 278 279 280 281 282 283 284 285 286 287 288 289 290 291 292 293 294 295 296 297 298 299 300 301 302 303 304 305 306 307 308 309 310 311 312 313 314 315 316 317 318 319 320 321 322 323 324 325 326 327 328 329 330 331 332 333 334 335 336 337 338 339 340 341 342 343 344 345 346 347 348 349 350 351 352 353 354 355 356 357 358
{-# 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)

Please sign in to comment on this gist.

Something went wrong with that request. Please try again.