bench: Add more metrics

ghcide/bench/lib/Experiments.hs

@@ -37,7 +37,9 @@ import           Development.IDE.Test            (getBuildEdgesCount,
                                                   getBuildKeysBuilt,
                                                   getBuildKeysChanged,
                                                   getBuildKeysVisited,
-                                                  getStoredKeys)
+                                                  getStoredKeys,
+                                                  getRebuildsCount,
+                                                  )
 import           Development.IDE.Test.Diagnostic
 import           Development.Shake               (CmdOption (Cwd, FileStdout),
                                                   cmd_)
@@ -329,12 +331,15 @@ runBenchmarksFun dir allBenchmarks = do
         , "setup"
         , "userTime"
         , "delayedTime"
+        , "firstBuildTime"
+        , "averageTimePerResponse"
         , "totalTime"
         , "buildRulesBuilt"
         , "buildRulesChanged"
         , "buildRulesVisited"
         , "buildRulesTotal"
         , "buildEdges"
+        , "ghcRebuilds"
         ]
       rows =
         [ [ name,
@@ -344,15 +349,21 @@ runBenchmarksFun dir allBenchmarks = do
             show runSetup',
             show userWaits,
             show delayedWork,
+            show $ firstResponse+firstResponseDelayed,
+            -- Exclude first response as it has a lot of setup time included
+            -- Assume that number of requests = number of modules * number of samples
+            show ((userWaits - firstResponse)/((fromIntegral samples - 1)*modules)),
             show runExperiment,
             show rulesBuilt,
             show rulesChanged,
             show rulesVisited,
             show rulesTotal,
-            show edgesTotal
+            show edgesTotal,
+            show rebuildsTotal
           ]
           | (Bench {name, samples}, BenchRun {..}) <- results,
             let runSetup' = if runSetup < 0.01 then 0 else runSetup
+                modules = fromIntegral $ length $ exampleModules $ example ?config
         ]
       csv = unlines $ map (intercalate ", ") (headers : rows)
   writeFile (outputCSV ?config) csv
@@ -369,12 +380,14 @@ runBenchmarksFun dir allBenchmarks = do
             showDuration runSetup',
             showDuration userWaits,
             showDuration delayedWork,
+            showDuration firstResponse,
             showDuration runExperiment,
             show rulesBuilt,
             show rulesChanged,
             show rulesVisited,
             show rulesTotal,
-            show edgesTotal
+            show edgesTotal,
+            show rebuildsTotal
           ]
           | (Bench {name, samples}, BenchRun {..}) <- results,
             let runSetup' = if runSetup < 0.01 then 0 else runSetup
@@ -420,16 +433,19 @@ data BenchRun = BenchRun
     runExperiment :: !Seconds,
     userWaits     :: !Seconds,
     delayedWork   :: !Seconds,
+    firstResponse :: !Seconds,
+    firstResponseDelayed :: !Seconds,
     rulesBuilt    :: !Int,
     rulesChanged  :: !Int,
     rulesVisited  :: !Int,
     rulesTotal    :: !Int,
     edgesTotal    :: !Int,
+    rebuildsTotal :: !Int,
     success       :: !Bool
   }
 
 badRun :: BenchRun
-badRun = BenchRun 0 0 0 0 0 0 0 0 0 0 False
+badRun = BenchRun 0 0 0 0 0 0 0 0 0 0 0 0 0 False
 
 waitForProgressStart :: Session ()
 waitForProgressStart = void $ do
@@ -482,26 +498,28 @@ runBench runSess b = handleAny (\e -> print e >> return badRun)
 
       liftIO $ output $ "Running " <> name <> " benchmark"
       (runSetup, ()) <- duration $ benchSetup docs
-      let loop !userWaits !delayedWork 0 = return $ Just (userWaits, delayedWork)
-          loop !userWaits !delayedWork n = do
+      let loop' (Just timeForFirstResponse) !userWaits !delayedWork 0 = return $ Just (userWaits, delayedWork, timeForFirstResponse)
+          loop' timeForFirstResponse !userWaits !delayedWork n = do
             (t, res) <- duration $ experiment docs
             if not res
               then return Nothing
             else do
                 output (showDuration t)
                 -- Wait for the delayed actions to finish
                 td <- waitForBuildQueue
-                loop (userWaits+t) (delayedWork+td) (n -1)
+                loop' (timeForFirstResponse <|> (Just (t,td))) (userWaits+t) (delayedWork+td) (n -1)
+          loop = loop' Nothing
 
       (runExperiment, result) <- duration $ loop 0 0 samples
       let success = isJust result
