Skip to content

Commit 9effc56

Browse files
wz1000mergify[bot]
wz1000
and
mergify[bot]
authored
Share ModuleGraphs for all files (#3232)
* Remove GetDependencyInformation in favour of GetModuleGraph. Computing and storing GetDependencyInformation for each file essentially individually means that we perform downsweep on each file individually, wasting a lot of work and using an excessive amount of memory to store all these duplicated graphs individually. However, we already have the `GetModuleGraph` rule, which we need to compute before compiling files any way due to being depended on by `NeedsCompilation`, which needs to know if any reverse dependencies of the module we are compiling requires TH, which meant that each file already depends on the results of downsweep for the whole project. Instead, we can compute the whole graph once when we execute the `GetModuleGraph` rule and even use this inside `HscEnv.hsc_mod_graph` to avoid reconstructing the `ModuleGraph` on each invocation of `GhcSessionDeps`. There may be concerns about excessive build churn due to any change to the result of `GetModuleGraph` invalidating the result of `GhcSessionDeps` too often, but note that this only happens when something in the header of a module changes, and this could be solved easily be re-introducing a version of `GetDependencyInformation` with early cutoff that essentially returns the result of `GetModuleGraph` but includes the hash of only the `ModSummary`s in the downward dependency closure of the file. * module graph early cutoff early cutoff for eval plugin * allow running benchmarks on examples generated via a script * Add new benchmarks to config * Allow pathToId to fail * Errors --------- Co-authored-by: mergify[bot] <37929162+mergify[bot]@users.noreply.github.com>
1 parent 202295b commit 9effc56

File tree

13 files changed

+363
-164
lines changed

13 files changed

+363
-164
lines changed

‎bench/MultiLayerModules.sh‎

Lines changed: 34 additions & 0 deletions
Original file line numberDiff line numberDiff line change
@@ -0,0 +1,34 @@
1+
#!/usr/bin/env bash
2+
# Generate $DEPTH layers of modules with $WIDTH modules on each layer
3+
# Every module on layer N imports all the modules on layer N-1
4+
# MultiLayerModules.hs imports all the modules from the last layer
5+
DEPTH=15
6+
WIDTH=40
7+
cat >hie.yaml << EOF
8+
cradle:
9+
direct:
10+
arguments:
11+
EOF
12+
for i in $(seq -w 1 $WIDTH); do
13+
echo "module DummyLevel0M$i where" > DummyLevel0M$i.hs;
14+
echo " - DummyLevel0M$i.hs" >> hie.yaml;
15+
done
16+
for l in $(seq 1 $DEPTH); do
17+
for i in $(seq -w 1 $WIDTH); do
18+
echo "module DummyLevel${l}M$i where" > DummyLevel${l}M$i.hs;
19+
echo " - DummyLevel${l}M$i.hs" >> hie.yaml;
20+
for j in $(seq -w 1 $WIDTH); do
21+
echo "import DummyLevel$((l-1))M$j" >> DummyLevel${l}M$i.hs;
22+
done
23+
done
24+
done
25+
case "$1" in
26+
'--th')
27+
echo "{-# LANGUAGE TemplateHaskell #-}" > MultiLayerModules.hs
28+
;;
29+
esac
30+
echo "module MultiLayerModules where" >> MultiLayerModules.hs
31+
echo " - MultiLayerModules.hs" >> hie.yaml;
32+
for j in $(seq -w 1 $WIDTH); do
33+
echo "import DummyLevel${DEPTH}M$j" >> MultiLayerModules.hs;
34+
done

‎bench/config.yaml‎

