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.1.1.0 +version: 0.2.0.0 synopsis: Build rules for historical benchmarking license: Apache-2.0 license-file: LICENSE @@ -8,16 +8,20 @@ maintainer: pepeiborra@gmail.com category: Development build-type: Simple -description: - A library Shake rules to build and run benchmarks for multiple revisions of a project. - An example of usage can be found in the ghcide benchmark suite +-- description is a single line so that implicit-hie can parse it +description: A library Shake rules to build and run benchmarks for multiple revisions of a project. An example of usage can be found in the ghcide benchmark suite +source-repository head + type: git + location: https://github.com/haskell/haskell-language-server.git + library exposed-modules: Development.Benchmark.Rules hs-source-dirs: src build-depends: aeson, base == 4.*, + bytestring, Chart, Chart-diagrams, diagrams-contrib, 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 @@ -26,20 +26,22 @@ ├── binaries │ └── │  ├── ghc.path - path to ghc used to build the executable - │  └── - binary for this version + │  ├── - binary for this version │  └── commitid - Git commit id for this reference ├─ - │ ├── results.csv - aggregated results for all the versions - │ └── - │   ├── .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 - │   ├── .log - bench stdout - │   └── results.csv - results of all the experiments for the example - ├── results.csv - aggregated results of all the experiments and versions - └── .svg - graph of bytes over elapsed time, for all the included versions + │ ├── 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 + │   ├── .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 For diff graphs, 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`. @@ -47,7 +49,7 @@ {-# OPTIONS_GHC -Wno-incomplete-uni-patterns #-} module Development.Benchmark.Rules ( - buildRules, MkBuildRules(..), + buildRules, MkBuildRules(..), OutputFolder, ProjectRoot, benchRules, MkBenchRules(..), BenchProject(..), ProfilingMode(..), csvRules, svgRules, @@ -60,6 +62,7 @@ GetVersions(..), GetCommitId(..), GetBuildSystem(..), + GetConfigurations(..), Configuration(..), BuildSystem(..), findGhcForBuildSystem, Escaped(..), Unescaped(..), escapeExperiment, unescapeExperiment, GitCommit @@ -67,14 +70,16 @@ ) where import Control.Applicative -import Control.Lens ((^.)) +import Control.Lens (preview, view, (^.)) import Control.Monad import qualified Control.Monad.State as S import Data.Aeson (FromJSON (..), ToJSON (..), Value (..), object, (.!=), (.:?), (.=)) -import Data.Aeson.Lens (_Object) +import Data.Aeson.Lens (AsJSON (_JSON), + _Object, _String) +import Data.ByteString.Lazy (ByteString) import Data.Char (isDigit) import Data.List (find, isInfixOf, stripPrefix, @@ -93,6 +98,7 @@ import GHC.Stack (HasCallStack) import qualified Graphics.Rendering.Chart.Backend.Diagrams as E import qualified Graphics.Rendering.Chart.Easy as E +import Numeric.Natural import System.Directory (createDirectoryIfMissing, findExecutable, renameFile) @@ -111,6 +117,7 @@ newtype GetBuildSystem = GetBuildSystem () deriving newtype (Binary, Eq, Hashable, NFData, Show) newtype GetExample = GetExample String deriving newtype (Binary, Eq, Hashable, NFData, Show) newtype GetExamples = GetExamples () deriving newtype (Binary, Eq, Hashable, NFData, Show) +newtype GetConfigurations = GetConfigurations () deriving newtype (Binary, Eq, Hashable, NFData, Show) type instance RuleResult GetExperiments = [Unescaped String] type instance RuleResult GetVersions = [GitCommit] @@ -123,6 +130,10 @@ , RuleResult GetExamples ~ [e] , IsExample e) +data Configuration = Configuration {confName :: String, confValue :: ByteString} + deriving (Binary, Eq, Generic, Hashable, NFData, Show, Typeable) +type instance RuleResult GetConfigurations = [Configuration] + -- | Knowledge needed to run an example class (Binary e, Eq e, Hashable e, NFData e, Show e, Typeable e) => IsExample e where getExampleName :: e -> String @@ -133,6 +144,7 @@ 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"] @@ -142,9 +154,12 @@ ++ [ buildFolder getExampleName ex T.unpack (humanName ver) - escaped (escapeExperiment e) <.> mode + confName + escaped (escapeExperiment e) <.> + mode | e <- experiments, ver <- versions, + Configuration{confName} <- configurations, mode <- ["svg", "diff.svg"] ++ ["heap.svg" | prof /= NoProfiling] ] @@ -178,6 +193,7 @@ phony (prefix <> "all-binaries") $ need =<< allBinaries buildFolder executableName -------------------------------------------------------------------------------- type OutputFolder = FilePath +type ProjectRoot = FilePath data MkBuildRules buildSystem = MkBuildRules { -- | Return the path to the GHC executable to use for the project found in the cwd @@ -186,9 +202,9 @@ , executableName :: String -- | An action that captures the source dependencies, used for the HEAD build , projectDepends :: Action () - -- | Build the project found in the cwd and save the build artifacts in the output folder + -- | Build the project found in the given path and save the build artifacts in the output folder , buildProject :: buildSystem - -> [CmdOption] + -> ProjectRoot -> OutputFolder -> Action () } @@ -216,7 +232,7 @@ projectDepends liftIO $ createDirectoryIfMissing True $ dropFileName out buildSystem <- askOracle $ GetBuildSystem () - buildProject buildSystem [Cwd "."] (takeDirectory out) + buildProject buildSystem "." (takeDirectory out) ghcLoc <- liftIO $ findGhc buildSystem "." writeFile' ghcpath ghcLoc @@ -231,7 +247,7 @@ buildSystem <- askOracle $ GetBuildSystem () flip actionFinally (cmd_ ("git worktree remove bench-temp-" <> ver <> " --force" :: String)) $ do ghcLoc <- liftIO $ findGhc buildSystem ver - buildProject buildSystem [Cwd $ "bench-temp-" <> ver] (".." takeDirectory out) + buildProject buildSystem ("bench-temp-" <> ver) (".." takeDirectory out) writeFile' ghcPath ghcLoc -------------------------------------------------------------------------------- @@ -245,14 +261,17 @@ , warmupProject :: buildSystem -> FilePath -> [CmdOption] -> example -> Action () -- | Name of the executable to benchmark. Should match the one used to 'MkBuildRules' , executableName :: String + -- | Number of concurrent benchmarks to run + , parallelism :: Natural } data BenchProject example = BenchProject - { outcsv :: FilePath -- ^ where to save the CSV output - , exePath :: FilePath -- ^ where to find the executable for benchmarking - , exeExtraArgs :: [String] -- ^ extra args for the executable - , example :: example -- ^ example to benchmark - , experiment :: Escaped String -- ^ experiment to run + { outcsv :: FilePath -- ^ where to save the CSV output + , exePath :: FilePath -- ^ where to find the executable for benchmarking + , exeExtraArgs :: [String] -- ^ extra args for the executable + , example :: example -- ^ example to benchmark + , experiment :: Escaped String -- ^ experiment to run + , configuration :: ByteString -- ^ configuration to use } data ProfilingMode = NoProfiling | CheapHeapProfiling Seconds @@ -271,7 +290,7 @@ benchRules :: RuleResultForExample example => FilePattern -> MkBenchRules BuildSystem example -> Rules () benchRules build MkBenchRules{..} = do - benchResource <- newResource "ghcide-bench" 1 + benchResource <- newResource "ghcide-bench" (fromIntegral parallelism) -- warmup an example build -/- "binaries/*/*.warmup" %> \out -> do let [_, _, ver, exampleName] = splitDirectories (dropExtension out) @@ -294,33 +313,38 @@ example -- run an experiment priority 0 $ - [ build -/- "*/*/*/*.csv", - build -/- "*/*/*/*.gcStats.log", - build -/- "*/*/*/*.output.log", - build -/- "*/*/*/*.eventlog", - build -/- "*/*/*/*.hp" + [ build -/- "*/*/*/*/*.csv", + build -/- "*/*/*/*/*.gcStats.log", + build -/- "*/*/*/*/*.output.log", + build -/- "*/*/*/*/*.eventlog", + build -/- "*/*/*/*/*.hp" ] &%> \[outcsv, outGc, outLog, outEventlog, outHp] -> do - let [_, flavour, exampleName, ver, exp] = splitDirectories outcsv + let [_, flavour, exampleName, ver, conf, exp] = splitDirectories outcsv prof = fromMaybe (error $ "Not a valid profiling mode: " <> flavour) $ profilingP flavour example <- fromMaybe (error $ "Unknown example " <> exampleName) <$> askOracle (GetExample exampleName) buildSystem <- askOracle $ GetBuildSystem () + configurations <- askOracle $ GetConfigurations () setupRes <- setupProject liftIO $ createDirectoryIfMissing True $ dropFileName outcsv let exePath = build "binaries" ver executableName exeExtraArgs = [ "+RTS" , "-l" + , "-ol" <> outEventlog , "-S" <> outGc] ++ concat [[ "-h" , "-i" <> show i + , "-po" <> outHp , "-qg"] | CheapHeapProfiling i <- [prof]] ++ ["-RTS"] ghcPath = build "binaries" ver "ghc.path" warmupPath = build "binaries" ver exampleName <.> "warmup" experiment = Escaped $ dropExtension exp + Just Configuration{..} = find (\Configuration{confName} -> confName == conf) configurations + configuration = confValue need [exePath, ghcPath, warmupPath] ghcPath <- readFile' ghcPath withResource benchResource 1 $ do @@ -332,10 +356,9 @@ AddPath [takeDirectory ghcPath, "."] [] ] BenchProject {..} - liftIO $ renameFile "ghcide.eventlog" outEventlog liftIO $ case prof of - CheapHeapProfiling{} -> renameFile "ghcide.hp" outHp - NoProfiling -> writeFile outHp dummyHp + NoProfiling -> writeFile outHp dummyHp + _ -> return () -- extend csv output with allocation data csvContents <- liftIO $ lines <$> readFile outcsv @@ -369,7 +392,7 @@ csvRules :: forall example . RuleResultForExample example => FilePattern -> Rules () csvRules build = do -- build results for every experiment*example - build -/- "*/*/*/results.csv" %> \out -> do + build -/- "*/*/*/*/results.csv" %> \out -> do experiments <- askOracle $ GetExperiments () let allResultFiles = [takeDirectory out escaped (escapeExperiment e) <.> "csv" | e <- experiments] @@ -379,6 +402,20 @@ results = map tail allResults writeFileChanged out $ unlines $ header : concat results + -- 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' + -- aggregate all experiments for an example build -/- "*/*/results.csv" %> \out -> do versions <- map (T.unpack . humanName) <$> askOracle (GetVersions ()) @@ -415,44 +452,60 @@ 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, _exp] = splitDirectories out - runLog <- loadRunLog (Escaped $ replaceExtension out "csv") ver + 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, exp_] = splitDirectories out + 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 - runLogPrev <- loadRunLog (Escaped $ joinPath [b,flav, example, prev, replaceExtension (dropExtension exp_) "csv"]) prev + 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 + -- 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 () + + runLogs <- forM configurations $ \Configuration{confName} -> do + loadRunLog (Escaped $ takeDirectory out confName replaceExtension (takeFileName out) "csv") ver confName + + let diagram = Diagram Live runLogs title + title = show (unescapeExperiment exp) <> " - live bytes over time" + plotDiagram False diagram out + -- 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 () - runLogs <- forM (filter include versions) $ \v -> do + runLogs <- forM (filter include versions) $ \v -> + forM configurations $ \Configuration{confName} -> do let v' = T.unpack (humanName v) - loadRunLog (Escaped $ takeDirectory out v' replaceExtension (takeFileName out) "csv") v' + loadRunLog (Escaped $ takeDirectory out v' confName replaceExtension (takeFileName out) "csv") v' confName - let diagram = Diagram Live runLogs title + let diagram = Diagram Live (concat runLogs) title title = show (unescapeExperiment exp) <> " - live bytes over time" plotDiagram False diagram out heapProfileRules :: FilePattern -> Rules () heapProfileRules build = do priority 3 $ - build -/- "*/*/*/*.heap.svg" %> \out -> do + build -/- "*/*/*/*/*.heap.svg" %> \out -> do let hpFile = dropExtension2 out <.> "hp" need [hpFile] cmd_ ("hp2pretty" :: String) [hpFile] @@ -504,8 +557,10 @@ parseJSON o@(Object _) = do let keymap = o ^. _Object case toList keymap of - [(name, String gitName)] -> pure $ GitCommit gitName (Just name) Nothing True - [(name, Object props)] -> + -- excuse the aeson 2.0 compatibility hack + [(preview _String . toJSON -> Just name, String gitName)] -> + pure $ GitCommit gitName (Just name) Nothing True + [(preview _String . toJSON -> Just name, Object props)] -> GitCommit <$> props .:? "git" .!= name <*> pure (Just name) @@ -560,14 +615,15 @@ -- | A file path containing the output of -S for a given run data RunLog = RunLog - { runVersion :: !String, - runFrames :: ![Frame], - runSuccess :: !Bool, - runFirstReponse :: !(Maybe Seconds) + { runVersion :: !String, + runConfiguration :: !String, + runFrames :: ![Frame], + runSuccess :: !Bool, + runFirstReponse :: !(Maybe Seconds) } -loadRunLog :: HasCallStack => Escaped FilePath -> String -> Action RunLog -loadRunLog (Escaped csv_fp) ver = do +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 @@ -588,7 +644,7 @@ , Just s <- readMaybe (T.unpack s) -> (s,timeForFirstResponse) _ -> error $ "Cannot parse: " <> csv_fp - return $ RunLog ver frames success firstResponse + return $ RunLog ver conf frames success firstResponse -------------------------------------------------------------------------------- @@ -628,13 +684,13 @@ ~(c:_) <- E.liftCState $ S.gets (E.view E.colors) E.plot $ do lplot <- E.line - (runVersion rl ++ if runSuccess rl then "" else " (FAILED)") + (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 + 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 ()