diff --git a/LICENSE b/LICENSE new file mode 100644 --- /dev/null +++ b/LICENSE @@ -0,0 +1,30 @@ +Copyright (c) 2016-2020, Ben Gamari, 2020 Oleg Grenrus + +All rights reserved. + +Redistribution and use in source and binary forms, with or without +modification, are permitted provided that the following conditions are met: + + * Redistributions of source code must retain the above copyright + notice, this list of conditions and the following disclaimer. + + * Redistributions in binary form must reproduce the above + copyright notice, this list of conditions and the following + disclaimer in the documentation and/or other materials provided + with the distribution. + + * Neither the name of Ben Gamari nor the names of other + contributors may be used to endorse or promote products derived + from this software without specific prior written permission. + +THIS SOFTWARE IS PROVIDED BY THE COPYRIGHT HOLDERS AND CONTRIBUTORS +"AS IS" AND ANY EXPRESS OR IMPLIED WARRANTIES, INCLUDING, BUT NOT +LIMITED TO, THE IMPLIED WARRANTIES OF MERCHANTABILITY AND FITNESS FOR +A PARTICULAR PURPOSE ARE DISCLAIMED. IN NO EVENT SHALL THE COPYRIGHT +OWNER OR CONTRIBUTORS BE LIABLE FOR ANY DIRECT, INDIRECT, INCIDENTAL, +SPECIAL, EXEMPLARY, OR CONSEQUENTIAL DAMAGES (INCLUDING, BUT NOT +LIMITED TO, PROCUREMENT OF SUBSTITUTE GOODS OR SERVICES; LOSS OF USE, +DATA, OR PROFITS; OR BUSINESS INTERRUPTION) HOWEVER CAUSED AND ON ANY +THEORY OF LIABILITY, WHETHER IN CONTRACT, STRICT LIABILITY, OR TORT +(INCLUDING NEGLIGENCE OR OTHERWISE) ARISING IN ANY WAY OUT OF THE USE +OF THIS SOFTWARE, EVEN IF ADVISED OF THE POSSIBILITY OF SUCH DAMAGE. diff --git a/criterion-cmp.cabal b/criterion-cmp.cabal new file mode 100644 --- /dev/null +++ b/criterion-cmp.cabal @@ -0,0 +1,56 @@ +cabal-version: 2.2 +name: criterion-cmp +version: 0.1.0.0 +synopsis: A simple tool for comparing in Criterion benchmark results +description: + Output a table containing a comparison of results for the input files + Based on https://github.com/bgamari/criterion-compare + +license: BSD-3-Clause +license-file: LICENSE +author: + Oleg Grenrus , Ben Gamari + +maintainer: Oleg Grenrus +copyright: (c) 2020-2021 Oleg Grenrus, 2016-2020 Ben Gamari +category: Development +build-type: Simple +tested-with: + GHC ==8.4.4 || ==8.6.5 || ==8.8.3 || ==8.10.1 + +source-repository head + type: git + location: https://github.com/phadej/criterion-cmp.git + +executable criterion-cmp + default-language: Haskell2010 + hs-source-dirs: src + main-is: CriterionCompare.hs + ghc-options: -Wall + other-modules: + CsvParse + Table + Types + + other-extensions: + DeriveFunctor + DeriveFoldable + FlexibleContexts + GeneralizedNewtypeDeriving + OverloadedStrings + RecordWildCards + + -- ghc boot libs + build-depends: + , base >=4.11 && <4.15 + , bytestring ^>=0.10.4.0 + , containers ^>=0.5.5.1 || ^>=0.6.0.1 + , filepath ^>=1.4 + + -- other-deps + build-depends: + , ansi-terminal ^>=0.11 + , boxes ^>=0.1.5 + , cassava ^>=0.5 + , optparse-applicative ^>=0.16.1.0 + , vector ^>=0.12.2.0 diff --git a/src/CriterionCompare.hs b/src/CriterionCompare.hs new file mode 100644 --- /dev/null +++ b/src/CriterionCompare.hs @@ -0,0 +1,119 @@ +{-# LANGUAGE FlexibleContexts #-} +{-# LANGUAGE OverloadedStrings #-} +{-# LANGUAGE RankNTypes #-} +{-# LANGUAGE RecordWildCards #-} + +import Control.Applicative (many) +import Data.Bifunctor (first) +import Data.Foldable (foldl') +import Data.Map (Map) +import Data.Traversable (for) +import System.FilePath (dropExtension, takeFileName) + +import qualified Data.Map.Strict as Map +import qualified Options.Applicative as O +import qualified Text.PrettyPrint.Boxes as B + +import CsvParse +import Table +import Types + +------------------------------------------------------------------------------- +-- Options +------------------------------------------------------------------------------- + +data Options = Options + { optRunNames :: [RunName] + , optOutput :: FilePath + , optRunPaths :: [FilePath] + } + +options :: O.Parser Options +options = Options + <$> many (O.strOption $ O.short 'l' <> O.long "label" <> O.help "label") + <*> O.strOption (O.short 'o' <> O.long "output" <> O.metavar "FILE" <> O.help "output file name" <> O.value "-") + <*> many (O.strArgument $ O.metavar "FILE" <> O.help "CSV file name") + +------------------------------------------------------------------------------- +-- Utilities +------------------------------------------------------------------------------- + +flipFiniteMap :: (Ord a, Ord b) => Map a (Map b v) -> Map b (Map a v) +flipFiniteMap abv = Map.unionsWith Map.union + [ Map.singleton b $ Map.singleton a v + | (a, bv) <- Map.toList abv + , (b, v) <- Map.toList bv + ] + +------------------------------------------------------------------------------- +-- Geometric mean +------------------------------------------------------------------------------- + +gmean :: Traversable f => f Stats -> Double +gmean = post . foldl' f (A 1.0 0 0) . fmap statsMean where + f (A acc es n) d = A c (es + e) (n + 1) where + (c, e) = split (acc * d) + + split :: Double -> (Double, Int) + split d = (d / 2 ^^ e, e) where e = exponent d + + post :: A -> Double + post (A acc es n) = acc ** (1 / fromIntegral n) + * 2 ** (fromIntegral es / fromIntegral n) + +-- | @A x e n@ is @n@ elements which product is @x * 2 ^^ e@ +data A = A !Double !Int !Int + +------------------------------------------------------------------------------- +-- Main +------------------------------------------------------------------------------- + +main :: IO () +main = do + Options{..} <- O.execParser $ O.info (O.helper <*> options) mempty + + let runs :: [(RunName, FilePath)] + runs = zipWith f (map Just optRunNames ++ repeat Nothing) optRunPaths + where + f (Just n) fp = (n, fp) + f Nothing fp = (RunName $ dropExtension $ takeFileName fp, fp) + + let names' :: [RunName] + names' = map fst runs + + case names' of + [] -> return () -- nothing to do + fname : names -> do + results0 <- fmap Map.fromList $ for runs $ \(name, fp) -> + (,) name . Map.fromList . map (first RowBenchName) <$> readResults fp + + let results1 :: Map RunName (Map RowName Stats) + results1 = fmap addGMean results0 where + -- zzz will make the line appear last. + addGMean m = Map.insert RowMean (Stats (gmean m) 0 0 0 0 0) m + + let results :: Map RowName (Map RunName Stats) + results = flipFiniteMap results1 + + let header :: Row V1 B.Box + header = makeHeader fname names + + let table :: [Row V2 B.Box] + table = makeTable fname names results + + let table1 :: Row V2 [B.Box] + table1 = sequenceA table + + let table2 :: Row V2 B.Box + table2 = case table1 of + Row f n xs -> Row + (B.vcat B.left f) + (B.vcat B.right n) + (fmap (fmap (B.vcat B.right)) xs) + + let table3 :: Row V1 B.Box + table3 = hoistRow (\(V2 x y) -> V1 (x B.<+> y)) table2 + + let table4 = pure (B.//) <*> header <*> table3 + + B.printBox $ B.hsep 2 B.left table4 diff --git a/src/CsvParse.hs b/src/CsvParse.hs new file mode 100644 --- /dev/null +++ b/src/CsvParse.hs @@ -0,0 +1,37 @@ +{-# LANGUAGE FlexibleContexts #-} +{-# LANGUAGE OverloadedStrings #-} + +module CsvParse (readResults) where + +import qualified Data.ByteString.Lazy as BSL +import qualified Data.Csv as Csv +import qualified Data.Vector as V + +import Types + +data BenchResult = BenchResult + { _benchName :: BenchName + , _benchStats :: Stats + } + +instance Csv.FromNamedRecord BenchResult where + parseNamedRecord m = bench + <$> m Csv..: "Name" + <*> m Csv..: "Mean" + <*> m Csv..: "MeanLB" + <*> m Csv..: "MeanUB" + <*> m Csv..: "Stddev" + <*> m Csv..: "StddevLB" + <*> m Csv..: "StddevUB" + where + bench a b c d e f g = BenchResult a (Stats b c d e f g) + +readResults :: FilePath -> IO [(BenchName, Stats)] +readResults fname = do + mxs <- parseResults <$> BSL.readFile fname + case mxs of + Left err -> fail err + Right xs -> return $ map (\(BenchResult a b) -> (a, b)) $ V.toList xs + +parseResults :: BSL.ByteString -> Either String (V.Vector BenchResult) +parseResults = fmap snd . Csv.decodeByName diff --git a/src/Table.hs b/src/Table.hs new file mode 100644 --- /dev/null +++ b/src/Table.hs @@ -0,0 +1,115 @@ +{-# LANGUAGE DeriveFunctor #-} +{-# LANGUAGE DeriveFoldable #-} +{-# LANGUAGE RankNTypes #-} +module Table where + +import Control.Monad (ap) +import Data.Foldable (for_) +import Data.Map (Map) +import Numeric (showFFloat) + +import qualified Text.PrettyPrint.Boxes as B +import qualified Data.Map.Strict as Map + +import Types + +-- | Row of things. +-- +-- Name, first column, and then pair of columns +data Row f a = Row a a [f a] + deriving (Show, Functor, Foldable) + +hoistRow :: (f a -> g a) -> Row f a -> Row g a +hoistRow f (Row x y zs) = Row x y (map f zs) + +instance Applicative f => Applicative (Row f) where + pure x = Row x x (repeat (pure x)) + + Row f1 f2 fs <*> Row x1 x2 xs = + Row (f1 x1) (f2 x2) (zipWith (<*>) fs xs) + +newtype V1 a = V1 a + deriving (Show, Functor, Foldable) + +instance Applicative V1 where + pure x = V1 x + V1 f1 <*> V1 x1 = V1 (f1 x1) + +data V2 a = V2 a a + deriving (Show, Functor, Foldable) + +instance Applicative V2 where + pure x = V2 x x + V2 f1 f2 <*> V2 x1 x2 = V2 (f1 x1) (f2 x2) + +makeHeader + :: RunName -- ^ first run + -> [RunName] -- ^ other runs + -> Row V1 B.Box +makeHeader fname names = + fmap B.text $ Row "Benchmark" (getRunName fname) (map (V1 . getRunName) names) + +makeTable + :: RunName -- ^ first run + -> [RunName] -- ^ other runs + -> Map RowName (Map RunName Stats) + -> [Row V2 B.Box] +makeTable fname names results = map (fmap B.text) $ buildList $ do + -- rows + for_ (Map.toList results) $ \(rn, mp) -> + for_ (Map.lookup fname mp) $ \fstats -> do + let fmean :: Double + fmean = statsMean fstats + + precision :: Int + precision = round $ logBase 10 fmean + + -- rest benchmarks + rest :: [V2 String] + rest = buildList $ do + for_ names $ \name -> case Map.lookup name mp of + Nothing -> do + item (V2 "" "") + Just stats -> do + let mean = statsMean stats + item $ V2 (showD precision mean) (showP fmean mean) + + -- name, first, rest + item $ Row (getRowName rn) (showD precision fmean) rest + where + showD :: Int -> Double -> String + showD p d = showFFloat (Just 3) (mul * d) . showChar 'e' . shows p $ "" + where mul = 10 ^ negate p + + showP :: Double -> Double -> String + showP orig curr + | curr > orig = '+' : showFFloat (Just 2) (100 * (curr - orig) / orig) "%" + | otherwise = '-' : showFFloat (Just 2) (100 * (orig - curr) / orig) "%" + +------------------------------------------------------------------------------- +-- List Builder +------------------------------------------------------------------------------- + +newtype ListBuilder x a = LB { unLB :: forall r. (([x] -> [x]) -> a -> r) -> r } + +instance Functor (ListBuilder x) where + fmap f (LB k) = LB $ k $ \endo a k' -> k' endo (f a) + +instance Applicative (ListBuilder x) where + pure x = LB $ \f -> f id x + (<*>) = ap + +instance Monad (ListBuilder x) where + return = pure + + m >>= k = + LB $ \r -> + unLB m $ \endo1 a -> + unLB (k a) $ \endo2 b -> + r (endo1 . endo2) b + +buildList :: ListBuilder x () -> [x] +buildList (LB f) = f $ \endo _ -> endo [] + +item :: x -> ListBuilder x () +item x = LB $ \f -> f (x :) () diff --git a/src/Types.hs b/src/Types.hs new file mode 100644 --- /dev/null +++ b/src/Types.hs @@ -0,0 +1,31 @@ +{-# LANGUAGE GeneralizedNewtypeDeriving #-} +module Types where + +import Data.Csv +import Data.String (IsString (..)) + +-- | The name of a set of benchmark results from a single run. +newtype RunName = RunName { getRunName :: String } + deriving (Eq, Ord, Show, FromField) + +instance IsString RunName where + fromString = RunName + +-- | The name of a benchmark +newtype BenchName = BenchName { getBenchName :: String } + deriving (Eq, Ord, Show, FromField) + +data RowName + = RowBenchName BenchName + | RowMean + deriving (Eq, Ord, Show) + +getRowName :: RowName -> String +getRowName (RowBenchName bn) = getBenchName bn +getRowName RowMean = "Geometric mean" + +data Stats = Stats + { statsMean, statsMeanLB, statsMeanUB :: Double + , statsStd, statsStdLB, statsStdUB :: Double + } + deriving (Show)