Main.hs 17 KB
Newer Older
Ben Gamari's avatar
Ben Gamari committed
1 2 3 4 5 6 7 8 9 10 11 12 13
{-# 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
Ben Gamari's avatar
Ben Gamari committed
14
import qualified Data.ByteString.Char8 as BS
Ben Gamari's avatar
Ben Gamari committed
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
import System.Exit
import System.Info
import System.IO
import System.Process
import System.Console.CmdArgs

-- Shake - build system
import Development.Shake hiding ((*>))
import Development.Shake.FilePath hiding (exe)


---------------------------------------------------------------------
-- 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]
Ben Gamari's avatar
SHake  
Ben Gamari committed
41
newlyDisabledTests = words "power lift fulsom fluid eff"
Ben Gamari's avatar
Ben Gamari committed
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


-- | 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, Show)

data Speed = Fast | Norm | Slow
    deriving (Data, 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

            shake shakeOptions
                {shakeThreads=threads
                ,shakeFiles=output ++ "/"
                ,shakeReport=[output ++ "/shake_report.html"]
                ,shakeVerbosity=Development.Shake.Loud} $
                    buildRules 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.
--
Ben Gamari's avatar
Ben Gamari committed
183 184
-- * .result - the stdout and stderr output from the build
--
Ben Gamari's avatar
Ben Gamari committed
185 186 187
--   Most complication comes from modules not named Main, which still produce
--   Main.o object files (I think ghc -M gets these wrong).
buildRules :: Nofib -> Rules ()
Ben Gamari's avatar
Ben Gamari committed
188
buildRules nofib@Build{..} = do
Ben Gamari's avatar
Ben Gamari committed
189 190 191 192 193 194
    r <- newResource "ghc linker" 1
    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]
Ben Gamari's avatar
Ben Gamari committed
195
    want $ [ "cachegrind" ]
Ben Gamari's avatar
Ben Gamari committed
196

Ben Gamari's avatar
Ben Gamari committed
197 198 199 200 201 202 203 204 205
    "//all-results" %> \out -> do
        let results = [ s </> "Main" <.> exe <.> "result"
                      | t <- tests
                      , let s = output </> t
                      ]
        need results
        xs <- mapM readFileLines results
        writeFileLines out (concat xs)

Ben Gamari's avatar
Ben Gamari committed
206 207 208 209 210 211 212 213 214
    "//cachegrind" %> \out -> do
        let results = [ s </> "Main" <.> "cachegrind" <.> "result"
                      | t <- tests
                      , let s = output </> t
                      ]
        need results
        xs <- mapM readFileLines results
        writeFileLines out (concat xs)

Ben Gamari's avatar
Ben Gamari committed
215 216 217
    "//config.txt" %> \out -> do
        let dir = unoutput out
        src <- readFileLines $ dir </> "Makefile"
Ben Gamari's avatar
SHake  
Ben Gamari committed
218
        let poss = ["Main.hs","Main.lhs","Era.hs","SumEuler.hs",takeFileName dir <.> "hs",takeFileName dir <.> "lhs"]
Ben Gamari's avatar
Ben Gamari committed
219 220 221 222 223 224
        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

Ben Gamari's avatar
Ben Gamari committed
225
    ["//Main" <.> exe, "//Main" <.> exe <.> "result"] &%> \[out, result] -> do
Ben Gamari's avatar
Ben Gamari committed
226 227 228 229 230 231 232 233
        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
Ben Gamari's avatar
Ben Gamari committed
234 235 236 237 238 239 240 241 242 243 244 245 246 247 248 249 250 251 252 253
        resultHdl <- liftIO $ openFile result WriteMode

        -- Add results from object compilation to results output
        forM os $ \o -> do
            ls <- liftIO $ BS.readFile (o <.> "result")
            liftIO $ BS.hPutStr resultHdl ls

        -- Link executable
        liftIO $ hPutStrLn resultHdl $ "==nofib== " ++ name ++ " : time to link " ++ name ++ " follows..."
        Stdouterr out_err <- withResource r 1 $
            cmd compiler $ ["-Rghc-timing","-rtsopts","-o", out] ++ os ++ way ++ words (config "SRC_HC_OPTS")
        liftIO $ BS.hPutStr resultHdl out_err
        liftIO $ hPutStrLn resultHdl $ "==nofib== " ++ name ++ ": size of " ++ name ++ " follows..."

        -- Report executable size
        Stdout out_err <- cmd "size" [out]
        liftIO $ BS.hPutStr resultHdl out_err
        liftIO $ hClose resultHdl

    ["//*.o","//*.hi","//*.o.result"] &%> \[o,hi,result] -> do
