Skip to content

Commit bca6e24

Browse files
wz1000wz1000
committed
Implement sharing of module graphs
1 parent dab3b7f commit bca6e24

File tree

5 files changed

+101
-80
lines changed

5 files changed

+101
-80
lines changed

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

Lines changed: 26 additions & 37 deletions
Original file line numberDiff line numberDiff line change
@@ -131,6 +131,7 @@ import GHC (Anchor (anchor),
131131
import qualified GHC as G
132132
import GHC.Hs (LEpaComment)
133133
import qualified GHC.Types.Error as Error
134+
import Development.IDE.Import.DependencyInformation
134135
#endif
135136

136137
-- | Given a string buffer, return the string (after preprocessing) and the 'ParsedModule'.
@@ -1012,25 +1013,19 @@ loadModulesHome mod_infos e =
10121013
-- Add the current ModSummary to the graph, along with the
10131014
-- HomeModInfo's of all direct dependencies (by induction hypothesis all
10141015
-- transitive dependencies will be contained in envs)
1016+
mergeEnvs :: HscEnv -> ModuleGraph -> ModSummary -> [HomeModInfo] -> [HscEnv] -> IO HscEnv
1017+
mergeEnvs env mg ms extraMods envs = do
10151018
#if MIN_VERSION_ghc(9,3,0)
1016-
mergeEnvs :: HscEnv -> (ModSummary, [NodeKey]) -> [HomeModInfo] -> [HscEnv] -> IO HscEnv
1017-
mergeEnvs env (ms, deps) extraMods envs = do
10181019
let im = Compat.installedModule (toUnitId $ moduleUnit $ ms_mod ms) (moduleName (ms_mod ms))
10191020
ifr = InstalledFound (ms_location ms) im
10201021
curFinderCache = Compat.extendInstalledModuleEnv Compat.emptyInstalledModuleEnv im ifr
1021-
-- Very important to force this as otherwise the hsc_mod_graph field is not
1022-
-- forced and ends up retaining a reference to all the old hsc_envs we have merged to get
1023-
-- this new one, which in turn leads to the EPS referencing the HPT.
1024-
module_graph_nodes =
1025-
nubOrdOn mkNodeKey (ModuleNode deps ms : concatMap (mgModSummaries' . hsc_mod_graph) envs)
1026-
10271022
newFinderCache <- concatFC curFinderCache (map hsc_FC envs)
1028-
liftRnf rwhnf module_graph_nodes `seq` (return $ loadModulesHome extraMods $
1023+
return $! loadModulesHome extraMods $
10291024
let newHug = foldl' mergeHUG (hsc_HUG env) (map hsc_HUG envs) in
10301025
(hscUpdateHUG (const newHug) env){
10311026
hsc_FC = newFinderCache,
1032-
hsc_mod_graph = mkModuleGraph module_graph_nodes
1033-
})
1027+
hsc_mod_graph = mg
1028+
}
10341029

10351030
where
10361031
mergeHUG (UnitEnvGraph a) (UnitEnvGraph b) = UnitEnvGraph $ Map.unionWith mergeHUE a b
@@ -1049,30 +1044,16 @@ mergeEnvs env (ms, deps) extraMods envs = do
10491044
pure $ FinderCache fcModules' fcFiles'
10501045

10511046
#else
1052-
mergeEnvs :: HscEnv -> ModSummary -> [HomeModInfo] -> [HscEnv] -> IO HscEnv
1053-
mergeEnvs env ms extraMods envs = do
10541047
prevFinderCache <- concatFC <$> mapM (readIORef . hsc_FC) envs
10551048
let im = Compat.installedModule (toUnitId $ moduleUnit $ ms_mod ms) (moduleName (ms_mod ms))
10561049
ifr = InstalledFound (ms_location ms) im
1057-
-- Very important to force this as otherwise the hsc_mod_graph field is not
1058-
-- forced and ends up retaining a reference to all the old hsc_envs we have merged to get
1059-
-- this new one, which in turn leads to the EPS referencing the HPT.
1060-
module_graph_nodes =
1061-
#if MIN_VERSION_ghc(9,2,0)
1062-
-- We don't do any instantiation for backpack at this point of time, so it is OK to use
1063-
-- 'extendModSummaryNoDeps'.
1064-
-- This may have to change in the future.
1065-
map extendModSummaryNoDeps $
1066-
#endif
1067-
nubOrdOn ms_mod (ms : concatMap (mgModSummaries . hsc_mod_graph) envs)
1068-
10691050
newFinderCache <- newIORef $! Compat.extendInstalledModuleEnv prevFinderCache im ifr
1070-
liftRnf rwhnf module_graph_nodes `seq` (return $ loadModulesHome extraMods $
1051+
return $! loadModulesHome extraMods $
10711052
env{
10721053
hsc_HPT = foldMapBy mergeUDFM emptyUDFM hsc_HPT envs,
10731054
hsc_FC = newFinderCache,
1074-
hsc_mod_graph = mkModuleGraph module_graph_nodes
1075-
})
1055+
hsc_mod_graph = mg
1056+
}
10761057

