From 70a01c6ef351a57675c4c6cb6d1c9a8ce009cf5c Mon Sep 17 00:00:00 2001
From: Pepe Iborra <pepeiborra@gmail.com>
Date: Mon, 25 Jan 2021 21:36:40 +0000
Subject: [PATCH] Produce heap profiles the old fashioned way, from .hp files

The -eventlog runtime is not reliable when combined with +RTS -h
leading to undiagnosed crashes and infinite loops.

The crashes are sporadic and seem to arise more frequently in the lsp-types
example, although we have not investigated deeply since there is a simple
alternative that doesn't crash: the vanilla runtime.
---
 ghcide/bench/hist/Main.hs                     |  4 +---
 ghcide/ghcide.cabal                           |  2 +-
 .../src/Development/Benchmark/Rules.hs        | 22 ++++++++++---------
 3 files changed, 14 insertions(+), 14 deletions(-)

diff --git a/ghcide/bench/hist/Main.hs b/ghcide/bench/hist/Main.hs
index 943bff5c84..f011167106 100644
--- a/ghcide/bench/hist/Main.hs
+++ b/ghcide/bench/hist/Main.hs
@@ -74,7 +74,7 @@ main = shakeArgs shakeOptions {shakeChange = ChangeModtimeAndDigest, shakeThread
       benchRules build resource (MkBenchRules (askOracle $ GetSamples ()) benchGhcide "ghcide")
       csvRules build
       svgRules build
-      eventlogRules build
+      heapProfileRules build
       action $ allTargets build
 
 ghcideBuildRules :: MkBuildRules BuildSystem
@@ -123,7 +123,6 @@ buildGhcide Cabal args out = do
         ,"--install-method=copy"
         ,"--overwrite-policy=always"
         ,"--ghc-options=-rtsopts"
-        ,"--ghc-options=-eventlog"
         ]
 
 buildGhcide Stack args out =
@@ -133,7 +132,6 @@ buildGhcide Stack args out =
         ,"ghcide:ghcide"
         ,"--copy-bins"
         ,"--ghc-options=-rtsopts"
-        ,"--ghc-options=-eventlog"
         ]
 
 benchGhcide
diff --git a/ghcide/ghcide.cabal b/ghcide/ghcide.cabal
index e78f5342d5..11647ab724 100644
--- a/ghcide/ghcide.cabal
+++ b/ghcide/ghcide.cabal
@@ -221,7 +221,7 @@ benchmark benchHist
     other-modules: Experiments.Types
     build-tool-depends:
         ghcide:ghcide-bench,
-        eventlog2html:eventlog2html
+        hp2pretty:hp2pretty
     default-extensions:
         BangPatterns
         DeriveFunctor
diff --git a/shake-bench/src/Development/Benchmark/Rules.hs b/shake-bench/src/Development/Benchmark/Rules.hs
index 8efc5c355d..8b4a074a6f 100644
--- a/shake-bench/src/Development/Benchmark/Rules.hs
+++ b/shake-bench/src/Development/Benchmark/Rules.hs
@@ -49,7 +49,7 @@ module Development.Benchmark.Rules
       benchRules, MkBenchRules(..), BenchProject(..),
       csvRules,
       svgRules,
-      eventlogRules,
+      heapProfileRules,
       allTargets,
       GetExample(..), GetExamples(..),
       IsExample(..), RuleResultForExample,
@@ -139,7 +139,7 @@ allTargets buildFolder = do
              | e <- experiments,
                ex <- examples,
                ver <- versions,
-               mode <- ["svg", "diff.svg","eventlog.html"]
+               mode <- ["svg", "diff.svg","heap.svg"]
            ]
 
 --------------------------------------------------------------------------------
@@ -225,11 +225,10 @@ benchRules build benchResource MkBenchRules{..} = do
   priority 0 $
     [ build -/- "*/*/*.csv",
       build -/- "*/*/*.benchmark-gcStats",
-      build -/- "*/*/*.eventlog",
       build -/- "*/*/*.hp",
       build -/- "*/*/*.log"
     ]
-      &%> \[outcsv, outGc, outEventLog, outHp, outLog] -> do
+      &%> \[outcsv, outGc, outHp, outLog] -> do
         let [_, exampleName, ver, exp] = splitDirectories outcsv
         example <- fromMaybe (error $ "Unknown example " <> exampleName)
                     <$> askOracle (GetExample exampleName)
@@ -237,7 +236,7 @@ benchRules build benchResource MkBenchRules{..} = do
         setupRes    <- setupProject
         liftIO $ createDirectoryIfMissing True $ dropFileName outcsv
         let exePath    = build </> "binaries" </> ver </> executableName
-            exeExtraArgs = ["+RTS", "-l-a", "-h", "-ol" <> outEventLog, "-S" <> outGc, "-RTS"]
+            exeExtraArgs = ["+RTS", "-h", "-S" <> outGc, "-RTS"]
             ghcPath    = build </> "binaries" </> ver </> "ghc.path"
             experiment = Escaped $ dropExtension exp
         need [exePath, ghcPath]
@@ -381,11 +380,14 @@ 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]
+heapProfileRules :: FilePattern -> Rules ()
+heapProfileRules build = do
+  priority 3 $
+    build -/- "*/*/*.heap.svg" %> \out -> do
+      let hpFile = dropExtension (dropExtension out) <.> "hp"
+      need [hpFile]
+      cmd_ ("hp2pretty" :: String) [hpFile]
+      liftIO $ renameFile (dropExtension hpFile <.> "svg") out
 
 --------------------------------------------------------------------------------
 --------------------------------------------------------------------------------