Show build graph statistics in ghcide-bench (#2343)

* Show build graph statistics in ghcide-bench This adds 5 new columns to the benchmark outputs: - buildRulesBuilt - for which the value didn't change - buildRulesChanged - for which the value did change - buildRulesVisited - for which the value was not even recomputed - buildRulesTotal - including the rules that were not visited in the last build - buildEdges - total number of edges in the build graph * Fix build * backwards compat.
haskell · Nov 14, 2021 · 9a670ed · 9a670ed
1 parent 37bf5dc
commit 9a670ed
Show file tree

Hide file tree

Showing 8 changed files with 132 additions and 49 deletions.
diff --git a/ghcide/bench/lib/Experiments.hs b/ghcide/bench/lib/Experiments.hs
@@ -26,11 +26,17 @@ import           Control.Exception.Safe          (IOException, handleAny, try)
 import           Control.Monad.Extra
 import           Control.Monad.IO.Class
 import           Data.Aeson                      (Value (Null), toJSON)
+import           Data.Either                     (fromRight)
 import           Data.List
 import           Data.Maybe
 import qualified Data.Text                       as T
 import           Data.Version
 import           Development.IDE.Plugin.Test
+import           Development.IDE.Test            (getBuildEdgesCount,
+                                                  getBuildKeysBuilt,
+                                                  getBuildKeysChanged,
+                                                  getBuildKeysVisited,
+                                                  getStoredKeys)
 import           Development.IDE.Test.Diagnostic
 import           Development.Shake               (CmdOption (Cwd, FileStdout),
                                                   cmd_)
@@ -323,6 +329,11 @@ runBenchmarksFun dir allBenchmarks = do
         , "userTime"
         , "delayedTime"
         , "totalTime"
+        , "buildRulesBuilt"
+        , "buildRulesChanged"
+        , "buildRulesVisited"
+        , "buildRulesTotal"
+        , "buildEdges"
         ]
       rows =
         [ [ name,
@@ -332,7 +343,12 @@ runBenchmarksFun dir allBenchmarks = do
             show runSetup',
             show userWaits,
             show delayedWork,
-            show runExperiment
+            show runExperiment,
+            show rulesBuilt,
+            show rulesChanged,
+            show rulesVisited,
+            show rulesTotal,
+            show edgesTotal
           ]
           | (Bench {name, samples}, BenchRun {..}) <- results,
             let runSetup' = if runSetup < 0.01 then 0 else runSetup
@@ -352,7 +368,12 @@ runBenchmarksFun dir allBenchmarks = do
             showDuration runSetup',
             showDuration userWaits,
             showDuration delayedWork,
-            showDuration runExperiment
+            showDuration runExperiment,
+            show rulesBuilt,
+            show rulesChanged,
+            show rulesVisited,
+            show rulesTotal,
+            show edgesTotal
           ]
           | (Bench {name, samples}, BenchRun {..}) <- results,
             let runSetup' = if runSetup < 0.01 then 0 else runSetup
@@ -398,11 +419,16 @@ data BenchRun = BenchRun
     runExperiment :: !Seconds,
     userWaits     :: !Seconds,
     delayedWork   :: !Seconds,
+    rulesBuilt    :: !Int,
+    rulesChanged  :: !Int,
+    rulesVisited  :: !Int,
+    rulesTotal    :: !Int,
+    edgesTotal    :: !Int,
     success       :: !Bool
   }
 
 badRun :: BenchRun
-badRun = BenchRun 0 0 0 0 0 False
+badRun = BenchRun 0 0 0 0 0 0 0 0 0 0 False
 
 waitForProgressStart :: Session ()
 waitForProgressStart = void $ do
