Skip to content

Commit 72221ab

Browse files
pepeiborrapepeiborra
committed
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
1 parent a4137e0 commit 72221ab

File tree

7 files changed

+117
-43
lines changed

7 files changed

+117
-43
lines changed

‎ghcide/bench/lib/Experiments.hs

Lines changed: 34 additions & 3 deletions
Original file line numberDiff line numberDiff line change
@@ -31,6 +31,11 @@ import Data.Maybe
3131
import qualified Data.Text as T
3232
import Data.Version
3333
import Development.IDE.Plugin.Test
34+
import Development.IDE.Test (getBuildEdgesCount,
35+
getBuildKeysBuilt,
36+
getBuildKeysChanged,
37+
getBuildKeysVisited,
38+
getStoredKeys)
3439
import Development.IDE.Test.Diagnostic
3540
import Development.Shake (CmdOption (Cwd, FileStdout),
3641
cmd_)
@@ -323,6 +328,11 @@ runBenchmarksFun dir allBenchmarks = do
323328
, "userTime"
324329
, "delayedTime"
325330
, "totalTime"
331+
, "buildRulesBuilt"
332+
, "buildRulesChanged"
333+
, "buildRulesVisited"
334+
, "buildRulesTotal"
335+
, "buildEdges"
326336
]
327337
rows =
328338
[ [ name,
@@ -332,7 +342,12 @@ runBenchmarksFun dir allBenchmarks = do
332342
show runSetup',
333343
show userWaits,
334344
show delayedWork,
335-
show runExperiment
345+
show runExperiment,
346+
show rulesBuilt,
347+
show rulesChanged,
348+
show rulesVisited,
349+
show rulesTotal,
350+
show edgesTotal
336351
]
337352
| (Bench {name, samples}, BenchRun {..}) <- results,
338353
let runSetup' = if runSetup < 0.01 then 0 else runSetup
@@ -352,7 +367,12 @@ runBenchmarksFun dir allBenchmarks = do
352367
showDuration runSetup',
353368
showDuration userWaits,
354369
showDuration delayedWork,
355-
showDuration runExperiment
370+
showDuration runExperiment,
371+
show rulesBuilt,
372+
show rulesChanged,
373+
show rulesVisited,
374+
show rulesTotal,
375+
show edgesTotal
356376
]
357377
| (Bench {name, samples}, BenchRun {..}) <- results,
358378
let runSetup' = if runSetup < 0.01 then 0 else runSetup
@@ -398,11 +418,16 @@ data BenchRun = BenchRun
398418
runExperiment :: !Seconds,
399419
userWaits :: !Seconds,
400420
delayedWork :: !Seconds,
421+
rulesBuilt :: !Int,
422+
rulesChanged :: !Int,
423+
rulesVisited :: !Int,
424+
rulesTotal :: !Int,
425+
edgesTotal :: !Int,
401426
success :: !Bool
402427
}
403428

404429
badRun :: BenchRun
405-
badRun = BenchRun 0 0 0 0 0 False
430+
badRun = BenchRun 0 0 0 0 0 0 0 0 0 0 False
406431

407432
waitForProgressStart :: Session ()
408433
waitForProgressStart = void $ do
@@ -470,6 +495,12 @@ runBench runSess b = handleAny (\e -> print e >> return badRun)
470495
let success = isJust result
471496
(userWaits, delayedWork) = fromMaybe (0,0) result
472497

498+
rulesTotal <- length <$> getStoredKeys
499+
rulesBuilt <- length <$> getBuildKeysBuilt
500+
rulesChanged <- length <$> getBuildKeysChanged
501+
rulesVisited <- length <$> getBuildKeysVisited
502+
edgesTotal <- getBuildEdgesCount
503+
473504
return BenchRun {..}
474505

475506
data SetupResult = SetupResult {

‎ghcide/ghcide.cabal

Lines changed: 3 additions & 0 deletions
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

Lines changed: 44 additions & 17 deletions
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

Lines changed: 12 additions & 4 deletions
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)
@@ -197,8 +196,17 @@ waitForAction :: String -> TextDocumentIdentifier -> Session WaitForIdeRuleResul
197196
waitForAction key TextDocumentIdentifier{_uri} =
198197
callTestPlugin (WaitForIdeRule key _uri)
199198

