Benchmarks: generate heap profiles

.github/mergify.yml

@@ -7,7 +7,6 @@ pull_request_rules:
   conditions:
   - status-success=bench (8.10.2, ubuntu-latest)
   - status-success=bench (8.8.4, ubuntu-latest)
-  - status-success=bench (8.6.5, ubuntu-latest)
 
   - status-success=nix (default, ubuntu-latest)
   - status-success=nix (default, macOS-latest)

.github/workflows/bench.yml

@@ -8,7 +8,7 @@ jobs:
     strategy:
       fail-fast: false
       matrix:
-        ghc: ['8.10.2', '8.8.4', '8.6.5']
+        ghc: ['8.10.2', '8.8.4']
         os: [ubuntu-latest]
 
     steps:

ghcide/bench/hist/Main.hs

@@ -66,14 +66,15 @@ type instance RuleResult GetExample = Maybe Example
 type instance RuleResult GetExamples = [Example]
 
 main :: IO ()
-main = shakeArgs shakeOptions {shakeChange = ChangeModtimeAndDigest} $ do
+main = shakeArgs shakeOptions {shakeChange = ChangeModtimeAndDigest, shakeThreads = 0} $ do
   createBuildSystem $ \resource -> do
       configStatic <- liftIO $ readConfigIO config
       let build = outputFolder configStatic
       buildRules build ghcideBuildRules
       benchRules build resource (MkBenchRules (askOracle $ GetSamples ()) benchGhcide "ghcide")
       csvRules build
       svgRules build
+      eventlogRules build
       action $ allTargets build
 
 ghcideBuildRules :: MkBuildRules BuildSystem
@@ -122,6 +123,7 @@ buildGhcide Cabal args out = do
         ,"--install-method=copy"
         ,"--overwrite-policy=always"
         ,"--ghc-options=-rtsopts"
+        ,"--ghc-options=-eventlog"
         ]
 
 buildGhcide Stack args out =
@@ -131,23 +133,24 @@ buildGhcide Stack args out =
         ,"ghcide:ghcide"
         ,"--copy-bins"
         ,"--ghc-options=-rtsopts"
+        ,"--ghc-options=-eventlog"
         ]
 
 benchGhcide
   :: Natural -> BuildSystem -> [CmdOption] -> BenchProject Example -> Action ()
 benchGhcide samples buildSystem args BenchProject{..} = do
   command_ args "ghcide-bench" $
-    [ "--timeout=3000",
+    [ "--timeout=300",
       "--no-clean",
         "-v",
         "--samples=" <> show samples,
         "--csv="     <> outcsv,
         "--ghcide="  <> exePath,
+        "--ghcide-options=" <> unwords exeExtraArgs,
         "--select",
         unescaped (unescapeExperiment experiment)
     ] ++
     exampleToOptions example ++
     [ "--stack" | Stack == buildSystem
-    ] ++
-    exeExtraArgs
+    ]
 

ghcide/ghcide.cabal

@@ -219,7 +219,8 @@ benchmark benchHist
     hs-source-dirs: bench/hist bench/lib
     other-modules: Experiments.Types
     build-tool-depends:
-        ghcide:ghcide-bench
+        ghcide:ghcide-bench,
+        eventlog2html:eventlog2html
     default-extensions:
         BangPatterns
         DeriveFunctor

shake-bench/src/Development/Benchmark/Rules.hs

@@ -49,6 +49,7 @@ module Development.Benchmark.Rules
       benchRules, MkBenchRules(..), BenchProject(..),
       csvRules,
       svgRules,
+      eventlogRules,
       allTargets,
       GetExample(..), GetExamples(..),
       IsExample(..), RuleResultForExample,
@@ -83,7 +84,7 @@ import           GHC.Stack                                 (HasCallStack)
 import qualified Graphics.Rendering.Chart.Backend.Diagrams as E
 import           Graphics.Rendering.Chart.Easy             ((.=))
 import qualified Graphics.Rendering.Chart.Easy             as E
