Nofib.hs 14.4 KB
Newer Older
dterei's avatar
dterei committed
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
{-# 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]
32 33
-- testRoots = words "imaginary spectral real parallel spectral/hartel"
testRoots = words "imaginary spectral real spectral/hartel"
dterei's avatar
dterei committed
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


-- | 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 $
217
            system' compiler $ ["-package","array","-Rghc-timing","-rtsopts","-o",out] ++ os ++ way ++ words (config "SRC_HC_OPTS")
dterei's avatar
dterei committed
218 219 220 221 222 223 224 225 226 227 228 229 230 231 232 233 234 235 236 237 238 239 240 241
        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"
242
        system' compiler $ ["-w","-M",dir </> config "MAIN","-i" ++ dir,"-dep-makefile=" ++ out, "-dep-suffix", ""] ++
dterei's avatar
dterei committed
243 244 245 246 247 248 249 250 251
                           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
252
    putStrLn $ "==nofib== " ++ takeDirectory1 test ++ ": time to run " ++ takeBaseName test ++ " follows..."
dterei's avatar
dterei committed
253 254 255
    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
256
    stats <- fmap (</> "stat.txt") (IO.canonicalizePath $ output </> test)
dterei's avatar
dterei committed
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 359

    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)