Skip to content

Commit 9a670ed

Browse files
pepeiborrapepeiborra
committed
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.
1 parent 37bf5dc commit 9a670ed

File tree

8 files changed

+132
-49
lines changed

8 files changed

+132
-49
lines changed

‎ghcide/bench/lib/Experiments.hs

+35-3
Original file line numberDiff line numberDiff line change
@@ -26,11 +26,17 @@ import Control.Exception.Safe (IOException, handleAny, try)
2626
import Control.Monad.Extra
2727
import Control.Monad.IO.Class
2828
import Data.Aeson (Value (Null), toJSON)
29+
import Data.Either (fromRight)
2930
import Data.List
3031
import Data.Maybe
3132
import qualified Data.Text as T
3233
import Data.Version
3334
import Development.IDE.Plugin.Test
35+
import Development.IDE.Test (getBuildEdgesCount,
36+
getBuildKeysBuilt,
37+
getBuildKeysChanged,
38+
getBuildKeysVisited,
39+
getStoredKeys)
3440
import Development.IDE.Test.Diagnostic
3541
import Development.Shake (CmdOption (Cwd, FileStdout),
3642
cmd_)
@@ -323,6 +329,11 @@ runBenchmarksFun dir allBenchmarks = do
323329
, "userTime"
324330
, "delayedTime"
325331
, "totalTime"
332+
, "buildRulesBuilt"
333+
, "buildRulesChanged"
334+
, "buildRulesVisited"
335+
, "buildRulesTotal"
336+
, "buildEdges"
326337
]
327338
rows =
328339
[ [ name,
@@ -332,7 +343,12 @@ runBenchmarksFun dir allBenchmarks = do
332343
show runSetup',
333344
show userWaits,
334345
show delayedWork,
335-
show runExperiment
346+
show runExperiment,
347+
show rulesBuilt,
348+
show rulesChanged,
349+
show rulesVisited,
350+
show rulesTotal,
351+
show edgesTotal
336352
]
337353
| (Bench {name, samples}, BenchRun {..}) <- results,
338354
let runSetup' = if runSetup < 0.01 then 0 else runSetup
@@ -352,7 +368,12 @@ runBenchmarksFun dir allBenchmarks = do
352368
showDuration runSetup',
353369
showDuration userWaits,
354370
showDuration delayedWork,
355-
showDuration runExperiment
371+
showDuration runExperiment,
372+
show rulesBuilt,
373+
show rulesChanged,
374+
show rulesVisited,
375+
show rulesTotal,
376+
show edgesTotal
356377
]
357378
| (Bench {name, samples}, BenchRun {..}) <- results,
358379
let runSetup' = if runSetup < 0.01 then 0 else runSetup
@@ -398,11 +419,16 @@ data BenchRun = BenchRun
398419
runExperiment :: !Seconds,
399420
userWaits :: !Seconds,
400421
delayedWork :: !Seconds,
422+
rulesBuilt :: !Int,
423+
rulesChanged :: !Int,
424+
rulesVisited :: !Int,
425+
rulesTotal :: !Int,
426+
edgesTotal :: !Int,
401427
success :: !Bool
402428
}
403429

404430
badRun :: BenchRun
405-
badRun = BenchRun 0 0 0 0 0 False
431+
badRun = BenchRun 0 0 0 0 0 0 0 0 0 0 False
406432

407433
waitForProgressStart :: Session ()
408434
waitForProgressStart = void $ do
@@ -470,6 +496,12 @@ runBench runSess b = handleAny (\e -> print e >> return badRun)
470496
let success = isJust result
471497
(userWaits, delayedWork) = fromMaybe (0,0) result
472498

499+
rulesTotal <- length <$> getStoredKeys
500+
rulesBuilt <- either (const 0) length <$> getBuildKeysBuilt
501+
rulesChanged <- either (const 0) length <$> getBuildKeysChanged
502+
rulesVisited <- either (const 0) length <$> getBuildKeysVisited
503+
edgesTotal <- fromRight 0 <$> getBuildEdgesCount
504+
473505
return BenchRun {..}
474506