@@ -470,6 +496,12 @@ runBench runSess b = handleAny (\e -> print e >> return badRun)
       let success = isJust result
           (userWaits, delayedWork) = fromMaybe (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
+
       return BenchRun {..}
 
 data SetupResult = SetupResult {

diff --git a/ghcide/ghcide.cabal b/ghcide/ghcide.cabal
@@ -446,6 +446,7 @@ executable ghcide-bench
         extra,
         filepath,
         ghcide,
+        hls-plugin-api,
         lens,
         lsp-test,
         lsp-types,
@@ -454,11 +455,13 @@ executable ghcide-bench
         safe-exceptions,
         hls-graph,
         shake,
+        tasty-hunit,
         text
     hs-source-dirs: bench/lib bench/exe test/src
     ghc-options: -threaded -Wall -Wno-name-shadowing -rtsopts
     main-is: Main.hs
     other-modules:
+        Development.IDE.Test
         Development.IDE.Test.Diagnostic
         Experiments
         Experiments.Types

diff --git a/ghcide/src/Development/IDE/Plugin/Test.hs b/ghcide/src/Development/IDE/Plugin/Test.hs
@@ -11,33 +11,40 @@ module Development.IDE.Plugin.Test
   , blockCommandId
   ) where
 
-import           Control.Concurrent              (threadDelay)
-import           Control.Concurrent.Extra        (readVar)
+import           Control.Concurrent                   (threadDelay)
+import           Control.Concurrent.Extra             (readVar)
 import           Control.Monad
 import           Control.Monad.IO.Class
 import           Control.Monad.STM
 import           Data.Aeson
 import           Data.Aeson.Types
 import           Data.Bifunctor
-import           Data.CaseInsensitive            (CI, original)
-import qualified Data.HashMap.Strict             as HM
-import           Data.Maybe                      (isJust)
+import           Data.CaseInsensitive                 (CI, original)
+import qualified Data.HashMap.Strict                  as HM
+import           Data.Maybe                           (isJust)
 import           Data.String
-import           Data.Text                       (Text, pack)
-import           Development.IDE.Core.OfInterest (getFilesOfInterest)
+import           Data.Text                            (Text, pack)
+import           Development.IDE.Core.OfInterest      (getFilesOfInterest)
 import           Development.IDE.Core.RuleTypes
 import           Development.IDE.Core.Service
 import           Development.IDE.Core.Shake
 import           Development.IDE.GHC.Compat
-import           Development.IDE.Graph          (Action)
-import           Development.IDE.Graph.Database (shakeLastBuildKeys)
+import           Development.IDE.Graph                (Action)
+import qualified Development.IDE.Graph                as Graph
+import           Development.IDE.Graph.Database       (ShakeDatabase,
+                                                       shakeGetBuildEdges,
+                                                       shakeGetBuildStep,
+                                                       shakeGetCleanKeys)
+import           Development.IDE.Graph.Internal.Types (Result (resultBuilt, resultChanged, resultVisited),
+                                                       Step (Step))
+import qualified Development.IDE.Graph.Internal.Types as Graph
 import           Development.IDE.Types.Action
-import           Development.IDE.Types.HscEnvEq  (HscEnvEq (hscEnv))
-import           Development.IDE.Types.Location  (fromUri)
-import           GHC.Generics                    (Generic)
-import           Ide.Plugin.Config               (CheckParents)
+import           Development.IDE.Types.HscEnvEq       (HscEnvEq (hscEnv))
+import           Development.IDE.Types.Location       (fromUri)
+import           GHC.Generics                         (Generic)
+import           Ide.Plugin.Config                    (CheckParents)
 import           Ide.Types
-import qualified Language.LSP.Server             as LSP
+import qualified Language.LSP.Server                  as LSP
 import           Language.LSP.Types
 import           System.Time.Extra
 
@@ -48,7 +55,10 @@ data TestRequest
     | GetShakeSessionQueueCount      -- ^ :: Number
     | WaitForShakeQueue -- ^ Block until the Shake queue is empty. Returns Null
     | WaitForIdeRule String Uri      -- ^ :: WaitForIdeRuleResult
-    | GetLastBuildKeys               -- ^ :: [String]
+    | GetBuildKeysVisited        -- ^ :: [(String]
+    | GetBuildKeysBuilt          -- ^ :: [(String]
+    | GetBuildKeysChanged        -- ^ :: [(String]
+    | GetBuildEdgesCount         -- ^ :: Int
     | GarbageCollectDirtyKeys CheckParents Age    -- ^ :: [String] (list of keys collected)
     | GetStoredKeys                  -- ^ :: [String] (list of keys in store)
     | GetFilesOfInterest             -- ^ :: [FilePath]
@@ -98,9 +108,18 @@ testRequestHandler s (WaitForIdeRule k file) = liftIO $ do
     success <- runAction ("WaitForIdeRule " <> k <> " " <> show file) s $ parseAction (fromString k) nfp
     let res = WaitForIdeRuleResult <$> success
     return $ bimap mkResponseError toJSON res
-testRequestHandler s GetLastBuildKeys = liftIO $ do
-    keys <- shakeLastBuildKeys $ shakeDb s
+testRequestHandler s GetBuildKeysBuilt = liftIO $ do
+    keys <- getDatabaseKeys resultBuilt $ shakeDb s
     return $ Right $ toJSON $ map show keys
+testRequestHandler s GetBuildKeysChanged = liftIO $ do
+    keys <- getDatabaseKeys resultChanged $ shakeDb s
+    return $ Right $ toJSON $ map show keys
+testRequestHandler s GetBuildKeysVisited = liftIO $ do
+    keys <- getDatabaseKeys resultVisited $ shakeDb s
+    return $ Right $ toJSON $ map show keys
+testRequestHandler s GetBuildEdgesCount = liftIO $ do
+    count <- shakeGetBuildEdges $ shakeDb s
+    return $ Right $ toJSON count
 testRequestHandler s (GarbageCollectDirtyKeys parents age) = do
     res <- liftIO $ runAction "garbage collect dirty" s $ garbageCollectDirtyKeysOlderThan age parents
     return $ Right $ toJSON $ map show res
@@ -111,6 +130,14 @@ testRequestHandler s GetFilesOfInterest = do
     ff <- liftIO $ getFilesOfInterest s
     return $ Right $ toJSON $ map fromNormalizedFilePath $ HM.keys ff
 
+getDatabaseKeys :: (Graph.Result -> Step)
+    -> ShakeDatabase
+    -> IO [Graph.Key]
+getDatabaseKeys field db = do
+    keys <- shakeGetCleanKeys db
+    step <- shakeGetBuildStep db
+    return [ k | (k, res) <- keys, field res == Step step]
+
 mkResponseError :: Text -> ResponseError
 mkResponseError msg = ResponseError InvalidRequest msg Nothing
 

diff --git a/ghcide/test/src/Development/IDE/Test.hs b/ghcide/test/src/Development/IDE/Test.hs
@@ -21,7 +21,6 @@ module Development.IDE.Test
   , standardizeQuotes
   , flushMessages
   , waitForAction
-  , getLastBuildKeys
   , getInterfaceFilesDir
   , garbageCollectDirtyKeys
   , getFilesOfInterest
@@ -30,7 +29,7 @@ module Development.IDE.Test
   , getStoredKeys
   , waitForCustomMessage
   , waitForGC
-  ) where
+  ,getBuildKeysBuilt,getBuildKeysVisited,getBuildKeysChanged,getBuildEdgesCount) where
 
 import           Control.Applicative.Combinators
 import           Control.Lens                    hiding (List)
@@ -182,23 +181,40 @@ canonicalizeUri uri = filePathToUri <$> canonicalizePath (fromJust (uriToFilePat
 diagnostic :: Session (NotificationMessage TextDocumentPublishDiagnostics)
 diagnostic = LspTest.message STextDocumentPublishDiagnostics
 
-callTestPlugin :: (A.FromJSON b) => TestRequest -> Session b
-callTestPlugin cmd = do
+tryCallTestPlugin :: (A.FromJSON b) => TestRequest -> Session (Either ResponseError b)
+tryCallTestPlugin cmd = do
     let cm = SCustomMethod "test"
     waitId <- sendRequest cm (A.toJSON cmd)
     ResponseMessage{_result} <- skipManyTill anyMessage $ responseForId cm waitId
     return $ case _result of
-         Left (ResponseError t err _) -> error $ show t <> ": " <> T.unpack err
+         Left e -> Left e
          Right json -> case A.fromJSON json of
-             A.Success a -> a
+             A.Success a -> Right a
              A.Error e   -> error e
 
+callTestPlugin :: (A.FromJSON b) => TestRequest -> Session b
+callTestPlugin cmd = do
+    res <- tryCallTestPlugin cmd
+    case res of
+        Left (ResponseError t err _) -> error $ show t <> ": " <> T.unpack err
+        Right a                      -> pure a
+
+
 waitForAction :: String -> TextDocumentIdentifier -> Session WaitForIdeRuleResult
 waitForAction key TextDocumentIdentifier{_uri} =
     callTestPlugin (WaitForIdeRule key _uri)
 
-getLastBuildKeys :: Session [T.Text]
-getLastBuildKeys = callTestPlugin GetLastBuildKeys
+getBuildKeysBuilt :: Session (Either ResponseError [T.Text])
+getBuildKeysBuilt = tryCallTestPlugin GetBuildKeysBuilt
+
+getBuildKeysVisited :: Session (Either ResponseError [T.Text])
+getBuildKeysVisited = tryCallTestPlugin GetBuildKeysVisited
+
+getBuildKeysChanged :: Session (Either ResponseError [T.Text])
+getBuildKeysChanged = tryCallTestPlugin GetBuildKeysChanged
+
+getBuildEdgesCount :: Session (Either ResponseError Int)
+getBuildEdgesCount = tryCallTestPlugin GetBuildEdgesCount
 
 getInterfaceFilesDir :: TextDocumentIdentifier -> Session FilePath
 getInterfaceFilesDir TextDocumentIdentifier{_uri} = callTestPlugin (GetInterfaceFilesDir _uri)

diff --git a/hls-graph/hls-graph.cabal b/hls-graph/hls-graph.cabal
@@ -38,8 +38,6 @@ library
     Development.IDE.Graph.Classes
     Development.IDE.Graph.Database
     Development.IDE.Graph.Rule
-
-  other-modules:
     Development.IDE.Graph.Internal.Action
     Development.IDE.Graph.Internal.Options
     Development.IDE.Graph.Internal.Rules
@@ -55,6 +53,7 @@ library
 
   hs-source-dirs:     src
   build-depends:
+    , aeson
     , async
     , base >=4.12 && <5
     , bytestring

diff --git a/hls-graph/src/Development/IDE/Graph/Database.hs b/hls-graph/src/Development/IDE/Graph/Database.hs
@@ -9,10 +9,9 @@ module Development.IDE.Graph.Database(
     shakeRunDatabaseForKeys,
     shakeProfileDatabase,
     shakeGetBuildStep,
-    shakeGetDatabaseKeys,
     shakeGetDirtySet,
-    shakeLastBuildKeys
-    ) where
+    shakeGetCleanKeys
+    ,shakeGetBuildEdges) where
 import           Data.Dynamic
 import           Data.IORef                              (readIORef)
 import           Data.Maybe
@@ -48,11 +47,6 @@ shakeGetDirtySet :: ShakeDatabase -> IO [(Key, Int)]
 shakeGetDirtySet (ShakeDatabase _ _ db) =
     fmap snd <$> Development.IDE.Graph.Internal.Database.getDirtySet db
 
--- | Returns ann approximation of the database keys,
---   annotated with how long ago (in # builds) they were visited
-shakeGetDatabaseKeys :: ShakeDatabase -> IO [(Key, Int)]
-shakeGetDatabaseKeys (ShakeDatabase _ _ db) = getKeysAndVisitAge db
-
 -- | Returns the build number
 shakeGetBuildStep :: ShakeDatabase -> IO Int
 shakeGetBuildStep (ShakeDatabase _ _ db) = do
@@ -78,9 +72,15 @@ shakeRunDatabaseForKeys keysChanged (ShakeDatabase lenAs1 as1 db) as2 = do
 shakeProfileDatabase :: ShakeDatabase -> FilePath -> IO ()
 shakeProfileDatabase (ShakeDatabase _ _ s) file = writeProfile file s
 
--- | Returns the set of keys built in the most recent step
-shakeLastBuildKeys :: ShakeDatabase -> IO [Key]
-shakeLastBuildKeys (ShakeDatabase _ _ db) = do
+-- | Returns the clean keys in the database
+shakeGetCleanKeys :: ShakeDatabase -> IO [(Key, Result )]
+shakeGetCleanKeys (ShakeDatabase _ _ db) = do
+    keys <- Ids.elems $ databaseValues db
+    return [ (k,res) | (k, Clean res) <- keys]
+
+-- | Returns the total count of edges in the build graph
+shakeGetBuildEdges :: ShakeDatabase -> IO Int
+shakeGetBuildEdges (ShakeDatabase _ _ db) = do
     keys <- Ids.elems $ databaseValues db
-    step <- readIORef $ databaseStep db
-    return [ k | (k, Clean res) <- keys, resultBuilt res == step ]
+    let ress = mapMaybe (getResult . snd) keys
+    return $ sum $ map (length . getResultDepsDefault [] . resultDeps) ress