Commit 839a0389 authored by Ben Gamari's avatar Ben Gamari 🐢

Simplify

parent 1ddc5819
......@@ -4,10 +4,9 @@ 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)
deriving (Show, Eq, Ord)
parse :: FilePath -> IO (M.Map EventName Integer)
parse fname = parse' <$> readFile fname
......
{-# LANGUAGE FlexibleInstances #-}
{-# LANGUAGE OverloadedStrings #-}
import Data.Align
import Data.Maybe
import Data.These
......@@ -13,7 +16,8 @@ import Text.Tabular.AsciiArt
import Options.Applicative
import qualified MeasurementTree as MTree
import MeasurementTree (MeasurementTree')
import MeasurementTree (Measurements, Label)
import LabelMatch
args :: Parser [FilePath]
args = some $ argument str (metavar "FILE" <> help "results.json file")
......@@ -32,49 +36,34 @@ padDecimal before after x =
main :: IO ()
main = do
files <- execParser $ info (helper <*> args) mempty
mtrees <- mapM (fmap fromJust . MTree.readFile) files
mtrees <- mapM (fmap (MTree.toMap head . fromJust) . MTree.readFile) files
let aligned = alignMany $ M.fromList $ zip (map takeFileName files) mtrees
putStrLn
$ unlines
[ unlines
[ ""
, intercalate "/" $ map MTree.getLabel path
, replicate 20 '='
, ""
, render MTree.getLabel id (maybe "-" (\x -> showGFloat (Just 3) x "")) table
]
| (path, table) <- Tree.flatten $ toTables aligned
, Table _ _ (_:_) <- pure table
]
let tabulate :: (Show a, Ord a) => String -> (Label -> Maybe a) -> IO ()
tabulate heading pred = do
putStrLn $ render show show (maybe "-" (\x -> showGFloat (Just 3) x ""))
$ toTable
$ M.fromList
$ mapMaybe (\(k,v) -> (\k' -> (k',v)) <$> pred k)
$ M.toList aligned
tabulate "compiler allocations" (match compilerAllocs)
tabulate "compiler mutator time" (match compilerMutTime)
tabulate "compiler GC time" (match compilerGcTime)
alignMany :: Ord k => M.Map k (MeasurementTree' a) -> MeasurementTree' (M.Map k a)
alignMany :: (Align f, Ord k) => M.Map k (f a) -> f (M.Map k a)
alignMany mtrees =
foldl1 (alignWith (mergeThese M.union))
[ fmap (M.singleton label) mtree
| (label, mtree) <- M.toList mtrees
]
toGroupTree :: MeasurementTree' (M.Map k a)
-> Maybe (Tree ([MTree.Label], M.Map MTree.Label (M.Map k a)))
toGroupTree = toTree []
where
toTree :: [MTree.Label]
-> MeasurementTree' (M.Map k a)
-> Maybe (Tree ([MTree.Label], M.Map MTree.Label (M.Map k a)))
toTree path (MTree.Group children) =
Just $ Tree.Node (reverse path, samples) subgroups
where
samples = M.mapMaybe MTree.isSample children
subgroups = mapMaybe (\(k, xs) -> toTree (k:path) xs) (M.toList children)
toTree path _ = Nothing
-- | Test name, module name
objectCompilerStats :: LabelMatcher (String, String)
objectCompilerStats = (,) <$> wildcard <* "objects" <*> wildcard <* "rts stats"
toTables
:: Ord k
=> MeasurementTree' (M.Map k a)
-> Tree ([MTree.Label], Table MTree.Label k (Maybe a))
toTables mtree
| Just tree <- toGroupTree mtree = fmap (fmap toTable) tree
| otherwise = error "empty measurement tree"
compilerAllocs, compilerMutTime :: LabelMatcher (String, String)
compilerAllocs = objectCompilerStats <* "bytes allocated"
compilerMutTime = objectCompilerStats <* "mutator_cpu_seconds"
compilerGcTime = objectCompilerStats <* "GC_cpu_seconds"
toTable :: (Ord r, Ord c)
=> M.Map r (M.Map c a)
......
{-# LANGUAGE DeriveFunctor #-}
{-# LANGUAGE GADTs #-}
module LabelMatch where
import Control.Monad
import Data.String
import MeasurementTree (Label(..))
import qualified MeasurementTree as MTree
newtype LabelMatcher a = LabelMatcher (Label -> Maybe (Label, a))
deriving (Functor)
match :: LabelMatcher a -> Label -> Maybe a
match (LabelMatcher f) l = snd <$> f l
instance (a ~ ()) => IsString (LabelMatcher a) where
fromString = matchPart
instance Applicative LabelMatcher where
pure x = LabelMatcher $ \lbl -> Just (lbl, x)
(<*>) = ap
instance Monad LabelMatcher where
LabelMatcher f >>= g = LabelMatcher $ \lbl ->
case f lbl of
Nothing -> Nothing
Just (lbl', x) -> let LabelMatcher h = g x
in h lbl'
matchPart :: String -> LabelMatcher ()
matchPart s = LabelMatcher f
where
f (Label (x:xs))
| x == s = Just (Label xs, ())
f _ = Nothing
wildcard :: LabelMatcher String
wildcard = LabelMatcher f
where
f (Label (x:xs)) = Just (Label xs, x)
f (Label []) = Nothing
end :: LabelMatcher ()
end = LabelMatcher f
where
f (Label []) = Just (Label [], ())
f (Label _) = Nothing
......@@ -8,6 +8,7 @@ import Control.Exception
import Control.Monad
import Data.Bifunctor
import Data.Char
import Data.Foldable
import Data.List
import Data.Maybe
import qualified Data.Map.Strict as M
......@@ -26,9 +27,12 @@ import Development.Shake hiding ((*>))
import Development.Shake.FilePath hiding (exe)
import qualified MeasurementTree as MTree
import MeasurementTree (Measurements, Label(..))
import qualified ParseResults
import qualified CachegrindParse
ml = MTree.mkLabel
---------------------------------------------------------------------
-- TEST CONFIGURATION - which tests are available to run
......@@ -252,8 +256,8 @@ buildRules nofib@Build{..} = 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
Just ms <- liftIO $ MTree.readFile (o <.> "results.json")
return ms
-- Link executable
liftIO $ hPutStrLn resultHdl $ "==nofib== " ++ name ++ " : time to link " ++ name ++ " follows..."
......@@ -268,10 +272,9 @@ buildRules nofib@Build{..} = do
liftIO $ BS.hPutStr resultHdl out_err
liftIO $ hClose resultHdl
liftIO $ MTree.writeFile resultsJson $ MTree.group
[ ("objects", MTree.Group $ M.unions objectResults)
, ("executable size", MTree.Sample $ realToFrac execSize)
]
liftIO $ MTree.writeFile resultsJson
$ fold objectResults
<> MTree.singleton (ml "executable size") (realToFrac execSize)
["//*.o","//*.hi","//*.o.result","//*.o.results.json"] &%> \[o,hi,result,resultsJson] -> do
......@@ -297,11 +300,11 @@ buildRules nofib@Build{..} = do
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)
]
rtsStats <- liftIO $ readRtsStats $ o++".stats"
liftIO $ MTree.writeFile resultsJson
$ MTree.prefix (MTree.mkLabel test <> ml "objects" <> MTree.mkLabel (takeFileName o))
$ MTree.singleton (ml "size") (realToFrac $ ParseResults.parseCodeSize $ BS.unpack out_err)
<> MTree.prefix (ml "rts stats") rtsStats
liftIO $ hClose resultHdl
......@@ -324,8 +327,11 @@ buildRules nofib@Build{..} = do
"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
$ MTree.fromList
$ [ (MTree.mkLabel test <> ml "run" <> ml "cachegrind" <> lbl, realToFrac v)
| (eventName, v) <- M.toList stats
, let lbl = MTree.mkLabel $ CachegrindParse.getEventName eventName
]
where
objectsForExecutable :: FilePath -> Action [FilePath]
......@@ -348,6 +354,11 @@ getTestCmdline nofib@Build{..} test = do
ss <- filterM IO.doesFileExist s
maybe (return BSL.empty) BSL.readFile $ listToMaybe ss
readRtsStats :: FilePath -> IO (Measurements Double)
readRtsStats fname = do
rtsStats <- ParseResults.parseRtsStats <$> readFile fname
return $ MTree.fromList $ map (first MTree.mkLabel) $ M.toList rtsStats
-- | Run a test, checking stdout/stderr are as expected, and reporting time.
-- Return True if the test passes.
runTest :: Nofib -> String -> IO Bool
......@@ -371,12 +382,9 @@ runTest nofib@Build{..} test = do
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
rtsStats <- readRtsStats stats
MTree.writeFile (output </> test </> "run.results.json")
$ MTree.singleton test
$ MTree.singleton "run"
$ MTree.group [ ("rts stats", rtsStats) ]
$ MTree.prefix (MTree.mkLabel test <> ml "run" <> ml "rts stats") rtsStats
err <- return $
if not skip_check && stderr /= stderrWant then "FAILED STDERR\nWANTED: " ++ snip stderrWant ++ "\nGOT: " ++ snip stderr
......
......@@ -39,7 +39,7 @@ executable nofib-run
executable nofib-compare
main-is: Compare.hs
other-modules:
other-modules: LabelMatch
other-extensions: RecordWildCards, DeriveDataTypeable
build-depends: base >=4.10 && <4.13,
these,
......
......@@ -5,9 +5,9 @@
module MeasurementTree where
import Data.Align
import Data.These
import Data.String (IsString)
import Data.String (IsString(..))
import Data.Bifunctor
import Data.Maybe
import Control.Applicative
import Control.Monad
import Data.Aeson
......@@ -21,78 +21,47 @@ newtype Label = Label { getLabel :: [String] }
instance IsString Label where
fromString s = Label [s]
type MeasurementTree = MeasurementTree' Double
data MeasurementTree' a = Sample a
-- ^ A measurement result
| Group (M.Map Label (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 :: Label -> MeasurementTree' a -> MeasurementTree' a
singleton name = Group . M.singleton name
singletonSample :: Label -> a -> MeasurementTree' a
singletonSample name = singleton name . Sample
isSample :: MeasurementTree' a -> Maybe a
isSample (Sample x) = Just x
isSample _ = Nothing
writeFile' :: ToJSON a => FilePath -> MeasurementTree' a -> IO ()
mkLabel :: String -> Label
mkLabel = fromString
newtype Measurements a = Measurements [(Label, a)]
deriving (Show, Functor, Monoid, Semigroup, ToJSON, FromJSON)
toMap :: ([a] -> b) -> Measurements a -> M.Map Label b
toMap f (Measurements xs) =
fmap f $ M.fromListWith (<>) [ (x, [y]) | (x,y) <- xs ]
fromMap :: M.Map Label a -> Measurements a
fromMap = Measurements . M.toList
prefix :: Label -> Measurements a -> Measurements a
prefix lbl (Measurements xs) = Measurements $ map (first (lbl<>)) xs
singleton :: Label -> a -> Measurements a
singleton lbl x = Measurements [(lbl, x)]
fromList :: [(Label, a)] -> Measurements a
fromList = Measurements
filterByLabel :: (Label -> Bool) -> Measurements a -> Measurements a
filterByLabel f (Measurements xs) = Measurements $ filter (f . fst) xs
mapLabels :: (Label -> Maybe Label) -> Measurements a -> Measurements a
mapLabels f (Measurements xs) =
Measurements $ mapMaybe (\(k,v) -> (\k' -> (k', v)) <$> f k) xs
writeFile' :: ToJSON a => FilePath -> Measurements a -> IO ()
writeFile' fname = BSL.writeFile fname . encode
writeFile :: FilePath -> MeasurementTree -> IO ()
writeFile :: FilePath -> Measurements Double -> IO ()
writeFile = writeFile'
readFile' :: FromJSON a => FilePath -> IO (Maybe (MeasurementTree' a))
readFile' :: FromJSON a => FilePath -> IO (Maybe (Measurements a))
readFile' fname = decode <$> BSL.readFile fname
readFile :: FilePath -> IO (Maybe MeasurementTree)
readFile :: FilePath -> IO (Maybe (Measurements Double))
readFile = readFile'
group :: [(Label, 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
flatten :: MeasurementTree' a -> [([Label], a)]
flatten = go []
where
go path (Group xs) = foldMap (\(label,x) -> go (label:path) x) (M.toList xs)
go path (Sample x) = [(reverse path, x)]
mean :: RealFrac a => [a] -> a
mean xs = sum xs / realToFrac (length xs)
......@@ -103,12 +72,3 @@ stdDev :: RealFloat a => [a] -> a
stdDev xs = sqrt $ mean $ map (\x -> (x-m)^(2::Int)) xs
where m = mean xs
instance Semialign MeasurementTree' where
align (Sample x) (Sample y) = Sample $ These x y
align (Group x) (Group y) = let f (This a) = fmap This a
f (That b) = fmap That b
f (These a b) = align a b
in Group $ alignWith f x y
align (Sample x) _ = Sample $ This x
align _ (Sample y) = Sample $ That y
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