From 23c68fc9540663f03495a032c13001db551839a4 Mon Sep 17 00:00:00 2001 From: Zubin Duggal Date: Tue, 29 Mar 2022 17:23:17 +0530 Subject: [PATCH] bench: Add more metrics Add columns to keep track of total GHC rebuilds, time for first response and average time per response --- ghcide/bench/lib/Experiments.hs | 34 ++++++++++++---- ghcide/src/Development/IDE/Core/Rules.hs | 33 ++++++++++++---- ghcide/src/Development/IDE/Plugin/Test.hs | 5 +++ ghcide/test/src/Development/IDE/Test.hs | 4 ++ shake-bench/shake-bench.cabal | 1 + .../src/Development/Benchmark/Rules.hs | 39 +++++++++++++------ 6 files changed, 88 insertions(+), 28 deletions(-) diff --git a/ghcide/bench/lib/Experiments.hs b/ghcide/bench/lib/Experiments.hs index 6fd08fe444..159f0addb9 100644 --- a/ghcide/bench/lib/Experiments.hs +++ b/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,8 +498,8 @@ 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 @@ -491,17 +507,19 @@ runBench runSess b = handleAny (\e -> print e >> return badRun) 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 {..} diff --git a/ghcide/src/Development/IDE/Core/Rules.hs b/ghcide/src/Development/IDE/Core/Rules.hs index 8f0fd18c3d..80a250490f 100644 --- a/ghcide/src/Development/IDE/Core/Rules.hs +++ b/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 diff --git a/ghcide/src/Development/IDE/Plugin/Test.hs b/ghcide/src/Development/IDE/Plugin/Test.hs index 0df73d87d5..86df7807c2 100644 --- a/ghcide/src/Development/IDE/Plugin/Test.hs +++ b/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 diff --git a/ghcide/test/src/Development/IDE/Test.hs b/ghcide/test/src/Development/IDE/Test.hs index 7768369adc..27036b9d75 100644 --- a/ghcide/test/src/Development/IDE/Test.hs +++ b/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) diff --git a/shake-bench/shake-bench.cabal b/shake-bench/shake-bench.cabal index 8c7f5d3f5c..6068520485 100644 --- a/shake-bench/shake-bench.cabal +++ b/shake-bench/shake-bench.cabal @@ -29,6 +29,7 @@ library filepath, lens, lens-aeson, + mtl, shake, text default-language: Haskell2010 diff --git a/shake-bench/src/Development/Benchmark/Rules.hs b/shake-bench/src/Development/Benchmark/Rules.hs index e2bcc9b4ca..e9117c8be8 100644 --- a/shake-bench/src/Development/Benchmark/Rules.hs +++ b/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 () --------------------------------------------------------------------------------