Lines changed: 45 additions & 0 deletions
Original file line numberDiff line numberDiff line change
@@ -33,6 +33,50 @@ examples:
3333
modules:
3434
- src/Language/LSP/Types/WatchedFiles.hs
3535
- src/Language/LSP/Types/CallHierarchy.hs
36+
37+
- name: MultiLayerModules
38+
path: bench/MultiLayerModules.sh
39+
script: True
40+
script-args: ["--th"]
41+
modules:
42+
- MultiLayerModules.hs
43+
- DummyLevel0M01.hs
44+
- DummyLevel1M01.hs
45+
- name: MultiLayerModulesNoTH
46+
path: bench/MultiLayerModules.sh
47+
script: True
48+
script-args: []
49+
modules:
50+
- MultiLayerModules.hs
51+
- DummyLevel0M01.hs
52+
- DummyLevel1M01.hs
53+
54+
- name: DummyLevel0M01
55+
path: bench/MultiLayerModules.sh
56+
script: True
57+
script-args: ["--th"]
58+
modules:
59+
- DummyLevel0M01.hs
60+
- name: DummyLevel0M01NoTH
61+
path: bench/MultiLayerModules.sh
62+
script: True
63+
script-args: []
64+
modules:
65+
- DummyLevel0M01.hs
66+
67+
- name: DummyLevel1M01
68+
path: bench/MultiLayerModules.sh
69+
script: True
70+
script-args: ["--th"]
71+
modules:
72+
- DummyLevel1M01.hs
73+
- name: DummyLevel1M01NoTH
74+
path: bench/MultiLayerModules.sh
75+
script: True
76+
script-args: []
77+
modules:
78+
- DummyLevel1M01.hs
79+
3680
# Small but heavily multi-component example
3781
# Disabled as it is far to slow. hie-bios >0.7.2 should help
3882
# - name: HLS
@@ -47,6 +91,7 @@ examples:
4791

4892
# The set of experiments to execute
4993
experiments:
94+
- "edit-header"
5095
- "edit"
5196
- "hover"
5297
- "hover after edit"

‎ghcide-bench/src/Experiments.hs‎

Lines changed: 44 additions & 12 deletions
Original file line numberDiff line numberDiff line change
@@ -79,6 +79,12 @@ charEdit p =
7979
.+ #rangeLength .== Nothing
8080
.+ #text .== "a"
8181