200-
getLastBuildKeys :: Session [T.Text]
201-
getLastBuildKeys = callTestPlugin GetLastBuildKeys
199+
getBuildKeysBuilt :: Session [T.Text]
200+
getBuildKeysBuilt = callTestPlugin GetBuildKeysBuilt
201+
202+
getBuildKeysVisited :: Session [T.Text]
203+
getBuildKeysVisited = callTestPlugin GetBuildKeysVisited
204+
205+
getBuildKeysChanged :: Session [T.Text]
206+
getBuildKeysChanged = callTestPlugin GetBuildKeysChanged
207+
208+
getBuildEdgesCount :: Session Int
209+
getBuildEdgesCount = callTestPlugin GetBuildEdgesCount
202210

203211
getInterfaceFilesDir :: TextDocumentIdentifier -> Session FilePath
204212
getInterfaceFilesDir TextDocumentIdentifier{_uri} = callTestPlugin (GetInterfaceFilesDir _uri)

‎hls-graph/hls-graph.cabal

Lines changed: 1 addition & 2 deletions
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

Lines changed: 13 additions & 13 deletions
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

‎hls-graph/src/Development/IDE/Graph/Internal/Types.hs

Lines changed: 10 additions & 4 deletions
Original file line numberDiff line numberDiff line change
@@ -1,6 +1,9 @@
11

22

3+
{-# LANGUAGE DeriveAnyClass #-}
34
{-# LANGUAGE DeriveFunctor #-}
5+
{-# LANGUAGE DeriveGeneric #-}
6+
{-# LANGUAGE DerivingStrategies #-}
47
{-# LANGUAGE ExistentialQuantification #-}
58
{-# LANGUAGE GeneralizedNewtypeDeriving #-}
69
{-# LANGUAGE ScopedTypeVariables #-}
@@ -14,6 +17,7 @@ import Control.Monad.Catch
1417
import Control.Monad.Fail
1518
import Control.Monad.IO.Class
1619
import Control.Monad.Trans.Reader
20+
import Data.Aeson (FromJSON, ToJSON)
1721
import qualified Data.ByteString as BS
1822
import Data.Dynamic
1923
import qualified Data.HashMap.Strict as Map
@@ -24,6 +28,7 @@ import Data.Typeable
2428
import Development.IDE.Graph.Classes
2529
import Development.IDE.Graph.Internal.Ids
2630
import Development.IDE.Graph.Internal.Intern
31+
import GHC.Generics (Generic)
2732
import System.Time.Extra (Seconds)
2833

2934

@@ -38,7 +43,7 @@ unwrapDynamic x = fromMaybe (error msg) $ fromDynamic x
3843
type TheRules = Map.HashMap TypeRep Dynamic
3944

4045
newtype Rules a = Rules (ReaderT SRules IO a)
41-
deriving (Monad, Applicative, Functor, MonadIO, MonadFail)
46+
deriving newtype (Monad, Applicative, Functor, MonadIO, MonadFail)
4247

4348
data SRules = SRules {
4449
rulesExtra :: !Dynamic,
@@ -51,7 +56,7 @@ data SRules = SRules {
5156
-- ACTIONS
5257

5358
newtype Action a = Action {fromAction :: ReaderT SAction IO a}
54-
deriving (Monad, Applicative, Functor, MonadIO, MonadFail, MonadThrow, MonadCatch, MonadMask)
59+
deriving newtype (Monad, Applicative, Functor, MonadIO, MonadFail, MonadThrow, MonadCatch, MonadMask)
5560

5661
data SAction = SAction {
5762
actionDatabase :: !Database,
@@ -65,7 +70,7 @@ getDatabase = Action $ asks actionDatabase
6570
-- DATABASE
6671

6772
newtype Step = Step Int
68-
deriving (Eq,Ord,Hashable)
73+
deriving newtype (Eq,Ord,Hashable)
6974

7075
data Key = forall a . (Typeable a, Eq a, Hashable a, Show a) => Key a
7176

@@ -151,7 +156,8 @@ data RunChanged
151156
| ChangedStore -- ^ The stored value has changed, but in a way that should be considered identical (used rarely).
152157
| ChangedRecomputeSame -- ^ I recomputed the value and it was the same.
153158
| ChangedRecomputeDiff -- ^ I recomputed the value and it was different.
154-
deriving (Eq,Show)
159+
deriving (Eq,Show,Generic)
160+
deriving anyclass (FromJSON, ToJSON)
155161

156162
instance NFData RunChanged where rnf x = x `seq` ()
157163

0 commit comments

Comments
 (0)