shake-bench 0.1.0.3 → 0.1.1.0
raw patch · 2 files changed
+721/−705 lines, 2 filesdep +mtlnew-uploader
Dependencies added: mtl
Files
- shake-bench.cabal +2/−1
- src/Development/Benchmark/Rules.hs +719/−704
shake-bench.cabal view
@@ -1,6 +1,6 @@ cabal-version: 2.2 name: shake-bench-version: 0.1.0.3+version: 0.1.1.0 synopsis: Build rules for historical benchmarking license: Apache-2.0 license-file: LICENSE@@ -29,6 +29,7 @@ filepath, lens, lens-aeson,+ mtl, shake, text default-language: Haskell2010
src/Development/Benchmark/Rules.hs view
@@ -1,704 +1,719 @@-{-# LANGUAGE AllowAmbiguousTypes #-} -{-# LANGUAGE ApplicativeDo #-} -{-# LANGUAGE ConstraintKinds #-} -{-# LANGUAGE DeriveAnyClass #-} -{-# LANGUAGE DerivingStrategies #-} -{-# LANGUAGE DuplicateRecordFields #-} -{-# LANGUAGE ExistentialQuantification #-} -{-# LANGUAGE OverloadedStrings #-} -{-# LANGUAGE RankNTypes #-} -{-# LANGUAGE TypeFamilies #-} - -{- | - This module provides a bunch of Shake rules to build multiple revisions of a - project and analyse their performance. - - It assumes a project bench suite composed of examples that runs a fixed set - of experiments on every example - - Your code must implement all of the GetFoo oracles and the IsExample class, - instantiate the Shake rules, and probably 'want' a set of targets. - - The results of the benchmarks and the analysis are recorded in the file - system, using the following structure: - - <build-folder> - ├── binaries - │ └── <git-reference> - │ ├── ghc.path - path to ghc used to build the executable - │ └── <executable> - binary for this version - │ └── commitid - Git commit id for this reference - ├─ <example> - │ ├── results.csv - aggregated results for all the versions - │ └── <git-reference> - │ ├── <experiment>.gcStats.log - RTS -s output - │ ├── <experiment>.csv - stats for the experiment - │ ├── <experiment>.svg - Graph of bytes over elapsed time - │ ├── <experiment>.diff.svg - idem, including the previous version - │ ├── <experiment>.heap.svg - Heap profile - │ ├── <experiment>.log - bench stdout - │ └── results.csv - results of all the experiments for the example - ├── results.csv - aggregated results of all the experiments and versions - └── <experiment>.svg - graph of bytes over elapsed time, for all the included versions - - 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`. - -} -{-# OPTIONS_GHC -Wno-incomplete-uni-patterns #-} -module Development.Benchmark.Rules - ( - buildRules, MkBuildRules(..), - benchRules, MkBenchRules(..), BenchProject(..), ProfilingMode(..), - csvRules, - svgRules, - heapProfileRules, - phonyRules, - allTargetsForExample, - GetExample(..), GetExamples(..), - IsExample(..), RuleResultForExample, - GetExperiments(..), - GetVersions(..), - GetCommitId(..), - GetBuildSystem(..), - BuildSystem(..), findGhcForBuildSystem, - Escaped(..), Unescaped(..), escapeExperiment, unescapeExperiment, - GitCommit - - ) where - -import Control.Applicative -import Control.Lens ((^.)) -import Control.Monad -import Data.Aeson (FromJSON (..), - ToJSON (..), - Value (..), object, - (.!=), (.:?), (.=)) -import Data.Aeson.Lens (_Object) -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 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 System.Directory (createDirectoryIfMissing, - findExecutable, - renameFile) -import System.FilePath -import System.Time.Extra (Seconds) -import qualified Text.ParserCombinators.ReadP as P -import Text.Printf -import Text.Read (Read (..), get, - readMaybe, - readP_to_Prec) - -newtype GetExperiments = GetExperiments () deriving newtype (Binary, Eq, Hashable, NFData, Show) -newtype GetVersions = GetVersions () deriving newtype (Binary, Eq, Hashable, NFData, Show) -newtype GetParent = GetParent Text deriving newtype (Binary, Eq, Hashable, NFData, Show) -newtype GetCommitId = GetCommitId String deriving newtype (Binary, Eq, Hashable, NFData, Show) -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) - -type instance RuleResult GetExperiments = [Unescaped String] -type instance RuleResult GetVersions = [GitCommit] -type instance RuleResult GetParent = Text -type instance RuleResult GetCommitId = String -type instance RuleResult GetBuildSystem = BuildSystem - -type RuleResultForExample e = - ( RuleResult GetExample ~ Maybe e - , RuleResult GetExamples ~ [e] - , IsExample e) - --- | 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 - --------------------------------------------------------------------------------- - -allTargetsForExample :: IsExample e => ProfilingMode -> FilePath -> e -> Action [FilePath] -allTargetsForExample prof baseFolder ex = do - experiments <- askOracle $ GetExperiments () - versions <- askOracle $ GetVersions () - 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) </> - escaped (escapeExperiment e) <.> mode - | e <- experiments, - ver <- versions, - mode <- ["svg", "diff.svg"] ++ ["heap.svg" | prof /= NoProfiling] - ] - -allBinaries :: FilePath -> String -> Action [FilePath] -allBinaries buildFolder executableName = do - versions <- askOracle $ GetVersions () - return $ - [ buildFolder </> "binaries" </> T.unpack (humanName ver) </> executableName - | ver <- versions] - --- | Generate a set of phony rules: --- * <prefix>all --- * <prefix><example> for each example -phonyRules - :: (Traversable t, IsExample e) - => String -- ^ prefix - -> String -- ^ Executable name - -> ProfilingMode - -> FilePath - -> t e - -> Rules () -phonyRules prefix executableName prof buildFolder examples = do - forM_ examples $ \ex -> - phony (prefix <> getExampleName ex) $ need =<< - allTargetsForExample prof buildFolder ex - phony (prefix <> "all") $ do - exampleTargets <- forM examples $ \ex -> - allTargetsForExample prof buildFolder ex - need $ (buildFolder </> profilingPath prof </> "results.csv") - : concat exampleTargets - phony (prefix <> "all-binaries") $ need =<< allBinaries buildFolder executableName --------------------------------------------------------------------------------- -type OutputFolder = FilePath - -data MkBuildRules buildSystem = MkBuildRules - { -- | Return the path to the GHC executable to use for the project found in the cwd - findGhc :: buildSystem -> FilePath -> IO FilePath - -- | Name of the binary produced by 'buildProject' - , 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 - , buildProject :: buildSystem - -> [CmdOption] - -> OutputFolder - -> Action () - } - --- | Rules that drive a build system to build various revisions of a project -buildRules :: FilePattern -> MkBuildRules BuildSystem -> Rules () --- TODO generalize BuildSystem -buildRules build MkBuildRules{..} = do - -- query git for the commitid for a version - build -/- "binaries/*/commitid" %> \out -> do - alwaysRerun - - let [_,_,ver,_] = splitDirectories out - mbEntry <- find ((== T.pack ver) . humanName) <$> askOracle (GetVersions ()) - let gitThing :: String - gitThing = maybe ver (T.unpack . gitName) mbEntry - Stdout commitid <- command [] "git" ["rev-list", "-n", "1", gitThing] - writeFileChanged out $ init commitid - - -- build rules for HEAD - priority 10 $ [ build -/- "binaries/HEAD/" <> executableName - , build -/- "binaries/HEAD/ghc.path" - ] - &%> \[out, ghcpath] -> do - projectDepends - liftIO $ createDirectoryIfMissing True $ dropFileName out - buildSystem <- askOracle $ GetBuildSystem () - buildProject buildSystem [Cwd "."] (takeDirectory out) - ghcLoc <- liftIO $ findGhc buildSystem "." - writeFile' ghcpath ghcLoc - - -- build rules for non HEAD revisions - [build -/- "binaries/*/" <> executableName - ,build -/- "binaries/*/ghc.path" - ] &%> \[out, ghcPath] -> do - let [_, _binaries, ver, _] = splitDirectories out - liftIO $ createDirectoryIfMissing True $ dropFileName out - commitid <- readFile' $ takeDirectory out </> "commitid" - cmd_ $ "git worktree add bench-temp-" ++ ver ++ " " ++ commitid - 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) - writeFile' ghcPath ghcLoc - --------------------------------------------------------------------------------- -data MkBenchRules buildSystem example = forall setup. MkBenchRules - { - -- | Workaround for Shake not allowing to call 'askOracle' from 'benchProject - setupProject :: Action setup - -- | An action that invokes the executable to run the benchmark - , benchProject :: setup -> buildSystem -> [CmdOption] -> BenchProject example -> Action () - -- | An action that performs any necessary warmup. Will only be invoked once - , warmupProject :: buildSystem -> FilePath -> [CmdOption] -> example -> Action () - -- | Name of the executable to benchmark. Should match the one used to 'MkBuildRules' - , executableName :: String - } - -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 - } - -data ProfilingMode = NoProfiling | CheapHeapProfiling Seconds - deriving (Eq) - -profilingP :: String -> Maybe ProfilingMode -profilingP "unprofiled" = Just NoProfiling -profilingP inp | Just delay <- stripPrefix "profiled-" inp, Just i <- readMaybe delay = Just $ CheapHeapProfiling i -profilingP _ = Nothing - -profilingPath :: ProfilingMode -> FilePath -profilingPath NoProfiling = "unprofiled" -profilingPath (CheapHeapProfiling i) = "profiled-" <> show i - --- TODO generalize BuildSystem -benchRules :: RuleResultForExample example => FilePattern -> MkBenchRules BuildSystem example -> Rules () -benchRules build MkBenchRules{..} = do - - benchResource <- newResource "ghcide-bench" 1 - -- warmup an example - build -/- "binaries/*/*.warmup" %> \out -> do - let [_, _, ver, exampleName] = splitDirectories (dropExtension out) - let exePath = build </> "binaries" </> ver </> executableName - ghcPath = build </> "binaries" </> ver </> "ghc.path" - need [exePath, ghcPath] - buildSystem <- askOracle $ GetBuildSystem () - example <- fromMaybe (error $ "Unknown example " <> exampleName) - <$> askOracle (GetExample exampleName) - let exeExtraArgs = [] - outcsv = "" - experiment = Escaped "hover" - withResource benchResource 1 $ warmupProject buildSystem exePath - [ EchoStdout False, - FileStdout out, - RemEnv "NIX_GHC_LIBDIR", - RemEnv "GHC_PACKAGE_PATH", - AddPath [takeDirectory ghcPath, "."] [] - ] - example - -- run an experiment - priority 0 $ - [ 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 - prof = fromMaybe (error $ "Not a valid profiling mode: " <> flavour) $ profilingP flavour - example <- fromMaybe (error $ "Unknown example " <> exampleName) - <$> askOracle (GetExample exampleName) - buildSystem <- askOracle $ GetBuildSystem () - setupRes <- setupProject - liftIO $ createDirectoryIfMissing True $ dropFileName outcsv - let exePath = build </> "binaries" </> ver </> executableName - exeExtraArgs = - [ "+RTS" - , "-l" - , "-S" <> outGc] - ++ concat - [[ "-h" - , "-i" <> show i - , "-qg"] - | CheapHeapProfiling i <- [prof]] - ++ ["-RTS"] - ghcPath = build </> "binaries" </> ver </> "ghc.path" - warmupPath = build </> "binaries" </> ver </> exampleName <.> "warmup" - experiment = Escaped $ dropExtension exp - need [exePath, ghcPath, warmupPath] - ghcPath <- readFile' ghcPath - withResource benchResource 1 $ do - benchProject setupRes buildSystem - [ EchoStdout False, - FileStdout outLog, - RemEnv "NIX_GHC_LIBDIR", - RemEnv "GHC_PACKAGE_PATH", - AddPath [takeDirectory ghcPath, "."] [] - ] - BenchProject {..} - liftIO $ renameFile "ghcide.eventlog" outEventlog - liftIO $ case prof of - CheapHeapProfiling{} -> renameFile "ghcide.hp" outHp - NoProfiling -> writeFile outHp dummyHp - - -- extend csv output with allocation data - csvContents <- liftIO $ lines <$> readFile outcsv - let header = head csvContents - results = tail csvContents - header' = header <> ", maxResidency, allocatedBytes" - results' <- forM results $ \row -> do - (maxResidency, allocations) <- liftIO - (parseMaxResidencyAndAllocations <$> readFile outGc) - return $ printf "%s, %s, %s" row (showMB maxResidency) (showMB allocations) - let csvContents' = header' : results' - writeFileLines outcsv csvContents' - where - showMB :: Int -> String - showMB x = show (x `div` 2^(20::Int)) <> "MB" - --- Parse the max residency and allocations in RTS -s output -parseMaxResidencyAndAllocations :: String -> (Int, Int) -parseMaxResidencyAndAllocations input = - (f "maximum residency", f "bytes allocated in the heap") - where - inps = reverse $ lines input - f label = case find (label `isInfixOf`) inps of - Just l -> read $ filter isDigit $ head $ words l - Nothing -> -1 - - --------------------------------------------------------------------------------- - --- | Rules to aggregate the CSV output of individual experiments -csvRules :: forall example . RuleResultForExample example => FilePattern -> Rules () -csvRules build = do - -- build results for every experiment*example - 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 - - -- 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' - - -- 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, _exp] = splitDirectories out - runLog <- loadRunLog (Escaped $ replaceExtension out "csv") ver - 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 - 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 - - 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 revisions - build -/- "*/*/*.svg" %> \out -> do - let exp = Escaped $ dropExtension $ takeFileName out - versions <- askOracle $ GetVersions () - - runLogs <- forM (filter include versions) $ \v -> do - let v' = T.unpack (humanName v) - loadRunLog (Escaped $ takeDirectory out </> v' </> replaceExtension (takeFileName out) "csv") v' - - let diagram = Diagram Live 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 - let hpFile = dropExtension2 out <.> "hp" - need [hpFile] - cmd_ ("hp2pretty" :: String) [hpFile] - liftIO $ renameFile (dropExtension hpFile <.> "svg") out - -dropExtension2 :: FilePath -> FilePath -dropExtension2 = dropExtension . dropExtension --------------------------------------------------------------------------------- --------------------------------------------------------------------------------- - --- | Default build system that handles Cabal and Stack -data BuildSystem = Cabal | Stack - deriving (Eq, Read, Show, Generic) - deriving (Binary, Hashable, NFData) - -findGhcForBuildSystem :: BuildSystem -> FilePath -> IO FilePath -findGhcForBuildSystem Cabal _cwd = - liftIO $ fromMaybe (error "ghc is not in the PATH") <$> findExecutable "ghc" -findGhcForBuildSystem Stack cwd = do - Stdout ghcLoc <- cmd [Cwd cwd] ("stack exec which ghc" :: String) - return ghcLoc - -instance FromJSON BuildSystem where - parseJSON x = fromString . lower <$> parseJSON x - where - fromString "stack" = Stack - fromString "cabal" = Cabal - fromString other = error $ "Unknown build system: " <> other - -instance ToJSON BuildSystem where - toJSON = toJSON . show - --------------------------------------------------------------------------------- - -data GitCommit = GitCommit - { -- | A git hash, tag or branch name (e.g. v0.1.0) - gitName :: Text, - -- | A human understandable name (e.g. fix-collisions-leak) - name :: Maybe Text, - -- | The human understandable name of the parent, if specified explicitly - parent :: Maybe Text, - -- | Whether to include this version in the top chart - include :: Bool - } - deriving (Binary, Eq, Hashable, Generic, NFData, Show) - -instance FromJSON GitCommit where - parseJSON (String s) = pure $ GitCommit s Nothing Nothing True - 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)] -> - GitCommit - <$> props .:? "git" .!= name - <*> pure (Just name) - <*> props .:? "parent" - <*> props .:? "include" .!= True - _ -> empty - parseJSON _ = empty - -instance ToJSON GitCommit where - toJSON GitCommit {..} = - case name of - Nothing -> String gitName - Just n -> object [fromString (T.unpack n) .= String gitName] - -humanName :: GitCommit -> Text -humanName GitCommit {..} = fromMaybe gitName name - -findPrev :: Text -> [GitCommit] -> Text -findPrev name (x : y : xx) - | humanName y == name = humanName x - | 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, - runFrames :: ![Frame], - runSuccess :: !Bool - } - -loadRunLog :: HasCallStack => Escaped FilePath -> String -> Action RunLog -loadRunLog (Escaped csv_fp) ver = 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 = case map (T.split (== ',') . T.pack) csv of - [_header, _name:s:_] | Just s <- readMaybe (T.unpack s) -> s - _ -> error $ "Cannot parse: " <> csv_fp - return $ RunLog ver frames success - --------------------------------------------------------------------------------- - -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) $ E.plot $ do - lplot <- E.line - (runVersion 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) - --------------------------------------------------------------------------------- - -newtype Escaped a = Escaped {escaped :: a} - -newtype Unescaped a = Unescaped {unescaped :: a} - deriving newtype (Show, FromJSON, ToJSON, Eq, NFData, Binary, Hashable) - -escapeExperiment :: Unescaped String -> Escaped String -escapeExperiment = Escaped . map f . unescaped - where - f ' ' = '_' - f other = other - -unescapeExperiment :: Escaped String -> Unescaped String -unescapeExperiment = Unescaped . map f . escaped - where - f '_' = ' ' - f other = other - --------------------------------------------------------------------------------- - -(-/-) :: FilePattern -> FilePattern -> FilePattern -a -/- b = a <> "/" <> b - -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 = - "JOB \"ghcide\" \ - \DATE \"Sun Jan 31 09:30 2021\" \ - \SAMPLE_UNIT \"seconds\" \ - \VALUE_UNIT \"bytes\" \ - \BEGIN_SAMPLE 0.000000 \ - \END_SAMPLE 0.000000" +{-# LANGUAGE AllowAmbiguousTypes #-}+{-# LANGUAGE ApplicativeDo #-}+{-# LANGUAGE ConstraintKinds #-}+{-# LANGUAGE DeriveAnyClass #-}+{-# LANGUAGE DerivingStrategies #-}+{-# LANGUAGE DuplicateRecordFields #-}+{-# LANGUAGE ExistentialQuantification #-}+{-# LANGUAGE OverloadedStrings #-}+{-# LANGUAGE RankNTypes #-}+{-# LANGUAGE TypeFamilies #-}++{- |+ This module provides a bunch of Shake rules to build multiple revisions of a+ project and analyse their performance.++ It assumes a project bench suite composed of examples that runs a fixed set+ of experiments on every example++ Your code must implement all of the GetFoo oracles and the IsExample class,+ instantiate the Shake rules, and probably 'want' a set of targets.++ The results of the benchmarks and the analysis are recorded in the file+ system, using the following structure:++ <build-folder>+ ├── binaries+ │ └── <git-reference>+ │ ├── ghc.path - path to ghc used to build the executable+ │ └── <executable> - binary for this version+ │ └── commitid - Git commit id for this reference+ ├─ <example>+ │ ├── results.csv - aggregated results for all the versions+ │ └── <git-reference>+ │ ├── <experiment>.gcStats.log - RTS -s output+ │ ├── <experiment>.csv - stats for the experiment+ │ ├── <experiment>.svg - Graph of bytes over elapsed time+ │ ├── <experiment>.diff.svg - idem, including the previous version+ │ ├── <experiment>.heap.svg - Heap profile+ │ ├── <experiment>.log - bench stdout+ │ └── results.csv - results of all the experiments for the example+ ├── results.csv - aggregated results of all the experiments and versions+ └── <experiment>.svg - graph of bytes over elapsed time, for all the included versions++ 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`.+ -}+{-# OPTIONS_GHC -Wno-incomplete-uni-patterns #-}+module Development.Benchmark.Rules+ (+ buildRules, MkBuildRules(..),+ benchRules, MkBenchRules(..), BenchProject(..), ProfilingMode(..),+ csvRules,+ svgRules,+ heapProfileRules,+ phonyRules,+ allTargetsForExample,+ GetExample(..), GetExamples(..),+ IsExample(..), RuleResultForExample,+ GetExperiments(..),+ GetVersions(..),+ GetCommitId(..),+ GetBuildSystem(..),+ BuildSystem(..), findGhcForBuildSystem,+ Escaped(..), Unescaped(..), escapeExperiment, unescapeExperiment,+ GitCommit++ ) where++import Control.Applicative+import Control.Lens ((^.))+import Control.Monad+import qualified Control.Monad.State as S+import Data.Aeson (FromJSON (..),+ ToJSON (..),+ Value (..), object,+ (.!=), (.:?), (.=))+import Data.Aeson.Lens (_Object)+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 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 System.Directory (createDirectoryIfMissing,+ findExecutable,+ renameFile)+import System.FilePath+import System.Time.Extra (Seconds)+import qualified Text.ParserCombinators.ReadP as P+import Text.Printf+import Text.Read (Read (..), get,+ readMaybe,+ readP_to_Prec)++newtype GetExperiments = GetExperiments () deriving newtype (Binary, Eq, Hashable, NFData, Show)+newtype GetVersions = GetVersions () deriving newtype (Binary, Eq, Hashable, NFData, Show)+newtype GetParent = GetParent Text deriving newtype (Binary, Eq, Hashable, NFData, Show)+newtype GetCommitId = GetCommitId String deriving newtype (Binary, Eq, Hashable, NFData, Show)+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)++type instance RuleResult GetExperiments = [Unescaped String]+type instance RuleResult GetVersions = [GitCommit]+type instance RuleResult GetParent = Text+type instance RuleResult GetCommitId = String+type instance RuleResult GetBuildSystem = BuildSystem++type RuleResultForExample e =+ ( RuleResult GetExample ~ Maybe e+ , RuleResult GetExamples ~ [e]+ , IsExample e)++-- | 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++--------------------------------------------------------------------------------++allTargetsForExample :: IsExample e => ProfilingMode -> FilePath -> e -> Action [FilePath]+allTargetsForExample prof baseFolder ex = do+ experiments <- askOracle $ GetExperiments ()+ versions <- askOracle $ GetVersions ()+ 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) </>+ escaped (escapeExperiment e) <.> mode+ | e <- experiments,+ ver <- versions,+ mode <- ["svg", "diff.svg"] ++ ["heap.svg" | prof /= NoProfiling]+ ]++allBinaries :: FilePath -> String -> Action [FilePath]+allBinaries buildFolder executableName = do+ versions <- askOracle $ GetVersions ()+ return $+ [ buildFolder </> "binaries" </> T.unpack (humanName ver) </> executableName+ | ver <- versions]++-- | Generate a set of phony rules:+-- * <prefix>all+-- * <prefix><example> for each example+phonyRules+ :: (Traversable t, IsExample e)+ => String -- ^ prefix+ -> String -- ^ Executable name+ -> ProfilingMode+ -> FilePath+ -> t e+ -> Rules ()+phonyRules prefix executableName prof buildFolder examples = do+ forM_ examples $ \ex ->+ phony (prefix <> getExampleName ex) $ need =<<+ allTargetsForExample prof buildFolder ex+ phony (prefix <> "all") $ do+ exampleTargets <- forM examples $ \ex ->+ allTargetsForExample prof buildFolder ex+ need $ (buildFolder </> profilingPath prof </> "results.csv")+ : concat exampleTargets+ phony (prefix <> "all-binaries") $ need =<< allBinaries buildFolder executableName+--------------------------------------------------------------------------------+type OutputFolder = FilePath++data MkBuildRules buildSystem = MkBuildRules+ { -- | Return the path to the GHC executable to use for the project found in the cwd+ findGhc :: buildSystem -> FilePath -> IO FilePath+ -- | Name of the binary produced by 'buildProject'+ , 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+ , buildProject :: buildSystem+ -> [CmdOption]+ -> OutputFolder+ -> Action ()+ }++-- | Rules that drive a build system to build various revisions of a project+buildRules :: FilePattern -> MkBuildRules BuildSystem -> Rules ()+-- TODO generalize BuildSystem+buildRules build MkBuildRules{..} = do+ -- query git for the commitid for a version+ build -/- "binaries/*/commitid" %> \out -> do+ alwaysRerun++ let [_,_,ver,_] = splitDirectories out+ mbEntry <- find ((== T.pack ver) . humanName) <$> askOracle (GetVersions ())+ let gitThing :: String+ gitThing = maybe ver (T.unpack . gitName) mbEntry+ Stdout commitid <- command [] "git" ["rev-list", "-n", "1", gitThing]+ writeFileChanged out $ init commitid++ -- build rules for HEAD+ priority 10 $ [ build -/- "binaries/HEAD/" <> executableName+ , build -/- "binaries/HEAD/ghc.path"+ ]+ &%> \[out, ghcpath] -> do+ projectDepends+ liftIO $ createDirectoryIfMissing True $ dropFileName out+ buildSystem <- askOracle $ GetBuildSystem ()+ buildProject buildSystem [Cwd "."] (takeDirectory out)+ ghcLoc <- liftIO $ findGhc buildSystem "."+ writeFile' ghcpath ghcLoc++ -- build rules for non HEAD revisions+ [build -/- "binaries/*/" <> executableName+ ,build -/- "binaries/*/ghc.path"+ ] &%> \[out, ghcPath] -> do+ let [_, _binaries, ver, _] = splitDirectories out+ liftIO $ createDirectoryIfMissing True $ dropFileName out+ commitid <- readFile' $ takeDirectory out </> "commitid"+ cmd_ $ "git worktree add bench-temp-" ++ ver ++ " " ++ commitid+ 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)+ writeFile' ghcPath ghcLoc++--------------------------------------------------------------------------------+data MkBenchRules buildSystem example = forall setup. MkBenchRules+ {+ -- | Workaround for Shake not allowing to call 'askOracle' from 'benchProject+ setupProject :: Action setup+ -- | An action that invokes the executable to run the benchmark+ , benchProject :: setup -> buildSystem -> [CmdOption] -> BenchProject example -> Action ()+ -- | An action that performs any necessary warmup. Will only be invoked once+ , warmupProject :: buildSystem -> FilePath -> [CmdOption] -> example -> Action ()+ -- | Name of the executable to benchmark. Should match the one used to 'MkBuildRules'+ , executableName :: String+ }++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+ }++data ProfilingMode = NoProfiling | CheapHeapProfiling Seconds+ deriving (Eq)++profilingP :: String -> Maybe ProfilingMode+profilingP "unprofiled" = Just NoProfiling+profilingP inp | Just delay <- stripPrefix "profiled-" inp, Just i <- readMaybe delay = Just $ CheapHeapProfiling i+profilingP _ = Nothing++profilingPath :: ProfilingMode -> FilePath+profilingPath NoProfiling = "unprofiled"+profilingPath (CheapHeapProfiling i) = "profiled-" <> show i++-- TODO generalize BuildSystem+benchRules :: RuleResultForExample example => FilePattern -> MkBenchRules BuildSystem example -> Rules ()+benchRules build MkBenchRules{..} = do++ benchResource <- newResource "ghcide-bench" 1+ -- warmup an example+ build -/- "binaries/*/*.warmup" %> \out -> do+ let [_, _, ver, exampleName] = splitDirectories (dropExtension out)+ let exePath = build </> "binaries" </> ver </> executableName+ ghcPath = build </> "binaries" </> ver </> "ghc.path"+ need [exePath, ghcPath]+ buildSystem <- askOracle $ GetBuildSystem ()+ example <- fromMaybe (error $ "Unknown example " <> exampleName)+ <$> askOracle (GetExample exampleName)+ let exeExtraArgs = []+ outcsv = ""+ experiment = Escaped "hover"+ withResource benchResource 1 $ warmupProject buildSystem exePath+ [ EchoStdout False,+ FileStdout out,+ RemEnv "NIX_GHC_LIBDIR",+ RemEnv "GHC_PACKAGE_PATH",+ AddPath [takeDirectory ghcPath, "."] []+ ]+ example+ -- run an experiment+ priority 0 $+ [ 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+ prof = fromMaybe (error $ "Not a valid profiling mode: " <> flavour) $ profilingP flavour+ example <- fromMaybe (error $ "Unknown example " <> exampleName)+ <$> askOracle (GetExample exampleName)+ buildSystem <- askOracle $ GetBuildSystem ()+ setupRes <- setupProject+ liftIO $ createDirectoryIfMissing True $ dropFileName outcsv+ let exePath = build </> "binaries" </> ver </> executableName+ exeExtraArgs =+ [ "+RTS"+ , "-l"+ , "-S" <> outGc]+ ++ concat+ [[ "-h"+ , "-i" <> show i+ , "-qg"]+ | CheapHeapProfiling i <- [prof]]+ ++ ["-RTS"]+ ghcPath = build </> "binaries" </> ver </> "ghc.path"+ warmupPath = build </> "binaries" </> ver </> exampleName <.> "warmup"+ experiment = Escaped $ dropExtension exp+ need [exePath, ghcPath, warmupPath]+ ghcPath <- readFile' ghcPath+ withResource benchResource 1 $ do+ benchProject setupRes buildSystem+ [ EchoStdout False,+ FileStdout outLog,+ RemEnv "NIX_GHC_LIBDIR",+ RemEnv "GHC_PACKAGE_PATH",+ AddPath [takeDirectory ghcPath, "."] []+ ]+ BenchProject {..}+ liftIO $ renameFile "ghcide.eventlog" outEventlog+ liftIO $ case prof of+ CheapHeapProfiling{} -> renameFile "ghcide.hp" outHp+ NoProfiling -> writeFile outHp dummyHp++ -- extend csv output with allocation data+ csvContents <- liftIO $ lines <$> readFile outcsv+ let header = head csvContents+ results = tail csvContents+ header' = header <> ", maxResidency, allocatedBytes"+ results' <- forM results $ \row -> do+ (maxResidency, allocations) <- liftIO+ (parseMaxResidencyAndAllocations <$> readFile outGc)+ return $ printf "%s, %s, %s" row (showMB maxResidency) (showMB allocations)+ let csvContents' = header' : results'+ writeFileLines outcsv csvContents'+ where+ showMB :: Int -> String+ showMB x = show (x `div` 2^(20::Int)) <> "MB"++-- Parse the max residency and allocations in RTS -s output+parseMaxResidencyAndAllocations :: String -> (Int, Int)+parseMaxResidencyAndAllocations input =+ (f "maximum residency", f "bytes allocated in the heap")+ where+ inps = reverse $ lines input+ f label = case find (label `isInfixOf`) inps of+ Just l -> read $ filter isDigit $ head $ words l+ Nothing -> -1+++--------------------------------------------------------------------------------++-- | Rules to aggregate the CSV output of individual experiments+csvRules :: forall example . RuleResultForExample example => FilePattern -> Rules ()+csvRules build = do+ -- build results for every experiment*example+ 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++ -- 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'++ -- 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, _exp] = splitDirectories out+ runLog <- loadRunLog (Escaped $ replaceExtension out "csv") ver+ 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+ 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++ 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 revisions+ build -/- "*/*/*.svg" %> \out -> do+ let exp = Escaped $ dropExtension $ takeFileName out+ versions <- askOracle $ GetVersions ()++ runLogs <- forM (filter include versions) $ \v -> do+ let v' = T.unpack (humanName v)+ loadRunLog (Escaped $ takeDirectory out </> v' </> replaceExtension (takeFileName out) "csv") v'++ let diagram = Diagram Live 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+ let hpFile = dropExtension2 out <.> "hp"+ need [hpFile]+ cmd_ ("hp2pretty" :: String) [hpFile]+ liftIO $ renameFile (dropExtension hpFile <.> "svg") out++dropExtension2 :: FilePath -> FilePath+dropExtension2 = dropExtension . dropExtension+--------------------------------------------------------------------------------+--------------------------------------------------------------------------------++-- | Default build system that handles Cabal and Stack+data BuildSystem = Cabal | Stack+ deriving (Eq, Read, Show, Generic)+ deriving (Binary, Hashable, NFData)++findGhcForBuildSystem :: BuildSystem -> FilePath -> IO FilePath+findGhcForBuildSystem Cabal _cwd =+ liftIO $ fromMaybe (error "ghc is not in the PATH") <$> findExecutable "ghc"+findGhcForBuildSystem Stack cwd = do+ Stdout ghcLoc <- cmd [Cwd cwd] ("stack exec which ghc" :: String)+ return ghcLoc++instance FromJSON BuildSystem where+ parseJSON x = fromString . lower <$> parseJSON x+ where+ fromString "stack" = Stack+ fromString "cabal" = Cabal+ fromString other = error $ "Unknown build system: " <> other++instance ToJSON BuildSystem where+ toJSON = toJSON . show++--------------------------------------------------------------------------------++data GitCommit = GitCommit+ { -- | A git hash, tag or branch name (e.g. v0.1.0)+ gitName :: Text,+ -- | A human understandable name (e.g. fix-collisions-leak)+ name :: Maybe Text,+ -- | The human understandable name of the parent, if specified explicitly+ parent :: Maybe Text,+ -- | Whether to include this version in the top chart+ include :: Bool+ }+ deriving (Binary, Eq, Hashable, Generic, NFData, Show)++instance FromJSON GitCommit where+ parseJSON (String s) = pure $ GitCommit s Nothing Nothing True+ 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)] ->+ GitCommit+ <$> props .:? "git" .!= name+ <*> pure (Just name)+ <*> props .:? "parent"+ <*> props .:? "include" .!= True+ _ -> empty+ parseJSON _ = empty++instance ToJSON GitCommit where+ toJSON GitCommit {..} =+ case name of+ Nothing -> String gitName+ Just n -> object [fromString (T.unpack n) .= String gitName]++humanName :: GitCommit -> Text+humanName GitCommit {..} = fromMaybe gitName name++findPrev :: Text -> [GitCommit] -> Text+findPrev name (x : y : xx)+ | humanName y == name = humanName x+ | 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,+ runFrames :: ![Frame],+ runSuccess :: !Bool,+ runFirstReponse :: !(Maybe Seconds)+ }++loadRunLog :: HasCallStack => Escaped FilePath -> String -> Action RunLog+loadRunLog (Escaped csv_fp) ver = 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 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 ++ 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}+ deriving newtype (Show, FromJSON, ToJSON, Eq, NFData, Binary, Hashable)++escapeExperiment :: Unescaped String -> Escaped String+escapeExperiment = Escaped . map f . unescaped+ where+ f ' ' = '_'+ f other = other++unescapeExperiment :: Escaped String -> Unescaped String+unescapeExperiment = Unescaped . map f . escaped+ where+ f '_' = ' '+ f other = other++--------------------------------------------------------------------------------++(-/-) :: FilePattern -> FilePattern -> FilePattern+a -/- b = a <> "/" <> b++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 =+ "JOB \"ghcide\" \+ \DATE \"Sun Jan 31 09:30 2021\" \+ \SAMPLE_UNIT \"seconds\" \+ \VALUE_UNIT \"bytes\" \+ \BEGIN_SAMPLE 0.000000 \+ \END_SAMPLE 0.000000"