Skip to content
Snippets Groups Projects

nofib-compare improvements

Open nofib-compare improvements
wip/nofib-compare-improvementrs into master
Open Ben Gamari requested to merge wip/nofib-compare-improvementrs into master
Compare
and
1 file
+ 205
− 203
Compare changes
  • Side-by-side
  • Inline
shake/compare/Compare.hs
+ 205
− 203
{-# LANGUAGE FlexibleInstances #-}
{-# LANGUAGE GeneralizedNewtypeDeriving #-}
{-# LANGUAGE OverloadedStrings #-}
{-# LANGUAGE ScopedTypeVariables #-}
import Debug.Trace
import Data.Align (Align, alignWith)
import Control.Monad (join)
import Data.Maybe
import Data.These
import Data.Char
@@ -12,17 +12,17 @@ import Data.List (intercalate, group)
import Data.Foldable
import Numeric
import qualified Data.Sequence as Seq
import qualified Data.Tree as Tree
import Data.Tree (Tree)
import qualified Data.Map.Strict as M
import qualified Data.Text as T
import qualified Data.Set as S
import System.Directory
import System.FilePath
import Text.Tabular
import qualified Text.Tabular.AsciiArt as AsciiArt
import qualified Text.Tabular.Csv as Csv
import qualified Text.Tabular.Latex as Latex
import Options.Applicative as O
import Options.Applicative hiding (value)
import qualified Options.Applicative as O
import System.Console.ANSI.Codes as ANSI
import qualified Measurements as Ms
@@ -31,18 +31,28 @@ import LabelMatch
data Mode = RelativeMode | AbsoluteMode
args :: Parser (Mode, OutputDest, OutputFormat, OutputOptions, [FilePath])
args =
(,,,,)
data Opts = Opts { outputMode :: Mode
, outputDest :: OutputDest
, outputFormat :: OutputFormat
, outputOptions :: OutputOptions
, showStdErr :: Bool
, inputs :: [FilePath]
}
optDesc :: Parser Opts
optDesc =
Opts
<$> flag RelativeMode AbsoluteMode (long "absolute" <> short 'a' <> help "show absolute metrics")
<*> outputDest
<*> formatOption
<*> outputOptions
<*> switch (long "stderr" <> help "show standard error of each metric ensemble")
<*> some (argument str (metavar "FILE" <> help "results.json file"))
where
formatOption :: Parser OutputFormat
formatOption = option (str >>= parse) (long "format" <> short 'f' <> help "Output format (one of markdown, ascii, csv, latex)" <> O.value FmtAsciiArt)
where
parse :: String -> ReadM OutputFormat
parse "markdown" = pure FmtMarkdown
parse "ascii" = pure FmtAsciiArt
parse "csv" = pure FmtCsv
@@ -90,6 +100,7 @@ render FmtLatex = Latex.render
-- name. Essentially we just break up all paths into their components and drop
-- all components common to all.
friendlyNameFiles :: [FilePath] -> M.Map MetricFile FilePath
friendlyNameFiles [f] = M.singleton (MetricFile f) f
friendlyNameFiles files =
M.fromList
[ (MetricFile $ joinPath $ toList name, path)
@@ -129,23 +140,30 @@ data OutputOptions = OutputOptions { fancyChars, color :: Bool }
simpleOutput :: OutputOptions
simpleOutput = OutputOptions False False
class ToRowLabel a where toRowLabel :: a -> String
instance ToRowLabel String where toRowLabel = id
instance ToRowLabel Label where toRowLabel = T.unpack . Ms.encodeLabel
instance (ToRowLabel a, ToRowLabel b) => ToRowLabel (a,b) where
toRowLabel (a,b) = toRowLabel a ++ " // " ++ toRowLabel b
class ToHeadingLabel a where toHeadingLabel :: a -> String
instance ToHeadingLabel String where toHeadingLabel = id
instance ToHeadingLabel MetricFile where toHeadingLabel (MetricFile f) = f
instance ToHeadingLabel Label where toHeadingLabel = T.unpack . Ms.encodeLabel
instance (ToHeadingLabel a, ToHeadingLabel b) => ToHeadingLabel (a,b) where
toHeadingLabel (a,b) = toHeadingLabel a ++ " // " ++ toHeadingLabel b
instance ToHeadingLabel lbl => ToHeadingLabel (TabulateTestRow lbl) where
toHeadingLabel (TabTestRowMetrics lbl) = toHeadingLabel lbl
toHeadingLabel TabTestRowMin = "min"
toHeadingLabel TabTestRowMax = "max"
toHeadingLabel TabTestRowGeomMean = "geo. mean"
instance ToHeadingLabel TabulateTestCol where
toHeadingLabel (TabTestColAbsolute f) = toHeadingLabel f
toHeadingLabel (TabTestColRelative f) = toHeadingLabel f
toHeadingLabel (TabTestColStdErr f) = "std.err(" ++ toHeadingLabel f ++ ")"
withColor :: OutputOptions -> ANSI.Color -> ShowS -> ShowS
withColor opts c s
| color opts =
showString start . s . showString end
showString start . s . showString reset
| otherwise = s
where
start = ANSI.setSGRCode [ANSI.SetColor ANSI.Foreground ANSI.Vivid c]
end = ANSI.setSGRCode [ANSI.Reset]
showGFloat' :: RealFloat a => OutputOptions -> Maybe Int -> a -> ShowS
showGFloat' opts prec x = prettySign opts x . showGFloat prec (abs x)
reset = ANSI.setSGRCode [ANSI.Reset]
showGFloatAbsolute :: RealFloat a => OutputOptions -> Maybe Int -> a -> ShowS
showGFloatAbsolute opts prec x
@@ -193,92 +211,67 @@ writeTable dest title contents =
ToStdout -> putStrLn
ToSingleFile path -> appendFile path
main :: IO ()
main = do
(mode, outputDest, fmt, opts, files) <- execParser $ info (helper <*> args) mempty
initializeOutputDest outputDest
let filesWithFriendlyNames :: M.Map MetricFile FilePath
filesWithFriendlyNames = friendlyNameFiles files
-- Yuck. Figure out friendly name of reference set
[ref] = [ name
| (name, fname) <- M.toList filesWithFriendlyNames
, fname == head files
]
readAligned :: [FilePath] -> IO (M.Map MetricFile FilePath, M.Map Label (M.Map MetricFile (MeanStddev Double)))
readAligned files = do
mtrees <- mapM Ms.readFile filesWithFriendlyNames
:: IO (M.Map MetricFile (Measurements Double))
let mtrees' :: M.Map MetricFile (M.Map Label (MeanStddev Double))
mtrees' = fmap (Ms.toMap (fromJust . meanStdErr)) mtrees
let aligned :: M.Map Label (M.Map MetricFile (MeanStddev Double))
aligned = alignMany mtrees'
return (filesWithFriendlyNames, aligned)
where
filesWithFriendlyNames :: M.Map MetricFile FilePath
filesWithFriendlyNames = friendlyNameFiles files
let tabulate :: forall rh. (Ord rh, ToRowLabel rh) => String -> LabelMatcher rh -> IO ()
tabulate heading pred = writeTable outputDest heading contents
where
xs :: M.Map rh (M.Map MetricFile (MeanStddev Double))
xs = M.fromList
$ mapMaybe (\(k,v) -> (\k' -> (k',v)) <$> match pred k)
$ M.toList aligned
contents
| null xs = "## no samples"
| otherwise =
case mode of
RelativeMode ->
let showRel = maybe "∙" (showRelative (showGFloat' opts (Just 3)) (showPercent opts))
relChg = toRelativeChange ref (fmap (fmap msMean) xs)
cols :: [SemiTable Column Cell]
cols =
[ absoluteCol xs ref, stderrCol xs ref ] ++
concat
[ [ relativeCol xs ref metricFile
, stderrCol xs metricFile
]
| metricFile <- M.keys mtrees
, metricFile /= ref
]
table :: Table rh Column Cell
table = foldl' (^|^) (baseTable xs) cols
in render fmt id (runShowS . showColumn) id
$ mapRowHeader toRowLabel (mapTable (runShowS . showCell opts) table)
+====+
mapSemiTable (maybe "" (\x -> showsPctChange opts x "")) (geomMeanRow relChg)
AbsoluteMode ->
let cols :: [SemiTable Column Cell]
cols = concat
[ [ absoluteCol xs metricFile
, stderrCol xs metricFile
]
| metricFile <- M.keys mtrees
]
table :: Table rh Column Cell
table = foldl' (^|^) (baseTable xs) cols
in render fmt toRowLabel (runShowS . showColumn) (runShowS . showCell opts) table
main :: IO ()
main = do
opts <- execParser $ info (helper <*> optDesc) mempty
initializeOutputDest (outputDest opts)
(filesWithFriendlyNames, aligned) <- readAligned (inputs opts)
let -- Yuck. Figure out friendly name of reference set
[ref] =
[ name
| (name, fname) <- M.toList filesWithFriendlyNames
, fname == head (inputs opts)
]
let tabulateTest' :: forall lbl. (Ord lbl, ToHeadingLabel lbl) => String -> LabelMatcher lbl -> IO ()
tabulateTest' name pred = do
let xs :: M.Map lbl (M.Map MetricFile (MeanStddev Double))
xs = M.fromList
$ mapMaybe (\(k,v) -> (\k' -> (k',v)) <$> match pred k)
$ M.toList aligned
writeTable (outputDest opts) name
(render (outputFormat opts) toHeadingLabel toHeadingLabel id $ tabulateTest opts xs ref)
-- compile-time metrics
tabulate "compiler allocations" $ objectCompilerRtsStats <* "bytes allocated"
tabulate "compiler mutator time" $ objectCompilerRtsStats <* ("mutator_cpu_seconds" <|> "mut_cpu_seconds")
tabulate "compiler GC (cpu) time" $ objectCompilerRtsStats <* "GC_cpu_seconds"
tabulate "compiler GC (wall) time" $ objectCompilerRtsStats <* "GC_wall_seconds"
tabulate "executable size" $ testName <* "executable size"
tabulateTest' "compiler allocations" $ objectCompilerRtsStats <* "bytes allocated"
tabulateTest' "compiler mutator time" $ objectCompilerRtsStats <* ("mutator_cpu_seconds" <|> "mut_cpu_seconds")
tabulateTest' "compiler GC (cpu) time" $ objectCompilerRtsStats <* "GC_cpu_seconds"
tabulateTest' "compiler GC (wall) time" $ objectCompilerRtsStats <* "GC_wall_seconds"
tabulateTest' "executable size" $ testName <* "executable size"
-- run-time metrics
tabulate "bytes allocated" $ runRtsStats <* "bytes allocated"
tabulate "mutator time" $ runRtsStats <* ("mutator_cpu_seconds" <|> "mut_cpu_seconds")
tabulate "GC (cpu) time" $ runRtsStats <* "GC_cpu_seconds"
tabulate "GC (wall) time" $ runRtsStats <* "GC_wall_seconds"
tabulate "Elapsed (wall) time" $ runRtsStats <* "total_wall_seconds"
tabulateTest' "bytes allocated" $ runRtsStats <* "bytes allocated"
tabulateTest' "mutator time" $ runRtsStats <* ("mutator_cpu_seconds" <|> "mut_cpu_seconds")
tabulateTest' "GC (cpu) time" $ runRtsStats <* "GC_cpu_seconds"
tabulateTest' "GC (wall) time" $ runRtsStats <* "GC_wall_seconds"
tabulateTest' "Elapsed (wall) time" $ runRtsStats <* "total_wall_seconds"
-- cachegrind
tabulate "instructions" $ cachegrindStats <* "Ir"
tabulate "LLC cache misses" $ cachegrindStats <* "DLmr"
tabulate "L1 cache misses" $ cachegrindStats <* "D1mr"
tabulateTest' "instructions" $ cachegrindStats <* "Ir"
tabulateTest' "LLC cache misses" $ cachegrindStats <* "DLmr"
tabulateTest' "L1 cache misses" $ cachegrindStats <* "D1mr"
tabulate "perf cache-misses" $ perfStats <* ("cache-misses" <|> "cache-misses:u")
tabulate "perf instructions" $ perfStats <* ("instructions" <|> "instructions:u")
tabulate "perf cycles" $ perfStats <* ("cycles" <|> "cycles:u")
tabulateTest' "perf cache-misses" $ perfStats <* ("cache-misses" <|> "cache-misses:u")
tabulateTest' "perf instructions" $ perfStats <* ("instructions" <|> "instructions:u")
tabulateTest' "perf cycles" $ perfStats <* ("cycles" <|> "cycles:u")
tabulateSummary
[ ("compiler allocations", objectCompilerRtsStats <* "bytes allocated")
, ("bytes allocated" $ runRtsStats <* "bytes allocated")
]
alignMany :: (Align f, Ord k) => M.Map k (f a) -> f (M.Map k a)
alignMany mtrees =
@@ -287,6 +280,118 @@ alignMany mtrees =
| (k, mtree) <- M.toList mtrees
]
mkTable :: forall rh ch. (ToHeadingLabel rh, ToHeadingLabel ch)
=> Header rh -> Header ch
-> (rh -> ch -> String)
-> Table rh ch String
mkTable rows cols oracle =
Table rows cols contents
where
contents =
[ [ oracle r c
| c <- headerContents cols
]
| r <- headerContents rows
]
data TabulateTestCol
= TabTestColAbsolute MetricFile
| TabTestColRelative MetricFile
| TabTestColStdErr MetricFile
deriving (Eq, Ord, Show)
data TabulateTestRow lbl
= TabTestRowMetrics lbl
| TabTestRowMin
| TabTestRowMax
| TabTestRowGeomMean
deriving (Eq, Ord, Show)
tabulateTest
:: forall rh. (Ord rh, ToHeadingLabel rh)
=> Opts
-> M.Map rh (M.Map MetricFile (MeanStddev Double))
-- ^ metrics to tabulate
-> MetricFile
-- ^ reference set
-> Table (TabulateTestRow rh) TabulateTestCol String
tabulateTest opts aligned ref =
table
where
table :: Table (TabulateTestRow rh) TabulateTestCol String
table = mkTable rows cols oracle
cols :: Header TabulateTestCol
cols = Group SingleLine $
[ Header $ TabTestColAbsolute ref
] ++
[ Group SingleLine
$ [case outputMode opts of
RelativeMode -> Header $ TabTestColRelative m
AbsoluteMode -> Header $ TabTestColAbsolute m
] ++ [Header $ TabTestColStdErr m | showStdErr opts]
| m <- allFiles
, m /= ref
]
allFiles :: [MetricFile]
allFiles = S.toList $ foldMap M.keysSet aligned
rows :: Header (TabulateTestRow rh)
rows = Group SingleLine
[ Group NoLine (map (Header . TabTestRowMetrics) (M.keys aligned))
, Group NoLine
[ Header TabTestRowGeomMean
, Header TabTestRowMin
, Header TabTestRowMax
]
]
showRel :: RelChange Double -> String
showRel r = showsRelChange (outputOptions opts) r ""
oracle :: TabulateTestRow rh -> TabulateTestCol -> String
oracle (TabTestRowMetrics lbl) (TabTestColAbsolute m) = showMb $ fmap msMean (lookup lbl m)
oracle (TabTestRowMetrics lbl) (TabTestColRelative m) = maybe "-" (showRel . toRelChange) $ lookupRel lbl m
oracle (TabTestRowMetrics lbl) (TabTestColStdErr m) = showMb $ fmap msStddev (lookup lbl m)
oracle TabTestRowMin (TabTestColRelative m) = aggregateRel (showRel . minimum . catMaybes) m
oracle TabTestRowMin _ = ""
oracle TabTestRowMax (TabTestColRelative m) = aggregateRel (showRel . maximum . catMaybes) m
oracle TabTestRowMax _ = ""
oracle TabTestRowGeomMean (TabTestColRelative m) = aggregateRel (maybe "-" showRel . geomMean . catMaybes) m
oracle TabTestRowGeomMean _ = ""
showMb = maybe "-" show
aggregateRel :: ([Maybe (RelChange Double)] -> String) -> MetricFile -> String
aggregateRel f m = f $ map (fmap toRelChange) $ fmap join $ M.elems $ M.map (M.lookup m) relative
lookup :: rh -> MetricFile -> Maybe (MeanStddev Double)
lookup lbl file = M.lookup lbl aligned >>= M.lookup file
lookupRel :: rh -> MetricFile -> Maybe (ValueBaseline Double)
lookupRel lbl file = M.lookup lbl relative >>= M.lookup file >>= id
relative :: M.Map rh (M.Map MetricFile (Maybe (ValueBaseline Double)))
relative = M.mapWithKey f aligned
where
f :: rh
-> M.Map MetricFile (MeanStddev Double)
-> M.Map MetricFile (Maybe (ValueBaseline Double))
f lbl = M.map $ \ms -> do
baseline <- msMean <$> lookup lbl ref
return $ ValueBaseline { value = msMean ms
, baseline = baseline
}
showPercent :: Double -> String
showPercent n = sign . showGFloat (Just 1) n . showChar '%' $ ""
where
sign = if n > 0 then showChar '+' else id
showRelPercent :: Double -> String
showRelPercent n = showPercent (n-1)
type TestName = String
type ModuleName = String
@@ -305,76 +410,17 @@ cachegrindStats = testName <* "run" <* "cachegrind"
perfStats :: LabelMatcher TestName
perfStats = testName <* "run" <* "perf"
data Column = AbsoluteCol MetricFile
| RelativeCol MetricFile
| StderrCol MetricFile
deriving (Show)
showColumn :: Column -> ShowS
showColumn (AbsoluteCol mf) = showString $ metricFileFriendlyName mf
showColumn (RelativeCol mf) = showString (metricFileFriendlyName mf) . showString " (rel)"
showColumn (StderrCol mf) = showString "std. err." --showString (metricFileFriendlyName mf) . showString " (\\sigma)"
data Cell = CellPctChange (ValueBaseline Double)
| CellMissing
| CellAbsolute Double
| CellStderrRel (MeanStddev Double)
deriving (Show)
showCell :: OutputOptions -> Cell -> ShowS
showCell opts (CellPctChange vb) = showString $ showPercent opts vb
showCell opts CellMissing = showChar '∙'
showCell opts (CellAbsolute x) = showGFloatAbsolute opts (Just 3) x
showCell opts (CellStderrRel ms) = showGFloat (Just 1) (msStddev ms / msMean ms * 100) . showChar '%'
baseTable :: M.Map rh (M.Map MetricFile (MeanStddev Double))
-> Table rh Column Cell
baseTable mtrees =
Table (Group NoLine $ map Header rowLbls) (Group NoLine []) ([] <$ rowLbls)
where rowLbls = M.keys mtrees
absoluteCol :: M.Map lbl (M.Map MetricFile (MeanStddev Double))
-> MetricFile
-> SemiTable Column Cell
absoluteCol mtrees metricFile =
col (AbsoluteCol metricFile)
[ maybe CellMissing (CellAbsolute . msMean) $ M.lookup metricFile xs
| (_metric, xs) <- M.toList mtrees
]
relativeCol :: M.Map lbl (M.Map MetricFile (MeanStddev Double))
-> MetricFile -- ^ reference
-> MetricFile
-> SemiTable Column Cell
relativeCol mtrees refFile metricFile =
col (RelativeCol metricFile)
[ fromMaybe CellMissing $ do
baseline <- msMean <$> M.lookup refFile xs
value <- msMean <$> M.lookup metricFile xs
return $ CellPctChange $ ValueBaseline baseline value
| (metric, xs) <- M.toList mtrees
]
stderrCol :: M.Map lbl (M.Map MetricFile (MeanStddev Double))
-> MetricFile
-> SemiTable Column Cell
stderrCol mtrees metricFile =
col (StderrCol metricFile)
[ maybe CellMissing CellStderrRel $ M.lookup metricFile xs
| (_metric, xs) <- M.toList mtrees
]
data ValueBaseline a = ValueBaseline { baseline, value :: a }
deriving (Show)
showBoth :: (RealFloat a, Show a) => ValueBaseline a -> String
showBoth (ValueBaseline ref val) = show (ref, val)
newtype PctChange a = PctChange a
deriving (Show)
newtype RelChange a = RelChange a
deriving (Show, Eq, Ord, RealFloat, RealFrac, Floating, Real, Num, Fractional)
showsPctChange :: (Ord a, RealFloat a) => OutputOptions -> PctChange a -> ShowS
showsPctChange opts (PctChange percent) =
showsRelChange :: (Ord a, RealFloat a) => OutputOptions -> RelChange a -> ShowS
showsRelChange opts (RelChange percent) =
withColor opts color $ prettySign opts rel . showFFloat (Just 2) (abs rel) . showChar '%'
where
rel = percent - 100
@@ -383,41 +429,8 @@ showsPctChange opts (PctChange percent) =
| rel > 0 = Red
| otherwise = White
toPctChange :: RealFloat a => ValueBaseline a -> PctChange a
toPctChange (ValueBaseline ref val) = PctChange ((val / ref) * 100)
showPercent :: (RealFloat a, Show a) => OutputOptions -> ValueBaseline a -> String
showPercent opts x = showsPctChange opts (toPctChange x) ""
data Relative a = Reference a
| Relative (ValueBaseline a)
| NoReference
showRelative :: (Ord a, RealFloat a, Show a)
=> (a -> ShowS) -> (ValueBaseline a -> String) -> Relative a -> String
showRelative showRef _showRel (Reference n) = showRef n ""
showRelative _showRef showRel (Relative vb) = showRel vb
showRelative _showRef _showRel NoReference = "no ref"
toRelativeChange :: (Ord r, Ord c, RealFrac a)
=> c
-> M.Map r (M.Map c a)
-> M.Map r (M.Map c (Relative a))
toRelativeChange ref xs = fmap f xs
where
f ys
| Just y0 <- M.lookup ref ys =
M.mapWithKey (\k y -> if k == ref then Reference y0 else Relative (ValueBaseline y0 y)) ys
| otherwise = fmap (const NoReference) ys
transpose :: (Ord r, Ord c)
=> M.Map r (M.Map c a)
-> M.Map c (M.Map r a)
transpose xs = M.fromListWith (<>)
[ (c, M.singleton r x)
| (r, cs) <- M.toList xs
, (c, x) <- M.toList cs
]
toRelChange :: RealFloat a => ValueBaseline a -> RelChange a
toRelChange (ValueBaseline ref val) = RelChange ((val / ref) * 100)
mean :: (Functor f, Foldable f, RealFloat a)
=> f a -> Maybe a
@@ -432,7 +445,7 @@ meanStddev :: (Functor f, Foldable f, RealFloat a)
=> f a -> Maybe (MeanStddev a)
meanStddev xs = do
mu <- mean xs
sigma <- fmap sqrt $ mean $ fmap (\x -> (x-mu)^2) xs
sigma <- fmap sqrt $ mean $ fmap (\x -> (x-mu)^(2::Int)) xs
return $ MeanStddev mu sigma
meanStdErr :: (Functor f, Foldable f, RealFloat a)
@@ -440,22 +453,11 @@ meanStdErr :: (Functor f, Foldable f, RealFloat a)
meanStdErr xs = do
ms <- meanStddev xs
return ms { msStddev = msStddev ms / sqrt n }
where n = realToFrac $ length xs
where
n = realToFrac $ length xs
geomMean :: (Functor f, Foldable f, RealFloat a)
=> f a -> Maybe a
geomMean = fmap exp . mean . fmap log'
where log' = log . max 0.05
geomMeanRow :: (Ord r, Ord c, RealFloat a)
=> M.Map r (M.Map c (Relative a))
-> SemiTable String (Maybe (PctChange a))
geomMeanRow xs =
row "geom mean" (M.elems $ fmap (fmap (PctChange . (*100)) . geomMean . mapMaybe ratios . M.elems) $ transpose xs)
where
ratios :: Fractional a => Relative a -> Maybe a
ratios (Relative (ValueBaseline ref val)) = Just (val / ref)
ratios _ = Nothing
runShowS :: ShowS -> String
runShowS = ($ [])