475507
data SetupResult = SetupResult {

‎ghcide/ghcide.cabal

+3
Original file line numberDiff line numberDiff line change
@@ -446,6 +446,7 @@ executable ghcide-bench
446446
extra,
447447
filepath,
448448
ghcide,
449+
hls-plugin-api,
449450
lens,
450451
lsp-test,
451452
lsp-types,
@@ -454,11 +455,13 @@ executable ghcide-bench
454455
safe-exceptions,
455456
hls-graph,
456457
shake,
458+
tasty-hunit,
457459
text
458460
hs-source-dirs: bench/lib bench/exe test/src
459461
ghc-options: -threaded -Wall -Wno-name-shadowing -rtsopts
460462
main-is: Main.hs
461463
other-modules:
464+
Development.IDE.Test
462465
Development.IDE.Test.Diagnostic
463466
Experiments
464467
Experiments.Types

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

+44-17
Original file line numberDiff line numberDiff line change
@@ -11,33 +11,40 @@ module Development.IDE.Plugin.Test
1111
, blockCommandId
1212
) where
1313

14-
import Control.Concurrent (threadDelay)
15-
import Control.Concurrent.Extra (readVar)
14+
import Control.Concurrent (threadDelay)
15+
import Control.Concurrent.Extra (readVar)
1616
import Control.Monad
1717
import Control.Monad.IO.Class
1818
import Control.Monad.STM
1919
import Data.Aeson
2020
import Data.Aeson.Types
2121
import Data.Bifunctor
22-
import Data.CaseInsensitive (CI, original)
23-
import qualified Data.HashMap.Strict as HM
24-
import Data.Maybe (isJust)
22+
import Data.CaseInsensitive (CI, original)
23+
import qualified Data.HashMap.Strict as HM
24+
import Data.Maybe (isJust)
2525
import Data.String
26-
import Data.Text (Text, pack)
27-
import Development.IDE.Core.OfInterest (getFilesOfInterest)
26+
import Data.Text (Text, pack)
27+
import Development.IDE.Core.OfInterest (getFilesOfInterest)
2828
import Development.IDE.Core.RuleTypes
2929
import Development.IDE.Core.Service
3030
import Development.IDE.Core.Shake
3131
import Development.IDE.GHC.Compat
32-
import Development.IDE.Graph (Action)
33-
import Development.IDE.Graph.Database (shakeLastBuildKeys)
32+
import Development.IDE.Graph (Action)
33+
import qualified Development.IDE.Graph as Graph
34+
import Development.IDE.Graph.Database (ShakeDatabase,
35+
shakeGetBuildEdges,
36+
shakeGetBuildStep,
37+
shakeGetCleanKeys)
38+
import Development.IDE.Graph.Internal.Types (Result (resultBuilt, resultChanged, resultVisited),
39+
Step (Step))
40+
import qualified Development.IDE.Graph.Internal.Types as Graph
3441
import Development.IDE.Types.Action
35-
import Development.IDE.Types.HscEnvEq (HscEnvEq (hscEnv))
36-
import Development.IDE.Types.Location (fromUri)
37-
import GHC.Generics (Generic)
38-
import Ide.Plugin.Config (CheckParents)
42+
import Development.IDE.Types.HscEnvEq (HscEnvEq (hscEnv))
43+
import Development.IDE.Types.Location (fromUri)
44+
import GHC.Generics (Generic)
45+
import Ide.Plugin.Config (CheckParents)
3946
import Ide.Types
40-
import qualified Language.LSP.Server as LSP
47+
import qualified Language.LSP.Server as LSP
4148
import Language.LSP.Types
4249
import System.Time.Extra
4350