10771058
where
10781059
mergeUDFM = plusUDFM_C combineModules
@@ -1468,8 +1449,8 @@ loadInterface session ms linkableNeeded RecompilationInfo{..} = do
14681449
let runtime_deps
14691450
| not (mi_used_th iface) = emptyModuleEnv
14701451
| otherwise = parseRuntimeDeps (md_anns details)
1471-
-- Perform the fine grained recompilation check for TH
1472-
maybe_recomp <- checkLinkableDependencies get_linkable_hashes (hsc_mod_graph sessionWithMsDynFlags) runtime_deps
1452+
-- Peform the fine grained recompilation check for TH
1453+
maybe_recomp <- checkLinkableDependencies session get_linkable_hashes runtime_deps
14731454
case maybe_recomp of
14741455
Just msg -> do_regenerate msg
14751456
Nothing
@@ -1506,13 +1487,21 @@ parseRuntimeDeps anns = mkModuleEnv $ mapMaybe go anns
15061487
-- the runtime dependencies of the module, to check if any of them are out of date
15071488
-- Hopefully 'runtime_deps' will be empty if the module didn't actually use TH
15081489
-- See Note [Recompilation avoidance in the presence of TH]
1509-
checkLinkableDependencies :: MonadIO m => ([NormalizedFilePath] -> m [BS.ByteString]) -> ModuleGraph -> ModuleEnv BS.ByteString -> m (Maybe RecompileRequired)
1510-
checkLinkableDependencies get_linkable_hashes graph runtime_deps = do
1511-
let hs_files = mapM go (moduleEnvToList runtime_deps)
1512-
go (mod, hash) = do
1513-
ms <- mgLookupModule graph mod
1514-
let hs = fromJust $ ml_hs_file $ ms_location ms
1515-
pure (toNormalizedFilePath' hs, hash)
1490+
checkLinkableDependencies :: MonadIO m => HscEnv -> ([NormalizedFilePath] -> m [BS.ByteString]) -> ModuleEnv BS.ByteString -> m (Maybe RecompileRequired)
1491+
checkLinkableDependencies hsc_env get_linkable_hashes runtime_deps = do
1492+
#if MIN_VERSION_ghc(9,3,0)
1493+
moduleLocs <- liftIO $ readIORef (fcModuleCache $ hsc_FC hsc_env)
1494+
#else
1495+
moduleLocs <- liftIO $ readIORef (hsc_FC hsc_env)
1496+
#endif
1497+
let go (mod, hash) = do
1498+
ifr <- lookupInstalledModuleEnv moduleLocs $ Compat.installedModule (toUnitId $ moduleUnit mod) (moduleName mod)
1499+
case ifr of
1500+
InstalledFound loc _ -> do
1501+
hs <- ml_hs_file loc
1502+
pure (toNormalizedFilePath' hs,hash)
1503+
_ -> Nothing
1504+
hs_files = mapM go (moduleEnvToList runtime_deps)
15161505
case hs_files of
15171506
Nothing -> error "invalid module graph"
15181507
Just fs -> do

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

Lines changed: 37 additions & 28 deletions
Original file line numberDiff line numberDiff line change
@@ -14,6 +14,10 @@ module Development.IDE.Core.Rules(
1414
IdeState, GetParsedModule(..), TransitiveDependencies(..),
1515
Priority(..), GhcSessionIO(..), GetClientSettings(..),
1616
-- * Functions
17+
--
18+
--
19+
--
20+
--
1721
priorityTypeCheck,
1822
priorityGenerateCore,
1923
priorityFilesOfInterest,
@@ -23,7 +27,6 @@ module Development.IDE.Core.Rules(
2327
defineEarlyCutOffNoFile,
2428
mainRule,
2529
RulesConfig(..),
26-
getDependencies,
2730
getParsedModule,
2831
getParsedModuleWithComments,
2932
getClientConfigAction,
@@ -155,6 +158,7 @@ import qualified Development.IDE.Types.Shake as Shake
155158
import Development.IDE.GHC.CoreFile
156159
import Data.Time.Clock.POSIX (posixSecondsToUTCTime)
157160
import Control.Monad.IO.Unlift
161+
import qualified Data.IntMap as IM
158162
#if MIN_VERSION_ghc(9,3,0)
159163
import GHC.Unit.Module.Graph
160164
import GHC.Unit.Env
@@ -204,12 +208,6 @@ toIdeResult = either (, Nothing) (([],) . Just)
204208
------------------------------------------------------------
205209
-- Exposed API
206210
------------------------------------------------------------
207-
-- | Get all transitive file dependencies of a given module.
208-
-- Does not include the file itself.
209-
getDependencies :: NormalizedFilePath -> Action (Maybe [NormalizedFilePath])
210-
getDependencies file =
211-
fmap transitiveModuleDeps . (`transitiveDeps` file) <$> useNoFile_ GetModuleGraph
212-
213211
getSourceFileSource :: NormalizedFilePath -> Action BS.ByteString
214212
getSourceFileSource nfp = do
215213
(_, msource) <- getFileContents nfp
@@ -414,17 +412,17 @@ type RawDepM a = StateT (RawDependencyInformation, IntMap ArtifactsLocation) Act
414412
execRawDepM :: Monad m => StateT (RawDependencyInformation, IntMap a1) m a2 -> m (RawDependencyInformation, IntMap a1)
415413
execRawDepM act =
416414
execStateT act
417-
( RawDependencyInformation IntMap.empty emptyPathIdMap IntMap.empty IntMap.empty
415+
( RawDependencyInformation IntMap.empty emptyPathIdMap IntMap.empty
418416
, IntMap.empty
419417
)
420418

421419
-- | Given a target file path, construct the raw dependency results by following
422420
-- imports recursively.
423-
rawDependencyInformation :: [NormalizedFilePath] -> Action RawDependencyInformation
421+
rawDependencyInformation :: [NormalizedFilePath] -> Action (RawDependencyInformation, BootIdMap)
424422
rawDependencyInformation fs = do
425423
(rdi, ss) <- execRawDepM (goPlural fs)
426424
let bm = IntMap.foldrWithKey (updateBootMap rdi) IntMap.empty ss
427-
return (rdi { rawBootMap = bm })
425+
return (rdi, bm)
428426
where
429427
goPlural ff = do
430428
mss <- lift $ (fmap.fmap) msrModSummary <$> uses GetModSummaryWithoutTimestamps ff
@@ -443,9 +441,9 @@ rawDependencyInformation fs = do
443441
fId <- getFreshFid al
444442
-- Record this module and its location
445443
whenJust msum $ \ms ->
446-
modifyRawDepInfo (\rd -> rd { rawModuleNameMap = IntMap.insert (getFilePathId fId)
447-
(ShowableModuleName (moduleName $ ms_mod ms))
448-
(rawModuleNameMap rd)})
444+
modifyRawDepInfo (\rd -> rd { rawModuleMap = IntMap.insert (getFilePathId fId)
445+
(ShowableModule $ ms_mod ms)
446+
(rawModuleMap rd)})
449447
-- Adding an edge to the bootmap so we can make sure to
450448
-- insert boot nodes before the real files.
451449
addBootMap al fId
@@ -667,8 +665,30 @@ knownFilesRule recorder = defineEarlyCutOffNoFile (cmapWithPrio LogShake recorde
667665
getModuleGraphRule :: Recorder (WithPriority Log) -> Rules ()
668666
getModuleGraphRule recorder = defineNoFile (cmapWithPrio LogShake recorder) $ \GetModuleGraph -> do
669667
fs <- toKnownFiles <$> useNoFile_ GetKnownTargets
670-
rawDepInfo <- rawDependencyInformation (HashSet.toList fs)
671-
pure $ processDependencyInformation rawDepInfo
668+
(rawDepInfo, bm) <- rawDependencyInformation (HashSet.toList fs)
669+
let (all_fs, _all_ids) = unzip $ HM.toList $ pathToIdMap $ rawPathIdMap rawDepInfo
670+
mss <- map (fmap msrModSummary) <$> uses GetModSummaryWithoutTimestamps all_fs
671+
#if MIN_VERSION_ghc(9,3,0)
672+
let deps = map (\i -> IM.lookup (getFilePathId i) (rawImports rawDepInfo)) _all_ids
673+
nodeKeys = IM.fromList $ catMaybes $ zipWith (\fi mms -> (getFilePathId fi,) . NodeKey_Module . msKey <$> mms) _all_ids mss
674+
mns = catMaybes $ zipWith go mss deps
675+
go (Just ms) (Just (Right (ModuleImports xs))) = Just $ ModuleNode this_dep_keys ms
676+
where this_dep_ids = mapMaybe snd xs
677+
this_dep_keys = mapMaybe (\fi -> IM.lookup (getFilePathId fi) nodeKeys) this_dep_ids
678+
go (Just ms) _ = Just $ ModuleNode [] ms
679+
go _ _ = Nothing
680+
mg = mkModuleGraph mns
681+
#else
682+
let mg = mkModuleGraph $
683+
#if MIN_VERSION_ghc(9,2,0)
684+
-- We don't do any instantiation for backpack at this point of time, so it is OK to use
685+
-- 'extendModSummaryNoDeps'.
686+
-- This may have to change in the future.
687+
map extendModSummaryNoDeps $
688+
#endif
689+
(catMaybes mss)
690+
#endif
691+
pure $ processDependencyInformation rawDepInfo bm mg
672692

673693
-- This is factored out so it can be directly called from the GetModIface
674694
-- rule. Directly calling this rule means that on the initial load we can
@@ -769,19 +789,8 @@ ghcSessionDepsDefinition fullModSummary GhcSessionDepsConfig{..} env file = do
769789
depSessions <- map hscEnv <$> uses_ (GhcSessionDeps_ fullModSummary) deps
770790
ifaces <- uses_ GetModIface deps
771791
let inLoadOrder = map (\HiFileResult{..} -> HomeModInfo hirModIface hirModDetails Nothing) ifaces
772-
#if MIN_VERSION_ghc(9,3,0)
773-
-- On GHC 9.4+, the module graph contains not only ModSummary's but each `ModuleNode` in the graph
774-
-- also points to all the direct descendants of the current module. To get the keys for the descendants
775-
-- we must get their `ModSummary`s
776-
!final_deps <- do
777-
dep_mss <- map msrModSummary <$> uses_ GetModSummaryWithoutTimestamps deps
778-
-- Don't want to retain references to the entire ModSummary when just the key will do
779-
return $!! map (NodeKey_Module . msKey) dep_mss
780-
let moduleNode = (ms, final_deps)
781-
#else
782-
let moduleNode = ms
783-
#endif
784-
session' <- liftIO $ mergeEnvs hsc moduleNode inLoadOrder depSessions
792+
mg <- depModuleGraph <$> useNoFile_ GetModuleGraph
793+
session' <- liftIO $ mergeEnvs hsc mg ms inLoadOrder depSessions
785794

786795
Just <$> liftIO (newHscEnvEqWithImportPaths (envImportPaths env) session' [])
787796

‎ghcide/src/Development/IDE/GHC/Orphans.hs

Lines changed: 4 additions & 0 deletions
Original file line numberDiff line numberDiff line change
@@ -40,6 +40,7 @@ import Data.String (IsString (fromString))
4040
import Data.Text (unpack)
4141
#if MIN_VERSION_ghc(9,0,0)
4242
import GHC.ByteCode.Types
43+
import GHC (ModuleGraph)
4344
#else
4445
import ByteCodeTypes
4546
#endif
@@ -207,6 +208,9 @@ instance Hashable OccName where hashWithSalt s n = hashWithSalt s (getKey $ getU
207208

208209
instance Show HomeModInfo where show = show . mi_module . hm_iface
209210

211+
instance Show ModuleGraph where show _ = "ModuleGraph {..}"
212+
instance NFData ModuleGraph where rnf = rwhnf
213+
210214
instance NFData HomeModInfo where
211215
rnf (HomeModInfo iface dets link) = rwhnf iface `seq` rnf dets `seq` rnf link
212216

‎ghcide/src/Development/IDE/Import/DependencyInformation.hs

Lines changed: 31 additions & 12 deletions
Original file line numberDiff line numberDiff line change
@@ -10,8 +10,9 @@ module Development.IDE.Import.DependencyInformation
1010
, TransitiveDependencies(..)
1111
, FilePathId(..)
1212
, NamedModuleDep(..)
13-
, ShowableModuleName(..)
14-
, PathIdMap
13+
, ShowableModule(..)
14+
, ShowableModuleEnv(..)
15+
, PathIdMap (..)
1516
, emptyPathIdMap
1617
, getPathId
1718
, lookupPathToId
@@ -23,7 +24,7 @@ module Development.IDE.Import.DependencyInformation
2324
, transitiveDeps
2425
, transitiveReverseDependencies
2526
, immediateReverseDependencies
26-
27+
, lookupModuleFile
2728
, BootIdMap
2829
, insertBootId
2930
) where
@@ -53,6 +54,7 @@ import Development.IDE.Types.Diagnostics
5354
import Development.IDE.Types.Location
5455

5556
import GHC
57+
import Development.IDE.GHC.Compat
5658

5759
-- | The imports for a given module.
5860
newtype ModuleImports = ModuleImports
@@ -128,15 +130,14 @@ data RawDependencyInformation = RawDependencyInformation
128130
-- corresponding hs file. It is used when topologically sorting as we
129131
-- need to add edges between .hs-boot and .hs so that the .hs files
130132
-- appear later in the sort.
131-
, rawBootMap :: !BootIdMap
132-
, rawModuleNameMap :: !(FilePathIdMap ShowableModuleName)
133+
, rawModuleMap :: !(FilePathIdMap ShowableModule)
133134
} deriving Show
134135

135136
data DependencyInformation =
136137
DependencyInformation
137138
{ depErrorNodes :: !(FilePathIdMap (NonEmpty NodeError))
138139
-- ^ Nodes that cannot be processed correctly.
139-
, depModuleNames :: !(FilePathIdMap ShowableModuleName)
140+
, depModules :: !(FilePathIdMap ShowableModule)
140141
, depModuleDeps :: !(FilePathIdMap FilePathIdSet)
141142
-- ^ For a non-error node, this contains the set of module immediate dependencies
142143
-- in the same package.
@@ -146,13 +147,24 @@ data DependencyInformation =
146147
-- ^ Map from FilePath to FilePathId
147148
, depBootMap :: !BootIdMap
148149
-- ^ Map from hs-boot file to the corresponding hs file
150+
, depModuleFiles :: !(ShowableModuleEnv FilePathId)
151+
-- ^ Map from Module to the corresponding non-boot hs file
152+
, depModuleGraph :: !ModuleGraph
149153
} deriving (Show, Generic)
150154

151-
newtype ShowableModuleName =
152-
ShowableModuleName {showableModuleName :: ModuleName}
155+
newtype ShowableModule =
156+
ShowableModule {showableModule :: Module}
153157
deriving NFData
154158

155-
instance Show ShowableModuleName where show = moduleNameString . showableModuleName
159+
newtype ShowableModuleEnv a =
160+
ShowableModuleEnv {showableModuleEnv :: ModuleEnv a}
161+
162+
instance Show a => Show (ShowableModuleEnv a) where
163+
show (ShowableModuleEnv x) = show (moduleEnvToList x)
164+
instance NFData a => NFData (ShowableModuleEnv a) where
165+
rnf = rwhnf
166+
167+
instance Show ShowableModule where show = moduleNameString . moduleName . showableModule
156168

157169
reachableModules :: DependencyInformation -> [NormalizedFilePath]
158170
reachableModules DependencyInformation{..} =
@@ -215,15 +227,17 @@ instance Semigroup NodeResult where
215227
SuccessNode _ <> ErrorNode errs = ErrorNode errs
216228
SuccessNode a <> SuccessNode _ = SuccessNode a
217229

218-
processDependencyInformation :: RawDependencyInformation -> DependencyInformation
219-
processDependencyInformation RawDependencyInformation{..} =
230+
processDependencyInformation :: RawDependencyInformation -> BootIdMap -> ModuleGraph -> DependencyInformation
231+
processDependencyInformation RawDependencyInformation{..} rawBootMap mg =
220232
DependencyInformation
221233
{ depErrorNodes = IntMap.fromList errorNodes
222234
, depModuleDeps = moduleDeps
223235
, depReverseModuleDeps = reverseModuleDeps
224-
, depModuleNames = rawModuleNameMap
236+
, depModules = rawModuleMap
225237
, depPathIdMap = rawPathIdMap
226238
, depBootMap = rawBootMap
239+
, depModuleFiles = ShowableModuleEnv reverseModuleMap
240+
, depModuleGraph = mg
227241
}
228242
where resultGraph = buildResultGraph rawImports
229243
(errorNodes, successNodes) = partitionNodeResults $ IntMap.toList resultGraph
@@ -240,6 +254,7 @@ processDependencyInformation RawDependencyInformation{..} =
240254
foldr (\(p, cs) res ->
241255
let new = IntMap.fromList (map (, IntSet.singleton (coerce p)) (coerce cs))
242256
in IntMap.unionWith IntSet.union new res ) IntMap.empty successEdges
257+
reverseModuleMap = mkModuleEnv $ map (\(i,sm) -> (showableModule sm, FilePathId i)) $ IntMap.toList rawModuleMap
243258

244259

245260
-- | Given a dependency graph, buildResultGraph detects and propagates errors in that graph as follows:
@@ -351,6 +366,10 @@ transitiveDeps DependencyInformation{..} file = do
351366

352367
vs = topSort g
353368

369+
lookupModuleFile :: Module -> DependencyInformation -> Maybe NormalizedFilePath
370+
lookupModuleFile mod DependencyInformation{..}
371+
= idToPath depPathIdMap <$> lookupModuleEnv (showableModuleEnv depModuleFiles) mod
372+
354373
newtype TransitiveDependencies = TransitiveDependencies
355374
{ transitiveModuleDeps :: [NormalizedFilePath]
356375
-- ^ Transitive module dependencies in topological order.

‎plugins/hls-eval-plugin/src/Ide/Plugin/Eval/CodeLens.hs

Lines changed: 3 additions & 3 deletions
Original file line numberDiff line numberDiff line change
@@ -75,7 +75,7 @@ import qualified Development.IDE.GHC.Compat as Compat
7575
import qualified Development.IDE.GHC.Compat as SrcLoc
7676
import Development.IDE.GHC.Compat.Util (GhcException,
7777
OverridingBool (..))
78-
import Development.IDE.Import.DependencyInformation (reachableModules)
78+
import Development.IDE.Import.DependencyInformation (transitiveDeps, transitiveModuleDeps)
7979
import Development.IDE.Types.Options
8080
import GHC (ClsInst,
8181
ExecOptions (execLineNumber, execSourceFile),
@@ -324,8 +324,8 @@ runEvalCmd plId st EvalParams{..} =
324324
-- This can be optimised to only get the linkables for the symbols depended on by
325325
-- the statement we are parsing
326326
lbs <- liftIO $ runAction "eval: GetLinkables" st $ do
327-
linkables_needed <- reachableModules <$> useNoFile_ GetModuleGraph
328-
uses_ GetLinkable (filter (/= nfp) linkables_needed) -- We don't need the linkable for the current module
327+
linkables_needed <- transitiveDeps <$> useNoFile_ GetModuleGraph <*> pure nfp
328+
uses_ GetLinkable (maybe [] transitiveModuleDeps linkables_needed) -- We don't need the linkable for the current module
329329
let hscEnv'' = hscEnv' { hsc_HPT = addListToHpt (hsc_HPT hscEnv') [(moduleName $ mi_module $ hm_iface hm, hm) | lb <- lbs, let hm = linkableHomeMod lb] }
330330

331331
edits <-

0 commit comments

Comments
 (0)