82+
headerEdit :: TextDocumentContentChangeEvent
83+
headerEdit =
84+
TextDocumentContentChangeEvent $ InL $ #range .== Range (Position 0 0) (Position 0 0)
85+
.+ #rangeLength .== Nothing
86+
.+ #text .== "-- header comment \n"
87+
8288
data DocumentPositions = DocumentPositions {
8389
-- | A position that can be used to generate non null goto-def and completion responses
8490
identifierP :: Maybe Position,
@@ -112,6 +118,16 @@ experiments =
112118
waitForProgressDone
113119
return True,
114120
---------------------------------------------------------------------------------------
121+
bench "edit-header" $ \docs -> do
122+
forM_ docs $ \DocumentPositions{..} -> do
123+
changeDoc doc [headerEdit]
124+
-- wait for a fresh build start
125+
waitForProgressStart
126+
-- wait for the build to be finished
127+
output "edit: waitForProgressDone"
128+
waitForProgressDone
129+
return True,
130+
---------------------------------------------------------------------------------------
115131
bench "hover after edit" $ \docs -> do
116132
forM_ docs $ \DocumentPositions{..} ->
117133
changeDoc doc [charEdit stringLiteralP]
@@ -276,23 +292,26 @@ configP =
276292
<*> optional (option auto (long "samples" <> metavar "NAT" <> help "override sampling count"))
277293
<*> strOption (long "ghcide" <> metavar "PATH" <> help "path to ghcide" <> value "ghcide")
278294
<*> option auto (long "timeout" <> value 60 <> help "timeout for waiting for a ghcide response")
279-
<*> ( Example "name"
280-
<$> (Right <$> packageP)
295+
<*> ( Example
296+
<$> exampleName
297+
<*> (ExampleHackage <$> packageP)
281298
<*> (some moduleOption <|> pure ["src/Distribution/Simple.hs"])
282299
<*> pure []
283-
<|>
284-
Example "name"
285-
<$> (Left <$> pathP)
286-
<*> some moduleOption
287-
<*> pure [])
300+
<|> Example
301+
<$> exampleName
302+
<*> pathOrScriptP
303+
<*> some moduleOption
304+
<*> pure [])
288305
<*> switch (long "lsp-config" <> help "Read an LSP config payload from standard input")
289306
where
290307
moduleOption = strOption (long "example-module" <> metavar "PATH")
308+
exampleName = strOption (long "example-name" <> metavar "NAME")
291309

292310
packageP = ExamplePackage
293311
<$> strOption (long "example-package-name" <> value "Cabal")
294312
<*> option versionP (long "example-package-version" <> value (makeVersion [3,6,0,0]))
295-
pathP = strOption (long "example-path")
313+
pathOrScriptP = ExamplePath <$> strOption (long "example-path")
314+
<|> ExampleScript <$> strOption (long "example-script") <*> many (strOption (long "example-script-args" <> help "arguments for the example generation script"))
296315

297316
versionP :: ReadM Version
298317
versionP = maybeReader $ extract . readP_to_S parseVersion
@@ -581,13 +600,25 @@ setup :: HasConfig => IO SetupResult
581600
setup = do
582601
-- when alreadyExists $ removeDirectoryRecursive examplesPath
583602
benchDir <- case exampleDetails(example ?config) of
584-
Left examplePath -> do
603+
ExamplePath examplePath -> do
585604
let hieYamlPath = examplePath </> "hie.yaml"
586605
alreadyExists <- doesFileExist hieYamlPath
587606
unless alreadyExists $
588607
cmd_ (Cwd examplePath) (FileStdout hieYamlPath) ("gen-hie"::String)
589608
return examplePath
590-
Right ExamplePackage{..} -> do
609+
ExampleScript examplePath' scriptArgs -> do
610+
let exampleDir = examplesPath </> exampleName (example ?config)
611+
alreadySetup <- doesDirectoryExist exampleDir
612+
unless alreadySetup $ do
613+
createDirectoryIfMissing True exampleDir
614+
examplePath <- makeAbsolute examplePath'
615+
cmd_ (Cwd exampleDir) examplePath scriptArgs
616+
let hieYamlPath = exampleDir </> "hie.yaml"
617+
alreadyExists <- doesFileExist hieYamlPath
618+
unless alreadyExists $
619+
cmd_ (Cwd exampleDir) (FileStdout hieYamlPath) ("gen-hie"::String)
620+
return exampleDir
621+
ExampleHackage ExamplePackage{..} -> do
591622
let path = examplesPath </> package
592623
package = packageName <> "-" <> showVersion packageVersion
593624
hieYamlPath = path </> "hie.yaml"
@@ -633,8 +664,9 @@ setup = do
633664
whenJust (shakeProfiling ?config) $ createDirectoryIfMissing True
634665

635666
let cleanUp = case exampleDetails(example ?config) of
636-
Right _ -> removeDirectoryRecursive examplesPath
637-
Left _ -> return ()
667+
ExampleHackage _ -> removeDirectoryRecursive examplesPath
668+
ExampleScript _ _ -> removeDirectoryRecursive examplesPath
669+
ExamplePath _ -> return ()
638670

639671
runBenchmarks = runBenchmarksFun benchDir
640672

‎ghcide-bench/src/Experiments/Types.hs‎

Lines changed: 28 additions & 5 deletions
Original file line numberDiff line numberDiff line change
@@ -40,12 +40,20 @@ data ExamplePackage = ExamplePackage {packageName :: !String, packageVersion ::
4040

4141
data Example = Example
4242
{ exampleName :: !String
43-
, exampleDetails :: Either FilePath ExamplePackage
43+
, exampleDetails :: ExampleDetails
4444
, exampleModules :: [FilePath]
4545
, exampleExtraArgs :: [String]}
4646
deriving (Eq, Generic, Show)
4747
deriving anyclass (Binary, Hashable, NFData)
4848

49+
data ExampleDetails
50+
= ExamplePath FilePath -- ^ directory where the package is located
51+
| ExampleHackage ExamplePackage -- ^ package from hackage
52+
| ExampleScript FilePath -- ^ location of the script we are running
53+
[String] -- ^ extra arguments for the script
54+
deriving (Eq, Generic, Show)
55+
deriving anyclass (Binary, Hashable, NFData)
56+
4957
instance FromJSON Example where
5058
parseJSON = withObject "example" $ \x -> do
5159
exampleName <- x .: "name"
@@ -55,24 +63,39 @@ instance FromJSON Example where
5563
path <- x .:? "path"
5664
case path of
5765
Just examplePath -> do
58-
let exampleDetails = Left examplePath
66+
script <- fromMaybe False <$> x.:? "script"
67+
args <- fromMaybe [] <$> x .:? "script-args"
68+
let exampleDetails
69+
| script = ExampleScript examplePath args
70+
| otherwise = ExamplePath examplePath
5971
return Example{..}
6072
Nothing -> do
6173
packageName <- x .: "package"
6274
packageVersion <- x .: "version"
63-
let exampleDetails = Right ExamplePackage{..}
75+
let exampleDetails = ExampleHackage ExamplePackage{..}
6476
return Example{..}
6577

6678
exampleToOptions :: Example -> [String] -> [String]
67-
exampleToOptions Example{exampleDetails = Right ExamplePackage{..}, ..} extraArgs =
79+
exampleToOptions Example{exampleDetails = ExampleHackage ExamplePackage{..}, ..} extraArgs =
6880
["--example-package-name", packageName
6981
,"--example-package-version", showVersion packageVersion
82+
,"--example-name", exampleName
7083
] ++
7184
["--example-module=" <> m | m <- exampleModules
7285
] ++
7386
["--ghcide-options=" <> o | o <- exampleExtraArgs ++ extraArgs]
74-
exampleToOptions Example{exampleDetails = Left examplePath, ..} extraArgs =
87+
exampleToOptions Example{exampleDetails = ExamplePath examplePath, ..} extraArgs =
7588
["--example-path", examplePath
89+
,"--example-name", exampleName
90+
] ++
91+
["--example-module=" <> m | m <- exampleModules
92+
] ++
93+
["--ghcide-options=" <> o | o <- exampleExtraArgs ++ extraArgs]
94+
exampleToOptions Example{exampleDetails = ExampleScript examplePath exampleArgs, ..} extraArgs =
95+
["--example-script", examplePath
96+
,"--example-name", exampleName
97+
] ++
98+
["--example-script-args=" <> o | o <- exampleArgs
7699
] ++
77100
["--example-module=" <> m | m <- exampleModules
78101
] ++

‎ghcide/src/Development/IDE/Core/Compile.hs‎

Lines changed: 26 additions & 37 deletions
Original file line numberDiff line numberDiff line change
@@ -137,6 +137,7 @@ import GHC (Anchor (anchor),
137137
import qualified GHC as G
138138
import GHC.Hs (LEpaComment)
139139
import qualified GHC.Types.Error as Error
140+
import Development.IDE.Import.DependencyInformation
140141
#endif
141142

142143
#if MIN_VERSION_ghc(9,5,0)
@@ -1052,25 +1053,19 @@ handleGenerationErrors' dflags source action =
10521053
-- Add the current ModSummary to the graph, along with the
10531054
-- HomeModInfo's of all direct dependencies (by induction hypothesis all
10541055
-- transitive dependencies will be contained in envs)
1056+
mergeEnvs :: HscEnv -> ModuleGraph -> ModSummary -> [HomeModInfo] -> [HscEnv] -> IO HscEnv
1057+
mergeEnvs env mg ms extraMods envs = do
10551058
#if MIN_VERSION_ghc(9,3,0)
1056-
mergeEnvs :: HscEnv -> (ModSummary, [NodeKey]) -> [HomeModInfo] -> [HscEnv] -> IO HscEnv
1057-
mergeEnvs env (ms, deps) extraMods envs = do
10581059
let im = Compat.installedModule (toUnitId $ moduleUnit $ ms_mod ms) (moduleName (ms_mod ms))
10591060
ifr = InstalledFound (ms_location ms) im
10601061
curFinderCache = Compat.extendInstalledModuleEnv Compat.emptyInstalledModuleEnv im ifr
1061-
-- Very important to force this as otherwise the hsc_mod_graph field is not
1062-
-- forced and ends up retaining a reference to all the old hsc_envs we have merged to get
1063-
-- this new one, which in turn leads to the EPS referencing the HPT.
1064-
module_graph_nodes =
1065-
nubOrdOn mkNodeKey (ModuleNode deps ms : concatMap (mgModSummaries' . hsc_mod_graph) envs)
1066-
10671062
newFinderCache <- concatFC curFinderCache (map hsc_FC envs)
1068-
liftRnf rwhnf module_graph_nodes `seq` (return $ loadModulesHome extraMods $
1063+
return $! loadModulesHome extraMods $
10691064
let newHug = foldl' mergeHUG (hsc_HUG env) (map hsc_HUG envs) in
10701065
(hscUpdateHUG (const newHug) env){
10711066
hsc_FC = newFinderCache,
1072-
hsc_mod_graph = mkModuleGraph module_graph_nodes
1073-
})
1067+
hsc_mod_graph = mg
1068+
}
10741069

10751070
where
10761071
mergeHUG (UnitEnvGraph a) (UnitEnvGraph b) = UnitEnvGraph $ Map.unionWith mergeHUE a b
@@ -1096,30 +1091,16 @@ mergeEnvs env (ms, deps) extraMods envs = do
10961091
pure $ FinderCache fcModules' fcFiles'
10971092

10981093
#else
1099-
mergeEnvs :: HscEnv -> ModSummary -> [HomeModInfo] -> [HscEnv] -> IO HscEnv
1100-
mergeEnvs env ms extraMods envs = do
11011094
prevFinderCache <- concatFC <$> mapM (readIORef . hsc_FC) envs
11021095
let im = Compat.installedModule (toUnitId $ moduleUnit $ ms_mod ms) (moduleName (ms_mod ms))
11031096
ifr = InstalledFound (ms_location ms) im
1104-
-- Very important to force this as otherwise the hsc_mod_graph field is not
1105-
-- forced and ends up retaining a reference to all the old hsc_envs we have merged to get
1106-
-- this new one, which in turn leads to the EPS referencing the HPT.
1107-
module_graph_nodes =
1108-
#if MIN_VERSION_ghc(9,2,0)
1109-
-- We don't do any instantiation for backpack at this point of time, so it is OK to use
1110-
-- 'extendModSummaryNoDeps'.
1111-
-- This may have to change in the future.
1112-
map extendModSummaryNoDeps $
1113-
#endif
1114-
nubOrdOn ms_mod (ms : concatMap (mgModSummaries . hsc_mod_graph) envs)
1115-
11161097
newFinderCache <- newIORef $! Compat.extendInstalledModuleEnv prevFinderCache im ifr
1117-
liftRnf rwhnf module_graph_nodes `seq` (return $ loadModulesHome extraMods $
1098+
return $! loadModulesHome extraMods $
11181099
env{
11191100
hsc_HPT = foldMapBy mergeUDFM emptyUDFM hsc_HPT envs,
11201101
hsc_FC = newFinderCache,
1121-
hsc_mod_graph = mkModuleGraph module_graph_nodes
1122-
})
1102+
hsc_mod_graph = mg
1103+
}
11231104

11241105
where
11251106
mergeUDFM = plusUDFM_C combineModules
@@ -1534,8 +1515,8 @@ loadInterface session ms linkableNeeded RecompilationInfo{..} = do
15341515
let runtime_deps
15351516
| not (mi_used_th iface) = emptyModuleEnv
15361517
| otherwise = parseRuntimeDeps (md_anns details)
1537-
-- Perform the fine grained recompilation check for TH
1538-
maybe_recomp <- checkLinkableDependencies get_linkable_hashes (hsc_mod_graph sessionWithMsDynFlags) runtime_deps
1518+
-- Peform the fine grained recompilation check for TH
1519+
maybe_recomp <- checkLinkableDependencies session get_linkable_hashes runtime_deps
15391520
case maybe_recomp of
15401521
Just msg -> do_regenerate msg
15411522
Nothing
@@ -1572,13 +1553,21 @@ parseRuntimeDeps anns = mkModuleEnv $ mapMaybe go anns
15721553
-- the runtime dependencies of the module, to check if any of them are out of date
15731554
-- Hopefully 'runtime_deps' will be empty if the module didn't actually use TH
15741555
-- See Note [Recompilation avoidance in the presence of TH]
1575-
checkLinkableDependencies :: MonadIO m => ([NormalizedFilePath] -> m [BS.ByteString]) -> ModuleGraph -> ModuleEnv BS.ByteString -> m (Maybe RecompileRequired)
1576-
checkLinkableDependencies get_linkable_hashes graph runtime_deps = do
1577-
let hs_files = mapM go (moduleEnvToList runtime_deps)
1578-
go (mod, hash) = do
1579-
ms <- mgLookupModule graph mod
1580-
let hs = fromJust $ ml_hs_file $ ms_location ms
1581-
pure (toNormalizedFilePath' hs, hash)
1556+
checkLinkableDependencies :: MonadIO m => HscEnv -> ([NormalizedFilePath] -> m [BS.ByteString]) -> ModuleEnv BS.ByteString -> m (Maybe RecompileRequired)
1557+
checkLinkableDependencies hsc_env get_linkable_hashes runtime_deps = do
1558+
#if MIN_VERSION_ghc(9,3,0)
1559+
moduleLocs <- liftIO $ readIORef (fcModuleCache $ hsc_FC hsc_env)
1560+
#else
1561+
moduleLocs <- liftIO $ readIORef (hsc_FC hsc_env)
1562+
#endif
1563+
let go (mod, hash) = do
1564+
ifr <- lookupInstalledModuleEnv moduleLocs $ Compat.installedModule (toUnitId $ moduleUnit mod) (moduleName mod)
1565+
case ifr of
1566+
InstalledFound loc _ -> do
1567+
hs <- ml_hs_file loc
1568+
pure (toNormalizedFilePath' hs,hash)
1569+
_ -> Nothing
1570+
hs_files = mapM go (moduleEnvToList runtime_deps)
15821571
case hs_files of
15831572
Nothing -> error "invalid module graph"
15841573
Just fs -> do

0 commit comments

Comments
 (0)