Ben Gamari's avatar
Ben Gamari committed
254 255 256 257 258 259 260 261 262 263 264
        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
Ben Gamari's avatar
Ben Gamari committed
265 266 267
        resultHdl <- liftIO $ openFile result WriteMode
        liftIO $ hPutStrLn resultHdl $ "==nofib== " ++ name ++ " : time to compile " ++ mod ++ " follows..."
        Stdouterr out_err <- cmd compiler $ ["-Rghc-timing","-c",src,"-w","-i"++obj,"-odir="++obj,"-hidir="++obj] ++
Ben Gamari's avatar
Ben Gamari committed
268
                           way ++ words (config "SRC_HC_OPTS")
Ben Gamari's avatar
Ben Gamari committed
269 270 271 272 273
        liftIO $ BS.hPutStr resultHdl out_err
        liftIO $ hPutStrLn resultHdl $ "==nofib== " ++ name ++ ": size of " ++ takeFileName o ++ " follows..."
        Stdout out_err <- cmd "size" [o]
        liftIO $ BS.hPutStr resultHdl out_err
        liftIO $ hClose resultHdl
Ben Gamari's avatar
Ben Gamari committed
274 275 276 277

    "//Main.deps" %> \out -> do
        let dir = unoutput out
        config <- readConfig' $ takeDirectory out </> "config.txt"
Ben Gamari's avatar
SHake  
Ben Gamari committed
278
        cmd_ compiler $ ["-w","-M",dir </> config "MAIN","-i" ++ dir,"-dep-makefile=" ++ out, "-dep-suffix", ""] ++
Ben Gamari's avatar
Ben Gamari committed
279 280 281 282
                           words (config "SRC_HC_OPTS")
        src <- liftIO $ readFile out
        need [x | x <- words src, takeExtension x `elem` [".hs",".lhs",".h"]]

Ben Gamari's avatar
Ben Gamari committed
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
    "//Main.cachegrind.result" %> \out -> do
        need [takeDirectory out </> "config.txt"]
        need [replaceExtensions out exe]
        let dir = unoutput out
        liftIO $ print dir
        runCachegrind nofib dir
        return ()

runCachegrind :: Nofib -> String -> Action Bool
runCachegrind nofib@Build{..} test = do
    resultsHdl <- liftIO $ openFile (test <.> "run.result") WriteMode
    liftIO $ hPutStrLn resultsHdl $ "==nofib== " ++ takeDirectory1 test ++ ": time to run " ++ takeDirectory1 test ++ " follows..."
    (stdin, args) <- liftIO $ getTestCmdline nofib test
    executable <- liftIO $ IO.canonicalizePath $ output </> test </> "Main" <.> exe
    cmd_ (Cwd test) "valgrind" "--tool=cachegrind" executable args
    return True

getTestCmdline :: Nofib -> String -> IO (FilePath, [String])
getTestCmdline nofib@Build{run=Just speed,..} test = do
    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
    return (stdin, args)
  where
    grab :: String -> IO String
    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
Ben Gamari's avatar
Ben Gamari committed
313 314 315 316

-- | Run a test, checking stdout/stderr are as expected, and reporting time.
--   Return True if the test passes.
runTest :: Nofib -> String -> IO Bool
Ben Gamari's avatar
Ben Gamari committed
317
runTest nofib@Build{run=Just speed,..} test = do
Ben Gamari's avatar
Ben Gamari committed
318
    putStrLn $ "==nofib== " ++ takeDirectory1 test ++ ": time to run " ++ takeDirectory1 test ++ " follows..."
Ben Gamari's avatar
Ben Gamari committed
319
    (stdin, args) <- getTestCmdline nofib test
Ben Gamari's avatar
Ben Gamari committed
320 321 322 323 324 325 326 327 328 329 330 331 332 333 334 335 336 337 338 339 340 341
    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

Ben Gamari's avatar
Ben Gamari committed
342
        grab :: String -> IO String
Ben Gamari's avatar
Ben Gamari committed
343 344 345 346 347 348 349 350 351 352 353 354 355 356 357 358 359 360 361 362 363 364 365 366 367 368 369 370 371 372 373 374 375 376 377 378 379 380 381 382 383 384 385 386 387 388 389 390 391 392 393 394 395 396 397 398 399 400 401 402 403 404 405 406 407 408 409 410 411 412 413 414 415 416 417 418 419 420 421 422 423 424
        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)