Commit 491e9d95 authored by Ben Gamari's avatar Ben Gamari 🐢

Add cachegrind support

parent 3b4210fa
......@@ -185,13 +185,14 @@ main = do
-- 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 ()
buildRules Build{..} = do
buildRules nofib@Build{..} = do
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]
want $ [ "cachegrind" ]
"//all-results" %> \out -> do
let results = [ s </> "Main" <.> exe <.> "result"
......@@ -202,6 +203,15 @@ buildRules Build{..} = do
xs <- mapM readFileLines results
writeFileLines out (concat xs)
"//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)
"//config.txt" %> \out -> do
let dir = unoutput out
src <- readFileLines $ dir </> "Makefile"
......@@ -270,15 +280,43 @@ buildRules Build{..} = do
src <- liftIO $ readFile out
need [x | x <- words src, takeExtension x `elem` [".hs",".lhs",".h"]]
"//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
-- | 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
runTest nofib@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
(stdin, args) <- getTestCmdline nofib test
stats <- IO.canonicalizePath $ output </> test </> "stat.txt"
fmap and $ replicateM times $ do
......@@ -301,6 +339,7 @@ runTest Build{run=Just speed,..} test = do
where
snip x = if length x > 200 then take 200 x ++ "..." else x
grab :: String -> IO String
grab ext = do
let s = [test </> takeFileName test <.> map toLower (show speed) ++ ext
,test </> takeFileName test <.> ext]
......
Markdown is supported
0% or
You are about to add 0 people to the discussion. Proceed with caution.
Finish editing this message first!
Please register or to comment