Skip to content

Commit aea4709

Browse files
wz1000wz1000
committed
Implement sharing of module graphs
1 parent 267686b commit aea4709

File tree

5 files changed

+103
-82
lines changed

5 files changed

+103
-82
lines changed

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

Lines changed: 28 additions & 39 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
@@ -1466,8 +1447,8 @@ loadInterface session ms linkableNeeded RecompilationInfo{..} = do
14661447
Just (old_hir, _)
14671448
| isNothing linkableNeeded || isJust (hirCoreFp old_hir)
14681449
-> do
1469-
-- Perform the fine grained recompilation check for TH
1470-
maybe_recomp <- checkLinkableDependencies get_linkable_hashes (hsc_mod_graph sessionWithMsDynFlags) (hirRuntimeModules old_hir)
1450+
-- Peform the fine grained recompilation check for TH
1451+
maybe_recomp <- checkLinkableDependencies session get_linkable_hashes (hirRuntimeModules old_hir)
14711452
case maybe_recomp of
14721453
Just msg -> do_regenerate msg
14731454
Nothing -> return ([], Just old_hir)
@@ -1478,8 +1459,8 @@ loadInterface session ms linkableNeeded RecompilationInfo{..} = do
14781459
let runtime_deps
14791460
| not (mi_used_th iface) = emptyModuleEnv
14801461
| otherwise = parseRuntimeDeps (md_anns details)
1481-
-- Perform the fine grained recompilation check for TH
1482-
maybe_recomp <- checkLinkableDependencies get_linkable_hashes (hsc_mod_graph sessionWithMsDynFlags) runtime_deps
1462+
-- Peform the fine grained recompilation check for TH
1463+
maybe_recomp <- checkLinkableDependencies session get_linkable_hashes runtime_deps
14831464
case maybe_recomp of
14841465
Just msg -> do_regenerate msg
14851466
Nothing
@@ -1516,13 +1497,21 @@ parseRuntimeDeps anns = mkModuleEnv $ mapMaybe go anns
15161497
-- the runtime dependencies of the module, to check if any of them are out of date
15171498
-- Hopefully 'runtime_deps' will be empty if the module didn't actually use TH
15181499
-- See Note [Recompilation avoidance in the presence of TH]
1519-
checkLinkableDependencies :: MonadIO m => ([NormalizedFilePath] -> m [BS.ByteString]) -> ModuleGraph -> ModuleEnv BS.ByteString -> m (Maybe RecompileRequired)
1520-
checkLinkableDependencies get_linkable_hashes graph runtime_deps = do
1521-
let hs_files = mapM go (moduleEnvToList runtime_deps)
1522-
go (mod, hash) = do
1523-
ms <- mgLookupModule graph mod
1524-
let hs = fromJust $ ml_hs_file $ ms_location ms
1525-
pure (toNormalizedFilePath' hs, hash)
1500+
checkLinkableDependencies :: MonadIO m => HscEnv -> ([NormalizedFilePath] -> m [BS.ByteString]) -> ModuleEnv BS.ByteString -> m (Maybe RecompileRequired)
1501+
checkLinkableDependencies hsc_env get_linkable_hashes runtime_deps = do
1502+
#if MIN_VERSION_ghc(9,3,0)
1503+
moduleLocs <- liftIO $ readIORef (fcModuleCache $ hsc_FC hsc_env)
1504+
#else
1505+
moduleLocs <- liftIO $ readIORef (hsc_FC hsc_env)
1506+
#endif
1507+
let go (mod, hash) = do
1508+
ifr <- lookupInstalledModuleEnv moduleLocs $ Compat.installedModule (toUnitId $ moduleUnit mod) (moduleName mod)
1509+
case ifr of
1510+
InstalledFound loc _ -> do
1511+
hs <- ml_hs_file loc
1512+
pure (toNormalizedFilePath' hs,hash)
1513+
_ -> Nothing
1514+
hs_files = mapM go (moduleEnvToList runtime_deps)
15261515
case hs_files of
15271516
Nothing -> error "invalid module graph"
15281517
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, utcTimeToPOSIXSeconds)
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
@@ -417,17 +415,17 @@ type RawDepM a = StateT (RawDependencyInformation, IntMap ArtifactsLocation) Act
417415
execRawDepM :: Monad m => StateT (RawDependencyInformation, IntMap a1) m a2 -> m (RawDependencyInformation, IntMap a1)
418416
execRawDepM act =
419417
execStateT act
420-
( RawDependencyInformation IntMap.empty emptyPathIdMap IntMap.empty IntMap.empty
418+
( RawDependencyInformation IntMap.empty emptyPathIdMap IntMap.empty
421419
, IntMap.empty
422420
)
423421

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

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

790799
Just <$> liftIO (newHscEnvEqWithImportPaths (envImportPaths env) session' [])
791800

‎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.

0 commit comments

Comments
 (0)