diff --git a/shake-bench.cabal b/shake-bench.cabal --- a/shake-bench.cabal +++ b/shake-bench.cabal @@ -1,6 +1,6 @@ cabal-version: 2.2 name: shake-bench -version: 0.2.0.0 +version: 0.3.0.0 synopsis: Build rules for historical benchmarking license: Apache-2.0 license-file: LICENSE @@ -22,12 +22,6 @@ aeson, base == 4.*, bytestring, - Chart, - Chart-diagrams, - diagrams-contrib, - diagrams-core, - diagrams-lib, - diagrams-svg, directory, extra >= 1.7.2, filepath, @@ -36,18 +30,8 @@ mtl, shake, text - default-language: Haskell2010 + default-language: GHC2021 default-extensions: - BangPatterns - DeriveFunctor - DeriveGeneric - FlexibleContexts - GeneralizedNewtypeDeriving LambdaCase - NamedFieldPuns RecordWildCards - ScopedTypeVariables - StandaloneDeriving - TupleSections - TypeApplications ViewPatterns diff --git a/src/Development/Benchmark/Rules.hs b/src/Development/Benchmark/Rules.hs --- a/src/Development/Benchmark/Rules.hs +++ b/src/Development/Benchmark/Rules.hs @@ -1,13 +1,10 @@ -{-# LANGUAGE AllowAmbiguousTypes #-} -{-# LANGUAGE ApplicativeDo #-} -{-# LANGUAGE ConstraintKinds #-} -{-# LANGUAGE DeriveAnyClass #-} -{-# LANGUAGE DerivingStrategies #-} -{-# LANGUAGE DuplicateRecordFields #-} -{-# LANGUAGE ExistentialQuantification #-} -{-# LANGUAGE OverloadedStrings #-} -{-# LANGUAGE RankNTypes #-} -{-# LANGUAGE TypeFamilies #-} +{-# LANGUAGE AllowAmbiguousTypes #-} +{-# LANGUAGE ApplicativeDo #-} +{-# LANGUAGE DeriveAnyClass #-} +{-# LANGUAGE DerivingStrategies #-} +{-# LANGUAGE DuplicateRecordFields #-} +{-# LANGUAGE OverloadedStrings #-} +{-# LANGUAGE TypeFamilies #-} {- | This module provides a bunch of Shake rules to build multiple revisions of a @@ -30,20 +27,17 @@ │  └── commitid - Git commit id for this reference ├─ │ ├── results.csv - aggregated results for all the versions and configurations - │ ├── .svg - graph of bytes over elapsed time, for all the versions and configurations | └── │ └── │   ├── .gcStats.log - RTS -s output │   ├── .csv - stats for the experiment - │   ├── .svg - Graph of bytes over elapsed time - │   ├── .diff.svg - idem, including the previous version - │   ├── .heap.svg - Heap profile + │   ├── .hp - raw heap profile data │   ├── .log - bench stdout │   └── results.csv - results of all the experiments for the example ├── results.csv - aggregated results of all the examples, experiments, versions and configurations - └── .svg - graph of bytes over elapsed time, for all the examples, experiments, versions and configurations + └── resultDiff.csv - diff of aggregated results compared with previous version - For diff graphs, the "previous version" is the preceding entry in the list of versions + For diff results, the "previous version" is the preceding entry in the list of versions in the config file. A possible improvement is to obtain this info via `git rev-list`. -} {-# OPTIONS_GHC -Wno-incomplete-uni-patterns #-} @@ -51,9 +45,8 @@ ( buildRules, MkBuildRules(..), OutputFolder, ProjectRoot, benchRules, MkBenchRules(..), BenchProject(..), ProfilingMode(..), + addGetParentOracle, csvRules, - svgRules, - heapProfileRules, phonyRules, allTargetsForExample, GetExample(..), GetExamples(..), @@ -70,45 +63,32 @@ ) where import Control.Applicative -import Control.Lens (preview, view, (^.)) +import Control.Lens (preview, (^.)) import Control.Monad -import qualified Control.Monad.State as S -import Data.Aeson (FromJSON (..), - ToJSON (..), - Value (..), object, - (.!=), (.:?), (.=)) -import Data.Aeson.Lens (AsJSON (_JSON), - _Object, _String) -import Data.ByteString.Lazy (ByteString) -import Data.Char (isDigit) -import Data.List (find, isInfixOf, - stripPrefix, - transpose) -import Data.List.Extra (lower) -import Data.Maybe (fromMaybe) -import Data.String (fromString) -import Data.Text (Text) -import qualified Data.Text as T +import Data.Aeson (FromJSON (..), ToJSON (..), + Value (..), object, (.!=), (.:?), + (.=)) +import Data.Aeson.Lens (AsJSON (_JSON), _Object, _String) +import Data.ByteString.Lazy (ByteString) +import Data.Char (isDigit) +import Data.List (find, intercalate, isInfixOf, + isSuffixOf, stripPrefix, transpose) +import Data.List.Extra (lower, splitOn) +import Data.Maybe (fromMaybe) +import Data.String (fromString) +import Data.Text (Text) +import qualified Data.Text as T import Development.Shake -import Development.Shake.Classes (Binary, Hashable, - NFData, Typeable) -import GHC.Exts (IsList (toList), - fromList) -import GHC.Generics (Generic) -import GHC.Stack (HasCallStack) -import qualified Graphics.Rendering.Chart.Backend.Diagrams as E -import qualified Graphics.Rendering.Chart.Easy as E +import Development.Shake.Classes (Binary, Hashable, NFData, Typeable) +import GHC.Exts (IsList (toList), fromList) +import GHC.Generics (Generic) import Numeric.Natural -import System.Directory (createDirectoryIfMissing, - findExecutable, - renameFile) +import System.Directory (createDirectoryIfMissing, + findExecutable) import System.FilePath -import System.Time.Extra (Seconds) -import qualified Text.ParserCombinators.ReadP as P +import System.Time.Extra (Seconds) import Text.Printf -import Text.Read (Read (..), get, - readMaybe, - readP_to_Prec) +import Text.Read (readMaybe) newtype GetExperiments = GetExperiments () deriving newtype (Binary, Eq, Hashable, NFData, Show) newtype GetVersions = GetVersions () deriving newtype (Binary, Eq, Hashable, NFData, Show) @@ -131,7 +111,7 @@ , IsExample e) data Configuration = Configuration {confName :: String, confValue :: ByteString} - deriving (Binary, Eq, Generic, Hashable, NFData, Show, Typeable) + deriving (Binary, Eq, Generic, Hashable, NFData, Show) type instance RuleResult GetConfigurations = [Configuration] -- | Knowledge needed to run an example @@ -142,26 +122,11 @@ allTargetsForExample :: IsExample e => ProfilingMode -> FilePath -> e -> Action [FilePath] allTargetsForExample prof baseFolder ex = do - experiments <- askOracle $ GetExperiments () - versions <- askOracle $ GetVersions () - configurations <- askOracle $ GetConfigurations () let buildFolder = baseFolder profilingPath prof return $ - [buildFolder getExampleName ex "results.csv"] - ++ [ buildFolder getExampleName ex escaped (escapeExperiment e) <.> "svg" - | e <- experiments - ] - ++ [ buildFolder - getExampleName ex - T.unpack (humanName ver) - confName - escaped (escapeExperiment e) <.> - mode - | e <- experiments, - ver <- versions, - Configuration{confName} <- configurations, - mode <- ["svg", "diff.svg"] ++ ["heap.svg" | prof /= NoProfiling] - ] + [ + buildFolder getExampleName ex "results.csv" + , buildFolder getExampleName ex "resultDiff.csv"] allBinaries :: FilePath -> String -> Action [FilePath] allBinaries buildFolder executableName = do @@ -190,6 +155,8 @@ allTargetsForExample prof buildFolder ex need $ (buildFolder profilingPath prof "results.csv") : concat exampleTargets + need $ (buildFolder profilingPath prof "resultDiff.csv") + : concat exampleTargets phony (prefix <> "all-binaries") $ need =<< allBinaries buildFolder executableName -------------------------------------------------------------------------------- type OutputFolder = FilePath @@ -336,7 +303,7 @@ ++ concat [[ "-h" , "-i" <> show i - , "-po" <> outHp + , "-po" <> dropExtension outHp , "-qg"] | CheapHeapProfiling i <- [prof]] ++ ["-RTS"] @@ -387,134 +354,106 @@ -------------------------------------------------------------------------------- - +-- | oracles to get previous version of a given version +-- used for diff the results +addGetParentOracle :: Rules () +addGetParentOracle = void $ addOracle $ \(GetParent name) -> findPrev name <$> askOracle (GetVersions ()) -- | Rules to aggregate the CSV output of individual experiments csvRules :: forall example . RuleResultForExample example => FilePattern -> Rules () csvRules build = do + let genConfig resultName prefixName prefixOracles out = do + configurations <- prefixOracles + let allResultFiles = [takeDirectory out c resultName | c <- configurations ] + allResults <- traverse readFileLines allResultFiles + let header = head $ head allResults + results = map tail allResults + header' = prefixName <> ", " <> header + results' = zipWith (\v -> map (\l -> v <> ", " <> l)) configurations results + writeFileChanged out $ unlines $ header' : interleave results' -- build results for every experiment*example - build -/- "*/*/*/*/results.csv" %> \out -> do + priority 1 $ build -/- "*/*/*/*/results.csv" %> \out -> do experiments <- askOracle $ GetExperiments () - let allResultFiles = [takeDirectory out escaped (escapeExperiment e) <.> "csv" | e <- experiments] allResults <- traverse readFileLines allResultFiles - let header = head $ head allResults results = map tail allResults writeFileChanged out $ unlines $ header : concat results - + priority 2 $ build -/- "*/*/*/*/resultDiff.csv" %> \out -> do + let [b, flav, example, ver, conf, _exp] = splitDirectories out + prev <- fmap T.unpack $ askOracle $ GetParent $ T.pack ver + allResultsCur <- readFileLines $ joinPath [b ,flav, example, ver, conf] "results.csv" + resultDiff <- + if prev == ver + then pure [] + else do + allResultsPrev <- readFileLines $ joinPath [b ,flav, example, prev, conf] "results.csv" + let resultsPrev = tail allResultsPrev + let resultsCur = tail allResultsCur + pure $ zipWith convertToDiffResults resultsCur resultsPrev + writeFileChanged out $ unlines $ head allResultsCur : resultDiff -- aggregate all configurations for an experiment - build -/- "*/*/*/results.csv" %> \out -> do - configurations <- map confName <$> askOracle (GetConfigurations ()) - let allResultFiles = [takeDirectory out c "results.csv" | c <- configurations ] - - allResults <- traverse readFileLines allResultFiles - - let header = head $ head allResults - results = map tail allResults - header' = "configuration, " <> header - results' = zipWith (\v -> map (\l -> v <> ", " <> l)) configurations results - - writeFileChanged out $ unlines $ header' : interleave results' - + priority 3 $ build -/- "*/*/*/results.csv" %> genConfig "results.csv" + "Configuration" (map confName <$> askOracle (GetConfigurations ())) + priority 3 $ build -/- "*/*/*/resultDiff.csv" %> genConfig "resultDiff.csv" + "Configuration" (map confName <$> askOracle (GetConfigurations ())) -- aggregate all experiments for an example - build -/- "*/*/results.csv" %> \out -> do - versions <- map (T.unpack . humanName) <$> askOracle (GetVersions ()) - let allResultFiles = [takeDirectory out v "results.csv" | v <- versions] - - allResults <- traverse readFileLines allResultFiles - - let header = head $ head allResults - results = map tail allResults - header' = "version, " <> header - results' = zipWith (\v -> map (\l -> v <> ", " <> l)) versions results - - writeFileChanged out $ unlines $ header' : interleave results' - + priority 4 $ build -/- "*/*/results.csv" %> genConfig "results.csv" + "Version" (map (T.unpack . humanName) <$> askOracle (GetVersions ())) + priority 4 $ build -/- "*/*/resultDiff.csv" %> genConfig "resultDiff.csv" + "Version" (map (T.unpack . humanName) <$> askOracle (GetVersions ())) -- aggregate all examples - build -/- "*/results.csv" %> \out -> do - examples <- map (getExampleName @example) <$> askOracle (GetExamples ()) - let allResultFiles = [takeDirectory out e "results.csv" | e <- examples] - - allResults <- traverse readFileLines allResultFiles - - let header = head $ head allResults - results = map tail allResults - header' = "example, " <> header - results' = zipWith (\e -> map (\l -> e <> ", " <> l)) examples results - - writeFileChanged out $ unlines $ header' : concat results' - --------------------------------------------------------------------------------- - --- | Rules to produce charts for the GC stats -svgRules :: FilePattern -> Rules () -svgRules build = do - void $ addOracle $ \(GetParent name) -> findPrev name <$> askOracle (GetVersions ()) - -- chart GC stats for an experiment on a given revision - priority 1 $ - build -/- "*/*/*/*/*.svg" %> \out -> do - let [_, _, _example, ver, conf, _exp] = splitDirectories out - runLog <- loadRunLog (Escaped $ replaceExtension out "csv") ver conf - let diagram = Diagram Live [runLog] title - title = ver <> " live bytes over time" - plotDiagram True diagram out - - -- chart of GC stats for an experiment on this and the previous revision - priority 2 $ - build -/- "*/*/*/*/*.diff.svg" %> \out -> do - let [b, flav, example, ver, conf, exp_] = splitDirectories out - exp = Escaped $ dropExtension2 exp_ - prev <- fmap T.unpack $ askOracle $ GetParent $ T.pack ver - - runLog <- loadRunLog (Escaped $ replaceExtension (dropExtension out) "csv") ver conf - runLogPrev <- loadRunLog (Escaped $ joinPath [b,flav, example, prev, conf, replaceExtension (dropExtension exp_) "csv"]) prev conf - - let diagram = Diagram Live [runLog, runLogPrev] title - title = show (unescapeExperiment exp) <> " - live bytes over time compared" - plotDiagram True diagram out + priority 5 $ build -/- "*/results.csv" %> genConfig "results.csv" + "Example" (map getExampleName <$> askOracle (GetExamples ())) + priority 5 $ build -/- "*/resultDiff.csv" %> genConfig "resultDiff.csv" + "Example" (map getExampleName <$> askOracle (GetExamples ())) - -- aggregated chart of GC stats for all the configurations - build -/- "*/*/*/*.svg" %> \out -> do - let exp = Escaped $ dropExtension $ takeFileName out - [b, flav, example, ver] = splitDirectories out - versions <- askOracle $ GetVersions () - configurations <- askOracle $ GetConfigurations () +convertToDiffResults :: String -> String -> String +convertToDiffResults line baseLine = intercalate "," diffResults + where items = parseLine line + baseItems = parseLine baseLine + diffItems = zipWith diffItem items baseItems + diffResults = map showItemDiffResult diffItems - runLogs <- forM configurations $ \Configuration{confName} -> do - loadRunLog (Escaped $ takeDirectory out confName replaceExtension (takeFileName out) "csv") ver confName +showItemDiffResult :: (Item, Maybe Double) -> String +showItemDiffResult (ItemString x, _) = x +showItemDiffResult (_, Nothing) = "NA" +showItemDiffResult (Mem _, Just y) = showPercentageDiff y +showItemDiffResult (Time _, Just y) = showPercentageDiff y - let diagram = Diagram Live runLogs title - title = show (unescapeExperiment exp) <> " - live bytes over time" - plotDiagram False diagram out +showPercentageDiff :: Double -> String +showPercentageDiff ratio + | not (isFinite percent) = "NA" + | otherwise = printf "%.2f" percent <> "%" + where + percent = ratio * 100 - 100 - -- aggregated chart of GC stats for all the revisions - build -/- "*/*/*.svg" %> \out -> do - let exp = Escaped $ dropExtension $ takeFileName out - versions <- askOracle $ GetVersions () - configurations <- askOracle $ GetConfigurations () +isFinite :: Double -> Bool +isFinite x = not (isNaN x || isInfinite x) - runLogs <- forM (filter include versions) $ \v -> - forM configurations $ \Configuration{confName} -> do - let v' = T.unpack (humanName v) - loadRunLog (Escaped $ takeDirectory out v' confName replaceExtension (takeFileName out) "csv") v' confName +diffItem :: Item -> Item -> (Item, Maybe Double) +diffItem (Mem x) (Mem y) = (Mem x, ratioMaybe (fromIntegral x) (fromIntegral y)) +diffItem (Time x) (Time y) = (Time x, ratioMaybe x y) +diffItem (ItemString x) (ItemString y) = (ItemString x, Nothing) +diffItem _ _ = (ItemString "no match", Nothing) - let diagram = Diagram Live (concat runLogs) title - title = show (unescapeExperiment exp) <> " - live bytes over time" - plotDiagram False diagram out +ratioMaybe :: Double -> Double -> Maybe Double +ratioMaybe x y + | y == 0 = Nothing + | not (isFinite x && isFinite y) = Nothing + | otherwise = Just $ x / y -heapProfileRules :: FilePattern -> Rules () -heapProfileRules build = do - priority 3 $ - build -/- "*/*/*/*/*.heap.svg" %> \out -> do - let hpFile = dropExtension2 out <.> "hp" - need [hpFile] - cmd_ ("hp2pretty" :: String) [hpFile] - liftIO $ renameFile (dropExtension hpFile <.> "svg") out +data Item = Mem Int | Time Double | ItemString String + deriving (Show) -dropExtension2 :: FilePath -> FilePath -dropExtension2 = dropExtension . dropExtension --------------------------------------------------------------------------------- --------------------------------------------------------------------------------- +parseLine :: String -> [Item] +parseLine = map f . splitOn "," + where + f x + | "MB" `isSuffixOf` x = Mem $ read $ reverse $ drop 2 $ reverse x + | otherwise = + case readMaybe @Double x of + Just time -> Time time + Nothing -> ItemString x -- | Default build system that handles Cabal and Stack data BuildSystem = Cabal | Stack @@ -584,119 +523,6 @@ | otherwise = findPrev name (y : xx) findPrev name _ = name --------------------------------------------------------------------------------- - --- | A line in the output of -S -data Frame = Frame - { allocated, copied, live :: !Int, - user, elapsed, totUser, totElapsed :: !Double, - generation :: !Int - } - deriving (Show) - -instance Read Frame where - readPrec = do - spaces - allocated <- readPrec @Int <* spaces - copied <- readPrec @Int <* spaces - live <- readPrec @Int <* spaces - user <- readPrec @Double <* spaces - elapsed <- readPrec @Double <* spaces - totUser <- readPrec @Double <* spaces - totElapsed <- readPrec @Double <* spaces - _ <- readPrec @Int <* spaces - _ <- readPrec @Int <* spaces - "(Gen: " <- replicateM 7 get - generation <- readPrec @Int - ')' <- get - return Frame {..} - where - spaces = readP_to_Prec $ const P.skipSpaces - --- | A file path containing the output of -S for a given run -data RunLog = RunLog - { runVersion :: !String, - runConfiguration :: !String, - runFrames :: ![Frame], - runSuccess :: !Bool, - runFirstReponse :: !(Maybe Seconds) - } - -loadRunLog :: HasCallStack => Escaped FilePath -> String -> String -> Action RunLog -loadRunLog (Escaped csv_fp) ver conf = do - let log_fp = replaceExtension csv_fp "gcStats.log" - log <- readFileLines log_fp - csv <- readFileLines csv_fp - let frames = - [ f - | l <- log, - Just f <- [readMaybe l], - -- filter out gen 0 events as there are too many - generation f == 1 - ] - -- TODO this assumes a certain structure in the CSV file - (success, firstResponse) = case map (map T.strip . T.split (== ',') . T.pack) csv of - [header, row] - | let table = zip header row - timeForFirstResponse :: Maybe Seconds - timeForFirstResponse = readMaybe . T.unpack =<< lookup "firstBuildTime" table - , Just s <- lookup "success" table - , Just s <- readMaybe (T.unpack s) - -> (s,timeForFirstResponse) - _ -> error $ "Cannot parse: " <> csv_fp - return $ RunLog ver conf frames success firstResponse - --------------------------------------------------------------------------------- - -data TraceMetric = Allocated | Copied | Live | User | Elapsed - deriving (Generic, Enum, Bounded, Read) - -instance Show TraceMetric where - show Allocated = "Allocated bytes" - show Copied = "Copied bytes" - show Live = "Live bytes" - show User = "User time" - show Elapsed = "Elapsed time" - -frameMetric :: TraceMetric -> Frame -> Double -frameMetric Allocated = fromIntegral . allocated -frameMetric Copied = fromIntegral . copied -frameMetric Live = fromIntegral . live -frameMetric Elapsed = elapsed -frameMetric User = user - -data Diagram = Diagram - { traceMetric :: TraceMetric, - runLogs :: [RunLog], - title :: String - } - deriving (Generic) - -plotDiagram :: Bool -> Diagram -> FilePath -> Action () -plotDiagram includeFailed t@Diagram {traceMetric, runLogs} out = do - let extract = frameMetric traceMetric - liftIO $ E.toFile E.def out $ do - E.layout_title E..= title t - E.setColors myColors - forM_ runLogs $ \rl -> - when (includeFailed || runSuccess rl) $ do - -- Get the color we are going to use - ~(c:_) <- E.liftCState $ S.gets (E.view E.colors) - E.plot $ do - lplot <- E.line - (runVersion rl ++ " " ++ runConfiguration rl ++ if runSuccess rl then "" else " (FAILED)") - [ [ (totElapsed f, extract f) - | f <- runFrames rl - ] - ] - return (lplot E.& E.plot_lines_style . E.line_width E.*~ 2) - case runFirstReponse rl of - Just t -> E.plot $ pure $ - E.vlinePlot ("First build: " ++ runVersion rl) (E.defaultPlotLineStyle E.& E.line_color E..~ c) t - _ -> pure () - --------------------------------------------------------------------------------- - newtype Escaped a = Escaped {escaped :: a} newtype Unescaped a = Unescaped {unescaped :: a} @@ -721,49 +547,6 @@ interleave :: [[a]] -> [a] interleave = concat . transpose - --------------------------------------------------------------------------------- - -myColors :: [E.AlphaColour Double] -myColors = map E.opaque - [ E.blue - , E.green - , E.red - , E.orange - , E.yellow - , E.violet - , E.black - , E.gold - , E.brown - , E.hotpink - , E.aliceblue - , E.aqua - , E.beige - , E.bisque - , E.blueviolet - , E.burlywood - , E.cadetblue - , E.chartreuse - , E.coral - , E.crimson - , E.darkblue - , E.darkgray - , E.darkgreen - , E.darkkhaki - , E.darkmagenta - , E.deeppink - , E.dodgerblue - , E.firebrick - , E.forestgreen - , E.fuchsia - , E.greenyellow - , E.lightsalmon - , E.seagreen - , E.olive - , E.sandybrown - , E.sienna - , E.peru - ] dummyHp :: String dummyHp =