Commit f2a24e7d authored by Ben Gamari's avatar Ben Gamari 🐢

Collect statistics

parent ac596ee3
{-# LANGUAGE GeneralizedNewtypeDeriving #-}
module CachegrindParse where
import Data.Maybe
import qualified Data.Map as M
import Data.Aeson
newtype EventName = EventName { getEventName :: String }
deriving (Show, Eq, Ord, ToJSON, FromJSON, ToJSONKey, FromJSONKey)
parse :: FilePath -> IO (M.Map EventName Integer)
parse fname = parse' <$> readFile fname
parse' :: String -> M.Map EventName Integer
parse' content =
M.fromList $ zip summary events
where
events = case mapMaybe isEventList $ lines content of
[] -> error "No event list found"
[x] -> x
_ -> error "More than one event list found"
summary = case mapMaybe isSummaryList $ lines content of
[] -> error "No event summary found"
[x] -> x
_ -> error "More than one event summary found"
isEventList :: String -> Maybe [Integer]
isEventList line
| "summary:" : rest <- words line = Just $ map read rest
| otherwise = Nothing
isSummaryList :: String -> Maybe [EventName]
isSummaryList line
| "events:" : rest <- words line = Just $ map EventName rest
| otherwise = Nothing
......@@ -6,6 +6,7 @@ module Main(main) where
import Control.Concurrent
import Control.Exception
import Control.Monad
import Data.Bifunctor
import Data.Char
import Data.List
import Data.Maybe
......@@ -24,6 +25,9 @@ import System.Console.CmdArgs
import Development.Shake hiding ((*>))
import Development.Shake.FilePath hiding (exe)
import qualified MeasurementTree as MTree
import qualified ParseResults
import qualified CachegrindParse
---------------------------------------------------------------------
-- TEST CONFIGURATION - which tests are available to run
......@@ -233,7 +237,7 @@ buildRules nofib@Build{..} = do
x:_ -> "MAIN = " ++ x
writeFileLines out $ mainMod : convertConfig src
["//Main" <.> exe, "//Main" <.> exe <.> "result"] &%> \[out, result] -> do
["//Main" <.> exe, "//Main" <.> exe <.> "result", "//Main.results.json"] &%> \[out, result, resultsJson] -> 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"]
......@@ -245,9 +249,11 @@ buildRules nofib@Build{..} = do
resultHdl <- liftIO $ openFile result WriteMode
-- Add results from object compilation to results output
forM os $ \o -> do
objectResults <- forM os $ \o -> do
ls <- liftIO $ BS.readFile (o <.> "result")
liftIO $ BS.hPutStr resultHdl ls
Just mtree <- liftIO $ MTree.readFile (o <.> "results.json")
return $ M.singleton o mtree
-- Link executable
liftIO $ hPutStrLn resultHdl $ "==nofib== " ++ name ++ " : time to link " ++ name ++ " follows..."
......@@ -258,10 +264,17 @@ buildRules nofib@Build{..} = do
-- Report executable size
Stdout out_err <- cmd "size" [out]
let execSize = ParseResults.parseCodeSize $ BS.unpack out_err
liftIO $ BS.hPutStr resultHdl out_err
liftIO $ hClose resultHdl
["//*.o","//*.hi","//*.o.result"] &%> \[o,hi,result] -> do
liftIO $ MTree.writeFile resultsJson $ MTree.group
[ ("objects", MTree.Group $ M.unions objectResults)
, ("executable size", MTree.Sample $ realToFrac execSize)
]
["//*.o","//*.hi","//*.o.result","//*.o.results.json"] &%> \[o,hi,result,resultsJson] -> do
let dir = unoutput o
obj = output </> dir
config <- readConfig' $ obj </> "config.txt"
......@@ -272,15 +285,24 @@ buildRules nofib@Build{..} = do
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
let test = takeFileName dir
resultHdl <- liftIO $ openFile result WriteMode
liftIO $ hPutStrLn resultHdl $ "==nofib== " ++ name ++ " : time to compile " ++ mod ++ " follows..."
liftIO $ hPutStrLn resultHdl $ "==nofib== " ++ test ++ " : time to compile " ++ mod ++ " follows..."
let rts_args = [ "+RTS", "--machine-readable", "-t"++o++".stats" ]
Stdouterr out_err <- cmd compiler $ ["-Rghc-timing","-c",src,"-w","-i"++obj,"-odir="++obj,"-hidir="++obj] ++
way ++ words (config "SRC_HC_OPTS") ++ [compiler_args]
way ++ words (config "SRC_HC_OPTS") ++ [compiler_args] ++ rts_args
liftIO $ BS.hPutStr resultHdl out_err
liftIO $ hPutStrLn resultHdl $ "==nofib== " ++ name ++ ": size of " ++ takeFileName o ++ " follows..."
liftIO $ hPutStrLn resultHdl $ "==nofib== " ++ test ++ ": size of " ++ takeFileName o ++ " follows..."
Stdout out_err <- cmd "size" [o]
liftIO $ BS.hPutStr resultHdl out_err
rtsStats <- liftIO $ ParseResults.parseRtsStats <$> readFile (o++".stats")
liftIO $ MTree.writeFile resultsJson $ MTree.group
[ ("size", MTree.Sample $ realToFrac $ ParseResults.parseCodeSize $ BS.unpack out_err)
, ("rts stats", MTree.Group $ fmap MTree.Sample rtsStats)
]
liftIO $ hClose resultHdl
"//Main.deps" %> \out -> do
......@@ -291,7 +313,7 @@ buildRules nofib@Build{..} = do
src <- liftIO $ readFile out
need [x | x <- words src, takeExtension x `elem` [".hs",".lhs",".h"]]
"//Main.cachegrind.result" %> \out -> do
["//Main.cachegrind.result", "//Main.cachegrind.results.json"] &%> \[out, resultsJson] -> do
need [takeDirectory out </> "config.txt"]
need [replaceExtensions out exe]
let test = unoutput out
......@@ -300,6 +322,17 @@ buildRules nofib@Build{..} = do
out' <- liftIO $ IO.canonicalizePath out
cmd_ (Cwd test) (EchoStdout False) (StdinBS stdin)
"valgrind" "--tool=cachegrind" cachegrind_args ("--cachegrind-out-file="++out') executable args
stats <- liftIO $ CachegrindParse.parse out'
liftIO $ MTree.writeFile resultsJson
$ MTree.singleton test $ MTree.singleton "run" $ MTree.singleton "cachegrind"
$ MTree.group $ map (bimap CachegrindParse.getEventName (MTree.Sample . realToFrac)) $ M.toList stats
where
objectsForExecutable :: FilePath -> Action [FilePath]
objectsForExecutable executable = do
deps <- readFile' $ replaceExtension executable "deps"
return $ nub [ if isLower $ head $ takeFileName x then replaceExtension executable "o" else output </> x
| x <- words deps, takeExtension x == ".o"]
getTestCmdline :: Nofib -> String -> IO (BSL.ByteString, [String])
getTestCmdline nofib@Build{..} test = do
......@@ -327,14 +360,24 @@ runTest nofib@Build{..} test = do
fmap and $ replicateM times $ do
start <- getCurrentTime
(code,stdout,stderr) <- readProcessWithExitCodeAndWorkingDirectory
test executable (args++"+RTS":rts++["-t"++stats]) stdin
test executable (args++"+RTS":rts++["--machine-readable", "-t"++stats]) stdin
end <- getCurrentTime
stdoutWant <- grab "stdout"
stderrWant <- grab "stderr"
BSL.writeFile (output </> test </> "stdout") stdout
BSL.writeFile (output </> test </> "stderr") stderr
putStrLn $ show (floor $ fromRational (toRational $ end `diffUTCTime` start) * 1000) ++ "ms"
putStr =<< readFile stats
parsedStats <- ParseResults.parseRtsStats <$> readFile stats
let rtsStats = MTree.Group $ fmap MTree.Sample parsedStats
MTree.writeFile (output </> test </> "run.results.json")
$ MTree.singleton test
$ MTree.singleton "run"
$ MTree.group [ ("rts stats", rtsStats) ]
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
......
{-# LANGUAGE DeriveFunctor #-}
{-# LANGUAGE DeriveGeneric #-}
{-# LANGUAGE OverloadedStrings #-}
module MeasurementTree where
import Control.Applicative
import Control.Monad
import Data.Aeson
import qualified Data.Map.Strict as M
import GHC.Generics
import qualified Data.ByteString.Lazy as BSL
type MeasurementTree = MeasurementTree' Double
data MeasurementTree' a = Sample a
-- ^ A measurement result
| Group (M.Map String (MeasurementTree' a))
-- ^ A group of related measurements.
deriving (Functor, Generic)
instance ToJSON a => ToJSON (MeasurementTree' a) where
toJSON (Sample x) = toJSON x
toJSON (Group x) = object [ "type" .= ("group" :: String)
, "children" .= x
]
instance FromJSON a => FromJSON (MeasurementTree' a) where
parseJSON v = parseGroup v <|> fmap Sample (parseJSON v)
where
parseGroup = withObject "group" $ \o -> do
typ <- o .: "type"
guard $ typ == ("group" :: String)
Group <$> o .: "children"
--instance ToJSON a => ToJSON (MeasurementTree' a)
--instance FromJSON a => FromJSON (MeasurementTree' a)
singleton :: String -> MeasurementTree' a -> MeasurementTree' a
singleton name = Group . M.singleton name
singletonSample :: String -> a -> MeasurementTree' a
singletonSample name = singleton name . Sample
writeFile' :: ToJSON a => FilePath -> MeasurementTree' a -> IO ()
writeFile' fname = BSL.writeFile fname . encode
writeFile :: FilePath -> MeasurementTree -> IO ()
writeFile = writeFile'
readFile' :: FromJSON a => FilePath -> IO (Maybe (MeasurementTree' a))
readFile' fname = decode <$> BSL.readFile fname
readFile :: FilePath -> IO (Maybe MeasurementTree)
readFile = readFile'
group :: [(String, MeasurementTree' a)] -> MeasurementTree' a
group = Group . M.fromList
collect :: RealFrac a => [MeasurementTree' a] -> MeasurementTree' [a]
collect = go [""]
where
isSample (Sample _) = True
isSample _ = False
isGroup = not . isSample
go path trees
| all isSample trees = Sample [ x | Sample x <- trees ]
| all isGroup trees =
Group $ M.mapWithKey (\k ts -> go (k:path) ts) $ M.fromListWith (<>)
[ (k,[t])
| Group xs <- trees
, (k,t) <- M.toList xs
]
| otherwise = error $ "Measurement tree type mismatch at " ++ show path
mean :: RealFrac a => [a] -> a
mean xs = sum xs / realToFrac (length xs)
geomMean :: RealFloat a => [a] -> a
geomMean = exp . mean . map log
stdDev :: RealFloat a => [a] -> a
stdDev xs = sqrt $ mean $ map (\x -> (x-m)^(2::Int)) xs
where m = mean xs
module ParseResults
( parseCodeSize
, parseRtsStats
) where
import qualified Data.Map.Strict as M
import Data.Maybe
-- | Parse text section size out of Berkley-format @size@ output
parseCodeSize :: String -> Integer
parseCodeSize content
| header : sizes : _ <- lines content
, "text" : _ <- words header =
read $ head $ words sizes
| otherwise = error "unrecognized size output"
parseRtsStats :: String -> M.Map String Double
parseRtsStats = foldMap parseValue . readPairs . dropFirstLine
where
parseValue (name, value)
| (x, ""):_ <- reads value = M.singleton name x
| otherwise = M.empty
dropFirstLine = unlines . drop 1 . lines
readPairs :: String -> [(String, String)]
readPairs s
| (x, _):_ <- reads s = x
| otherwise = error $ "Failed to parse RTS statistics: " ++ s
......@@ -14,7 +14,7 @@ build-type: Simple
executable nofib-run
main-is: Main.hs
-- other-modules:
other-modules: CachegrindParse, ParseResults, MeasurementTree
other-extensions: RecordWildCards, DeriveDataTypeable
build-depends: base >=4.10 && <4.13,
time >=1.8 && <1.9,
......@@ -22,6 +22,7 @@ executable nofib-run
bytestring,
directory >=1.3 && <1.4,
process >=1.6 && <1.7,
aeson,
cmdargs,
shake
default-language: Haskell2010
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