-          (userWaits, delayedWork) = fromMaybe (0,0) result
+          (userWaits, delayedWork, (firstResponse, firstResponseDelayed)) = fromMaybe (0,0,(0,0)) result
 
       rulesTotal <- length <$> getStoredKeys
       rulesBuilt <- either (const 0) length <$> getBuildKeysBuilt
       rulesChanged <- either (const 0) length <$> getBuildKeysChanged
       rulesVisited <- either (const 0) length <$> getBuildKeysVisited
       edgesTotal   <- fromRight 0 <$> getBuildEdgesCount
+      rebuildsTotal <- fromRight 0 <$> getRebuildsCount
 
       return BenchRun {..}
 

ghcide/src/Development/IDE/Core/Rules.hs

@@ -54,6 +54,7 @@ module Development.IDE.Core.Rules(
     ghcSessionDepsDefinition,
     getParsedModuleDefinition,
     typeCheckRuleDefinition,
+    getRebuildCount,
     GhcSessionDepsConfig(..),
     Log(..),
     DisplayTHWarning(..),
@@ -911,6 +912,20 @@ getModIfaceRule recorder = defineEarlyCutoff (cmapWithPrio LogShake recorder) $
       liftIO $ void $ modifyVar' compiledLinkables $ \old -> extendModuleEnv old mod time
   pure res
 
+-- | Count of total times we asked GHC to recompile
+newtype RebuildCounter = RebuildCounter { getRebuildCountVar :: TVar Int }
+instance IsIdeGlobal RebuildCounter
+
+getRebuildCount :: Action Int
+getRebuildCount = do
+  count <- getRebuildCountVar <$> getIdeGlobalAction
+  liftIO $ readTVarIO count
+
+incrementRebuildCount :: Action ()
+incrementRebuildCount = do
+  count <- getRebuildCountVar <$> getIdeGlobalAction
+  liftIO $ atomically $ modifyTVar' count (+1)
+
 -- | Also generates and indexes the `.hie` file, along with the `.o` file if needed
 -- Invariant maintained is that if the `.hi` file was successfully written, then the
 -- `.hie` and `.o` file (if needed) were also successfully written
@@ -940,10 +955,10 @@ regenerateHiFile sess f ms compNeeded = do
               Just tmr -> do
 
                 -- compile writes .o file
-                let compile = compileModule (RunSimplifier True) hsc (pm_mod_summary pm) $ tmrTypechecked tmr
+                let compile = liftIO $ compileModule (RunSimplifier True) hsc (pm_mod_summary pm) $ tmrTypechecked tmr
 
                 -- Bang pattern is important to avoid leaking 'tmr'
-                (diags'', !res) <- liftIO $ compileToObjCodeIfNeeded hsc compNeeded compile tmr
+                (diags'', !res) <- compileToObjCodeIfNeeded hsc compNeeded compile tmr
 
                 -- Write hi file
                 hiDiags <- case res of
@@ -967,18 +982,17 @@ regenerateHiFile sess f ms compNeeded = do
                     pure (hiDiags <> gDiags <> concat wDiags)
                   Nothing -> pure []
 
-
                 return (diags <> diags' <> diags'' <> hiDiags, res)
 
 
-type CompileMod m = m (IdeResult ModGuts)
-
 -- | HscEnv should have deps included already
-compileToObjCodeIfNeeded :: MonadIO m => HscEnv -> Maybe LinkableType -> CompileMod m -> TcModuleResult -> m (IdeResult HiFileResult)
-compileToObjCodeIfNeeded hsc Nothing _ tmr = liftIO $ do
-  res <- mkHiFileResultNoCompile hsc tmr
+compileToObjCodeIfNeeded :: HscEnv -> Maybe LinkableType -> Action (IdeResult ModGuts) -> TcModuleResult -> Action (IdeResult HiFileResult)
+compileToObjCodeIfNeeded hsc Nothing _ tmr = do
+  incrementRebuildCount
+  res <- liftIO $ mkHiFileResultNoCompile hsc tmr
   pure ([], Just $! res)
 compileToObjCodeIfNeeded hsc (Just linkableType) getGuts tmr = do
+  incrementRebuildCount
   (diags, mguts) <- getGuts
   case mguts of
     Nothing -> pure (diags, Nothing)
@@ -1079,6 +1093,7 @@ computeLinkableTypeForDynFlags d
 newtype CompiledLinkables = CompiledLinkables { getCompiledLinkables :: Var (ModuleEnv UTCTime) }
 instance IsIdeGlobal CompiledLinkables
 
+
 writeHiFileAction :: HscEnv -> HiFileResult -> Action [FileDiagnostic]
 writeHiFileAction hsc hiFile = do
     extras <- getShakeExtras
@@ -1115,6 +1130,8 @@ mainRule :: Recorder (WithPriority Log) -> RulesConfig -> Rules ()
 mainRule recorder RulesConfig{..} = do
     linkables <- liftIO $ newVar emptyModuleEnv
     addIdeGlobal $ CompiledLinkables linkables
+    rebuildCountVar <- liftIO $ newTVarIO 0
+    addIdeGlobal $ RebuildCounter rebuildCountVar
     getParsedModuleRule recorder
     getParsedModuleWithCommentsRule recorder
     getLocatedImportsRule recorder

ghcide/src/Development/IDE/Plugin/Test.hs

@@ -28,6 +28,7 @@ import           Development.IDE.Core.OfInterest      (getFilesOfInterest)
 import           Development.IDE.Core.RuleTypes
 import           Development.IDE.Core.Service
 import           Development.IDE.Core.Shake
+import           Development.IDE.Core.Rules
 import           Development.IDE.GHC.Compat
 import           Development.IDE.Graph                (Action)
 import qualified Development.IDE.Graph                as Graph
@@ -64,6 +65,7 @@ data TestRequest
     | GarbageCollectDirtyKeys CheckParents Age    -- ^ :: [String] (list of keys collected)
     | GetStoredKeys                  -- ^ :: [String] (list of keys in store)
     | GetFilesOfInterest             -- ^ :: [FilePath]
+    | GetRebuildsCount               -- ^ :: Int (number of times we recompiled with GHC)
     deriving Generic
     deriving anyclass (FromJSON, ToJSON)
 
@@ -131,6 +133,9 @@ testRequestHandler s GetStoredKeys = do
 testRequestHandler s GetFilesOfInterest = do
     ff <- liftIO $ getFilesOfInterest s
     return $ Right $ toJSON $ map fromNormalizedFilePath $ HM.keys ff
+testRequestHandler s GetRebuildsCount = do
+    count <- liftIO $ runAction "get build count" s getRebuildCount
+    return $ Right $ toJSON count
 
 getDatabaseKeys :: (Graph.Result -> Step)
     -> ShakeDatabase

ghcide/test/src/Development/IDE/Test.hs

@@ -33,6 +33,7 @@ module Development.IDE.Test
   , getBuildKeysVisited
   , getBuildKeysChanged
   , getBuildEdgesCount
+  , getRebuildsCount
   , configureCheckProject
   , isReferenceReady
   , referenceReady) where
@@ -225,6 +226,9 @@ getBuildKeysChanged = tryCallTestPlugin GetBuildKeysChanged
 getBuildEdgesCount :: Session (Either ResponseError Int)
 getBuildEdgesCount = tryCallTestPlugin GetBuildEdgesCount
 
+getRebuildsCount :: Session (Either ResponseError Int)
+getRebuildsCount = tryCallTestPlugin GetRebuildsCount
+
 getInterfaceFilesDir :: TextDocumentIdentifier -> Session FilePath
 getInterfaceFilesDir TextDocumentIdentifier{_uri} = callTestPlugin (GetInterfaceFilesDir _uri)
 

shake-bench/shake-bench.cabal

@@ -29,6 +29,7 @@ library
         filepath,
         lens,
         lens-aeson,
+        mtl,
         shake,
         text
   default-language: Haskell2010

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

@@ -69,6 +69,7 @@ module Development.Benchmark.Rules
 import           Control.Applicative
 import           Control.Lens                              ((^.))
 import           Control.Monad
+import qualified Control.Monad.State                       as S
 import           Data.Aeson                                (FromJSON (..),
                                                             ToJSON (..),
                                                             Value (..), object,
@@ -561,7 +562,8 @@ instance Read Frame where
 data RunLog = RunLog
   { runVersion :: !String,
     runFrames  :: ![Frame],
-    runSuccess :: !Bool
+    runSuccess :: !Bool,
+    runFirstReponse :: !(Maybe Seconds)
   }
 
 loadRunLog :: HasCallStack => Escaped FilePath -> String -> Action RunLog
@@ -577,10 +579,16 @@ loadRunLog (Escaped csv_fp) ver = do
             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
+      (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
+  return $ RunLog ver frames success firstResponse
 
 --------------------------------------------------------------------------------
 
@@ -615,14 +623,21 @@ plotDiagram includeFailed t@Diagram {traceMetric, runLogs} 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)
+      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 ()
 
 --------------------------------------------------------------------------------