{- Bench history A Shake script to analyze the performance of ghcide over the git history of the project Driven by a config file `bench/hist.yaml` containing the list of Git references to analyze. Builds each one of them and executes a set of experiments using the ghcide-bench suite. The results of the benchmarks and the analysis are recorded in the file system with the following structure: bench-hist ├── - one folder per version │   ├── .benchmark-gcStats - RTS -s output │   ├── .csv - stats for the experiment │   ├── .svg - Graph of bytes over elapsed time │   ├── .diff.svg - idem, including the previous version │   ├── .log - ghcide-bench output │   ├── ghc.path - path to ghc used to build the binary │   ├── ghcide - binary for this version │   └── results.csv - results of all the experiments for the version ├── results.csv - aggregated results of all the experiments and versions ├── .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`. The script relies on stack for building and running all the binaries. To execute the script: > stack bench To build a specific analysis, enumerate the desired file artifacts > stack bench --ba "bench-hist/HEAD/results.csv bench-hist/HEAD/edit.diff.svg" -} {-# LANGUAGE DeriveAnyClass #-} {-# LANGUAGE DerivingStrategies#-} {-# LANGUAGE TypeFamilies #-} import Control.Applicative (Alternative (empty)) import Control.Monad (when, forM, forM_, replicateM) import Data.Foldable (find) import Data.Maybe (fromMaybe) import Data.Text (Text) import qualified Data.Text as T import Data.Yaml ((.!=), (.:?), FromJSON (..), ToJSON (..), Value (..), decodeFileThrow) import Development.Shake import Development.Shake.Classes (Binary, Hashable, NFData) import GHC.Exts (IsList (..)) import GHC.Generics (Generic) import qualified Graphics.Rendering.Chart.Backend.Diagrams as E import Graphics.Rendering.Chart.Easy ((.=)) import qualified Graphics.Rendering.Chart.Easy as E import Numeric.Natural (Natural) import System.Directory import System.FilePath import qualified Text.ParserCombinators.ReadP as P import Text.Read (Read (..), get, readMaybe, readP_to_Prec) config :: FilePath config = "bench/hist.yaml" -- | Read the config without dependency readConfigIO :: FilePath -> IO Config readConfigIO = decodeFileThrow newtype GetSamples = GetSamples () deriving newtype (Binary, Eq, Hashable, NFData, Show) 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) type instance RuleResult GetSamples = Natural type instance RuleResult GetExperiments = [Unescaped String] type instance RuleResult GetVersions = [GitCommit] type instance RuleResult GetParent = Text type instance RuleResult GetCommitId = String main :: IO () main = shakeArgs shakeOptions {shakeChange = ChangeModtimeAndDigest} $ do want ["all"] readConfig <- newCache $ \fp -> need [fp] >> liftIO (readConfigIO fp) _ <- addOracle $ \GetSamples {} -> samples <$> readConfig config _ <- addOracle $ \GetExperiments {} -> experiments <$> readConfig config _ <- addOracle $ \GetVersions {} -> versions <$> readConfig config _ <- addOracle $ \(GetParent name) -> findPrev name . versions <$> readConfig config let readVersions = askOracle $ GetVersions () readExperiments = askOracle $ GetExperiments () readSamples = askOracle $ GetSamples () getParent = askOracle . GetParent build <- liftIO $ outputFolder <$> readConfigIO config ghcideBenchPath <- ghcideBench <$> liftIO (readConfigIO config) phony "all" $ do Config {..} <- readConfig config forM_ versions $ \ver -> need [build T.unpack (humanName ver) "results.csv"] need $ [build "results.csv"] ++ [ build escaped (escapeExperiment e) <.> "svg" | e <- experiments ] ++ [ build T.unpack (humanName ver) escaped (escapeExperiment e) <.> mode <.> "svg" | e <- experiments, ver <- versions, mode <- ["", "diff"] ] build -/- "*/commitid" %> \out -> do alwaysRerun let [_,ver,_] = splitDirectories out mbEntry <- find ((== T.pack ver) . humanName) <$> readVersions let gitThing :: String gitThing = maybe ver (T.unpack . gitName) mbEntry Stdout commitid <- command [] "git" ["rev-list", "-n", "1", gitThing] writeFileChanged out $ init commitid priority 10 $ [build -/- "HEAD/ghcide" , build -/- "HEAD/ghc.path" ] &%> \[out, ghcpath] -> do liftIO $ createDirectoryIfMissing True $ dropFileName out need =<< getDirectoryFiles "." ["src//*.hs", "exe//*.hs", "ghcide.cabal"] cmd_ ( "stack --local-bin-path=" <> takeDirectory out <> " --stack-yaml=stack88.yaml build ghcide:ghcide --copy-bins --ghc-options -rtsopts" ) Stdout ghcLoc <- cmd (s "stack --stack-yaml=stack88.yaml exec which ghc") writeFile' ghcpath ghcLoc [ build -/- "*/ghcide", build -/- "*/ghc.path" ] &%> \[out, ghcpath] -> do let [b, ver, _] = splitDirectories out liftIO $ createDirectoryIfMissing True $ dropFileName out commitid <- readFile' $ b ver "commitid" cmd_ $ "git worktree add bench-temp " ++ commitid flip actionFinally (cmd_ (s "git worktree remove bench-temp --force")) $ do Stdout ghcLoc <- cmd [Cwd "bench-temp"] (s "stack --stack-yaml=stack88.yaml exec which ghc") cmd_ [Cwd "bench-temp"] ( "stack --local-bin-path=../" <> takeDirectory out <> " --stack-yaml=stack88.yaml build ghcide:ghcide --copy-bins --ghc-options -rtsopts" ) writeFile' ghcpath ghcLoc priority 8000 $ build -/- "*/results.csv" %> \out -> do experiments <- readExperiments 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 ghcideBenchResource <- newResource "ghcide-bench" 1 priority 0 $ [ build -/- "*/*.csv", build -/- "*/*.benchmark-gcStats", build -/- "*/*.log" ] &%> \[outcsv, _outGc, outLog] -> do let [_, _, exp] = splitDirectories outcsv samples <- readSamples liftIO $ createDirectoryIfMissing True $ dropFileName outcsv let ghcide = dropFileName outcsv "ghcide" ghcpath = dropFileName outcsv "ghc.path" need [ghcide, ghcpath] ghcPath <- readFile' ghcpath withResource ghcideBenchResource 1 $ do command_ [ EchoStdout False, FileStdout outLog, RemEnv "NIX_GHC_LIBDIR", RemEnv "GHC_PACKAGE_PATH", AddPath [takeDirectory ghcPath, "."] [] ] ghcideBenchPath [ "--timeout=3000", "-v", "--samples=" <> show samples, "--csv=" <> outcsv, "--example-package-version=3.0.0.0", "--ghcide-options= +RTS -I0.5 -RTS", "--ghcide=" <> ghcide, "--select", unescaped (unescapeExperiment (Escaped $ dropExtension exp)) ] cmd_ Shell $ "mv *.benchmark-gcStats " <> dropFileName outcsv build -/- "results.csv" %> \out -> do versions <- readVersions let allResultFiles = [build T.unpack (humanName v) "results.csv" | v <- versions] need [build T.unpack (humanName v) "ghcide" | v <- versions] allResults <- traverse readFileLines allResultFiles let header = head $ head allResults results = map tail allResults header' = "version, " <> header results' = zipWith (\v -> map (\l -> T.unpack (humanName v) <> ", " <> l)) versions results writeFileChanged out $ unlines $ header' : concat results' priority 2 $ build -/- "*/*.diff.svg" %> \out -> do let [b, ver, exp_] = splitDirectories out exp = Escaped $ dropExtension $ dropExtension exp_ prev <- getParent $ T.pack ver runLog <- loadRunLog b exp ver runLogPrev <- loadRunLog b exp $ T.unpack prev let diagram = Diagram Live [runLog, runLogPrev] title title = show (unescapeExperiment exp) <> " - live bytes over time compared" plotDiagram True diagram out priority 1 $ build -/- "*/*.svg" %> \out -> do let [b, ver, exp] = splitDirectories out runLog <- loadRunLog b (Escaped $ dropExtension exp) ver let diagram = Diagram Live [runLog] title title = ver <> " live bytes over time" plotDiagram True diagram out build -/- "*.svg" %> \out -> do let exp = Escaped $ dropExtension $ takeFileName out versions <- readVersions runLogs <- forM (filter include versions) $ \v -> do loadRunLog build exp $ T.unpack $ humanName v let diagram = Diagram Live runLogs title title = show (unescapeExperiment exp) <> " - live bytes over time" plotDiagram False diagram out ---------------------------------------------------------------------------------------------------- data Config = Config { experiments :: [Unescaped String], samples :: Natural, versions :: [GitCommit], -- | Path to the ghcide-bench binary for the experiments ghcideBench :: FilePath, -- | Output folder ('foo' works, 'foo/bar' does not) outputFolder :: String } deriving (Generic, Show) deriving anyclass (FromJSON, ToJSON) 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 (Object (toList -> [(name, String gitName)])) = pure $ GitCommit gitName (Just name) Nothing True parseJSON (Object (toList -> [(name, Object props)])) = GitCommit <$> props .:? "git" .!= name <*> pure (Just name) <*> props .:? "parent" <*> props .:? "include" .!= True parseJSON _ = empty instance ToJSON GitCommit where toJSON GitCommit {..} = case name of Nothing -> String gitName Just n -> Object $ fromList [(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 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) -- | A file path containing the output of -S for a given run data RunLog = RunLog { runVersion :: !String, _runExperiment :: !String, runFrames :: ![Frame], runSuccess :: !Bool } loadRunLog :: FilePath -> Escaped FilePath -> FilePath -> Action RunLog loadRunLog buildF exp ver = do let log_fp = buildF ver escaped exp <.> "benchmark-gcStats" csv_fp = replaceExtension log_fp "csv" 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 ] 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 (dropExtension $ escaped exp) frames success 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 .= 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) s :: String -> String s = id (-/-) :: FilePattern -> FilePattern -> FilePattern a -/- b = a <> "/" <> b 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 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 ]