-import           System.Directory                          (findExecutable, createDirectoryIfMissing)
+import           System.Directory (createDirectoryIfMissing, findExecutable, renameFile)
 import           System.FilePath
 import qualified Text.ParserCombinators.ReadP              as P
 import           Text.Read                                 (Read (..), get,
@@ -134,11 +135,11 @@ allTargets buildFolder = do
         ++ [ buildFolder </>
              getExampleName ex </>
              T.unpack (humanName ver) </>
-             escaped (escapeExperiment e) <.> mode <.> "svg"
+             escaped (escapeExperiment e) <.> mode
              | e <- experiments,
                ex <- examples,
                ver <- versions,
-               mode <- ["", "diff"]
+               mode <- ["svg", "diff.svg","eventlog.html"]
            ]
 
 --------------------------------------------------------------------------------
@@ -188,14 +189,14 @@ buildRules build MkBuildRules{..} = do
   [build -/- "binaries/*/" <> executableName
    ,build -/- "binaries/*/ghc.path"
    ] &%> \[out, ghcPath] -> do
-      let [_, _binaries, _ver, _] = splitDirectories out
+      let [_, _binaries, ver, _] = splitDirectories out
       liftIO $ createDirectoryIfMissing True $ dropFileName out
       commitid <- readFile' $ takeDirectory out </> "commitid"
-      cmd_ $ "git worktree add bench-temp " ++ commitid
+      cmd_ $ "git worktree add bench-temp-" ++ ver ++ " " ++ commitid
       buildSystem <- askOracle $ GetBuildSystem ()
-      flip actionFinally (cmd_ ("git worktree remove bench-temp --force" :: String)) $ do
-        ghcLoc <- liftIO $ findGhc buildSystem "bench-temp"
-        buildProject buildSystem [Cwd "bench-temp"] (".." </> takeDirectory out)
+      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
 
 --------------------------------------------------------------------------------
@@ -224,17 +225,19 @@ benchRules build benchResource MkBenchRules{..} = do
   priority 0 $
     [ build -/- "*/*/*.csv",
       build -/- "*/*/*.benchmark-gcStats",
+      build -/- "*/*/*.eventlog",
+      build -/- "*/*/*.hp",
       build -/- "*/*/*.log"
     ]
-      &%> \[outcsv, outGc, outLog] -> do
+      &%> \[outcsv, outGc, outEventLog, outHp, outLog] -> do
         let [_, exampleName, ver, exp] = splitDirectories outcsv
         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", "-I0.5", "-S" <> takeFileName outGc, "-RTS"]
+            exeExtraArgs = ["+RTS", "-l-a", "-h", "-ol" <> outEventLog, "-S" <> outGc, "-RTS"]
             ghcPath    = build </> "binaries" </> ver </> "ghc.path"
             experiment = Escaped $ dropExtension exp
         need [exePath, ghcPath]
@@ -247,8 +250,8 @@ benchRules build benchResource MkBenchRules{..} = do
                 RemEnv "GHC_PACKAGE_PATH",
                 AddPath [takeDirectory ghcPath, "."] []
               ]
-              BenchProject{..}
-          cmd_ Shell $ "mv *.benchmark-gcStats " <> dropFileName outcsv
+              BenchProject {..}
+          liftIO $ renameFile "ghcide.hp" $ dropFileName outcsv </> dropExtension exp <.> "hp"
 
         -- extend csv output with allocation data
         csvContents <- liftIO $ lines <$> readFile outcsv
@@ -378,6 +381,11 @@ svgRules build = do
         title = show (unescapeExperiment exp) <> " - live bytes over time"
     plotDiagram False diagram out
 
+eventlogRules :: FilePattern -> Rules ()
+eventlogRules build = do
+  build -/- "*/*/*.eventlog.html" %> \out -> do
+    need [dropExtension out]
+    cmd_ ("eventlog2html" :: String) [dropExtension out]
 
 --------------------------------------------------------------------------------
 --------------------------------------------------------------------------------