@@ -48,7 +55,10 @@ data TestRequest
4855
| GetShakeSessionQueueCount -- ^ :: Number
4956
| WaitForShakeQueue -- ^ Block until the Shake queue is empty. Returns Null
5057
| WaitForIdeRule String Uri -- ^ :: WaitForIdeRuleResult
51-
| GetLastBuildKeys -- ^ :: [String]
58+
| GetBuildKeysVisited -- ^ :: [(String]
59+
| GetBuildKeysBuilt -- ^ :: [(String]
60+
| GetBuildKeysChanged -- ^ :: [(String]
61+
| GetBuildEdgesCount -- ^ :: Int
5262
| GarbageCollectDirtyKeys CheckParents Age -- ^ :: [String] (list of keys collected)
5363
| GetStoredKeys -- ^ :: [String] (list of keys in store)
5464
| GetFilesOfInterest -- ^ :: [FilePath]
@@ -98,9 +108,18 @@ testRequestHandler s (WaitForIdeRule k file) = liftIO $ do
98108
success <- runAction ("WaitForIdeRule " <> k <> " " <> show file) s $ parseAction (fromString k) nfp
99109
let res = WaitForIdeRuleResult <$> success
100110
return $ bimap mkResponseError toJSON res
101-
testRequestHandler s GetLastBuildKeys = liftIO $ do
102-
keys <- shakeLastBuildKeys $ shakeDb s
111+
testRequestHandler s GetBuildKeysBuilt = liftIO $ do
112+
keys <- getDatabaseKeys resultBuilt $ shakeDb s
103113
return $ Right $ toJSON $ map show keys
114+
testRequestHandler s GetBuildKeysChanged = liftIO $ do
115+
keys <- getDatabaseKeys resultChanged $ shakeDb s
116+
return $ Right $ toJSON $ map show keys
117+
testRequestHandler s GetBuildKeysVisited = liftIO $ do
118+
keys <- getDatabaseKeys resultVisited $ shakeDb s
119+
return $ Right $ toJSON $ map show keys
120+
testRequestHandler s GetBuildEdgesCount = liftIO $ do
121+
count <- shakeGetBuildEdges $ shakeDb s
122+
return $ Right $ toJSON count
104123
testRequestHandler s (GarbageCollectDirtyKeys parents age) = do
105124
res <- liftIO $ runAction "garbage collect dirty" s $ garbageCollectDirtyKeysOlderThan age parents
106125
return $ Right $ toJSON $ map show res
@@ -111,6 +130,14 @@ testRequestHandler s GetFilesOfInterest = do
111130
ff <- liftIO $ getFilesOfInterest s
112131
return $ Right $ toJSON $ map fromNormalizedFilePath $ HM.keys ff
113132

133+
getDatabaseKeys :: (Graph.Result -> Step)
134+
-> ShakeDatabase
135+
-> IO [Graph.Key]
136+
getDatabaseKeys field db = do
137+
keys <- shakeGetCleanKeys db
138+
step <- shakeGetBuildStep db
139+
return [ k | (k, res) <- keys, field res == Step step]
140+
114141
mkResponseError :: Text -> ResponseError
115142
mkResponseError msg = ResponseError InvalidRequest msg Nothing
116143

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

+24-8
Original file line numberDiff line numberDiff line change
@@ -21,7 +21,6 @@ module Development.IDE.Test
2121
, standardizeQuotes
2222
, flushMessages
2323
, waitForAction
24-
, getLastBuildKeys
2524
, getInterfaceFilesDir
2625
, garbageCollectDirtyKeys
2726
, getFilesOfInterest
@@ -30,7 +29,7 @@ module Development.IDE.Test
3029
, getStoredKeys
3130
, waitForCustomMessage
3231
, waitForGC
33-
) where
32+
,getBuildKeysBuilt,getBuildKeysVisited,getBuildKeysChanged,getBuildEdgesCount) where
3433

3534
import Control.Applicative.Combinators
3635
import Control.Lens hiding (List)
@@ -182,23 +181,40 @@ canonicalizeUri uri = filePathToUri <$> canonicalizePath (fromJust (uriToFilePat
182181
diagnostic :: Session (NotificationMessage TextDocumentPublishDiagnostics)
183182
diagnostic = LspTest.message STextDocumentPublishDiagnostics
184183

185-
callTestPlugin :: (A.FromJSON b) => TestRequest -> Session b
186-
callTestPlugin cmd = do
184+
tryCallTestPlugin :: (A.FromJSON b) => TestRequest -> Session (Either ResponseError b)
185+
tryCallTestPlugin cmd = do
187186
let cm = SCustomMethod "test"
188187
waitId <- sendRequest cm (A.toJSON cmd)
189188
ResponseMessage{_result} <- skipManyTill anyMessage $ responseForId cm waitId
190189
return $ case _result of
191-
Left (ResponseError t err _) -> error $ show t <> ": " <> T.unpack err
190+
Left e -> Left e
192191
Right json -> case A.fromJSON json of
193-
A.Success a -> a
192+
A.Success a -> Right a
194193
A.Error e -> error e
195194

195+
callTestPlugin :: (A.FromJSON b) => TestRequest -> Session b
196+
callTestPlugin cmd = do
197+
res <- tryCallTestPlugin cmd
198+
case res of
199+
Left (ResponseError t err _) -> error $ show t <> ": " <> T.unpack err
200+
Right a -> pure a
201+
202+
196203
waitForAction :: String -> TextDocumentIdentifier -> Session WaitForIdeRuleResult
197204
waitForAction key TextDocumentIdentifier{_uri} =
198205
callTestPlugin (WaitForIdeRule key _uri)
199206

200-
getLastBuildKeys :: Session [T.Text]
201-
getLastBuildKeys = callTestPlugin GetLastBuildKeys
207+
getBuildKeysBuilt :: Session (Either ResponseError [T.Text])
208+
getBuildKeysBuilt = tryCallTestPlugin GetBuildKeysBuilt
209+
210+
getBuildKeysVisited :: Session (Either ResponseError [T.Text])
211+
getBuildKeysVisited = tryCallTestPlugin GetBuildKeysVisited
212+
213+
getBuildKeysChanged :: Session (Either ResponseError [T.Text])
214+
getBuildKeysChanged = tryCallTestPlugin GetBuildKeysChanged
215+
216+
getBuildEdgesCount :: Session (Either ResponseError Int)
217+
getBuildEdgesCount = tryCallTestPlugin GetBuildEdgesCount
202218

203219
getInterfaceFilesDir :: TextDocumentIdentifier -> Session FilePath
204220
getInterfaceFilesDir TextDocumentIdentifier{_uri} = callTestPlugin (GetInterfaceFilesDir _uri)

‎hls-graph/hls-graph.cabal

+1-2
Original file line numberDiff line numberDiff line change
@@ -38,8 +38,6 @@ library
3838
Development.IDE.Graph.Classes
3939
Development.IDE.Graph.Database
4040
Development.IDE.Graph.Rule
41-
42-
other-modules:
4341
Development.IDE.Graph.Internal.Action
4442
Development.IDE.Graph.Internal.Options
4543
Development.IDE.Graph.Internal.Rules
@@ -55,6 +53,7 @@ library
5553

5654
hs-source-dirs: src
5755
build-depends:
56+
, aeson
5857
, async
5958
, base >=4.12 && <5
6059
, bytestring

‎hls-graph/src/Development/IDE/Graph/Database.hs

+13-13
Original file line numberDiff line numberDiff line change
@@ -9,10 +9,9 @@ module Development.IDE.Graph.Database(
99
shakeRunDatabaseForKeys,
1010
shakeProfileDatabase,
1111
shakeGetBuildStep,
12-
shakeGetDatabaseKeys,
1312
shakeGetDirtySet,
14-
shakeLastBuildKeys
15-
) where
13+
shakeGetCleanKeys
14+
,shakeGetBuildEdges) where
1615
import Data.Dynamic
1716
import Data.IORef (readIORef)
1817
import Data.Maybe
@@ -48,11 +47,6 @@ shakeGetDirtySet :: ShakeDatabase -> IO [(Key, Int)]
4847
shakeGetDirtySet (ShakeDatabase _ _ db) =
4948
fmap snd <$> Development.IDE.Graph.Internal.Database.getDirtySet db
5049

51-
-- | Returns ann approximation of the database keys,
52-
-- annotated with how long ago (in # builds) they were visited
53-
shakeGetDatabaseKeys :: ShakeDatabase -> IO [(Key, Int)]
54-
shakeGetDatabaseKeys (ShakeDatabase _ _ db) = getKeysAndVisitAge db
55-
5650
-- | Returns the build number
5751
shakeGetBuildStep :: ShakeDatabase -> IO Int
5852
shakeGetBuildStep (ShakeDatabase _ _ db) = do
@@ -78,9 +72,15 @@ shakeRunDatabaseForKeys keysChanged (ShakeDatabase lenAs1 as1 db) as2 = do
7872
shakeProfileDatabase :: ShakeDatabase -> FilePath -> IO ()
7973
shakeProfileDatabase (ShakeDatabase _ _ s) file = writeProfile file s
8074

81-
-- | Returns the set of keys built in the most recent step
82-
shakeLastBuildKeys :: ShakeDatabase -> IO [Key]
83-
shakeLastBuildKeys (ShakeDatabase _ _ db) = do
75+
-- | Returns the clean keys in the database
76+
shakeGetCleanKeys :: ShakeDatabase -> IO [(Key, Result )]
77+
shakeGetCleanKeys (ShakeDatabase _ _ db) = do
78+
keys <- Ids.elems $ databaseValues db
79+
return [ (k,res) | (k, Clean res) <- keys]
80+
81+
-- | Returns the total count of edges in the build graph
82+
shakeGetBuildEdges :: ShakeDatabase -> IO Int
83+
shakeGetBuildEdges (ShakeDatabase _ _ db) = do
8484
keys <- Ids.elems $ databaseValues db
85-
step <- readIORef $ databaseStep db
86-
return [ k | (k, Clean res) <- keys, resultBuilt res == step ]
85+
let ress = mapMaybe (getResult . snd) keys
86+
return $ sum $ map (length . getResultDepsDefault [] . resultDeps) ress

0 commit comments

Comments
 (0)