Matthew Pickering pushed to branch wip/module_graph_mode at Glasgow Haskell Compiler / GHC
Commits:
-
f834b604
by Matthew Pickering at 2025-06-23T08:14:57+01:00
12 changed files:
- compiler/GHC.hs
- compiler/GHC/Core/Opt/Pipeline.hs
- compiler/GHC/Driver/Backpack.hs
- compiler/GHC/Driver/Env.hs
- compiler/GHC/Driver/Env/Types.hs
- compiler/GHC/Driver/Main.hs
- compiler/GHC/Driver/Make.hs
- compiler/GHC/Driver/Pipeline/Execute.hs
- compiler/GHC/Iface/Load.hs
- compiler/GHC/Tc/Module.hs
- compiler/GHC/Unit/Env.hs
- ghc/GHCi/UI.hs
Changes:
... | ... | @@ -859,6 +859,7 @@ setProgramDynFlags_ invalidate_needed dflags = do |
859 | 859 | , ue_namever = ghcNameVersion dflags1
|
860 | 860 | , ue_home_unit_graph = home_unit_graph
|
861 | 861 | , ue_current_unit = ue_currentUnit old_unit_env
|
862 | + , ue_module_graph = ue_module_graph old_unit_env
|
|
862 | 863 | , ue_eps = ue_eps old_unit_env
|
863 | 864 | }
|
864 | 865 | modifySession $ \h -> hscSetFlags dflags1 h{ hsc_unit_env = unit_env }
|
... | ... | @@ -916,6 +917,7 @@ setProgramHUG_ invalidate_needed new_hug0 = do |
916 | 917 | , ue_home_unit_graph = home_unit_graph
|
917 | 918 | , ue_current_unit = ue_currentUnit unit_env0
|
918 | 919 | , ue_eps = ue_eps unit_env0
|
920 | + , ue_module_graph = ue_module_graph unit_env0
|
|
919 | 921 | }
|
920 | 922 | modifySession $ \h ->
|
921 | 923 | -- hscSetFlags takes care of updating the logger as well.
|
... | ... | @@ -996,7 +998,7 @@ setProgramHUG_ invalidate_needed new_hug0 = do |
996 | 998 | --
|
997 | 999 | invalidateModSummaryCache :: GhcMonad m => m ()
|
998 | 1000 | invalidateModSummaryCache =
|
999 | - modifySession $ \h -> h { hsc_mod_graph = mapMG inval (hsc_mod_graph h) }
|
|
1001 | + modifySession $ \hsc_env -> setModuleGraph (mapMG inval (hsc_mod_graph hsc_env)) hsc_env
|
|
1000 | 1002 | where
|
1001 | 1003 | inval ms = ms { ms_hs_hash = fingerprint0 }
|
1002 | 1004 |
... | ... | @@ -97,10 +97,11 @@ core2core hsc_env guts@(ModGuts { mg_module = mod |
97 | 97 | where
|
98 | 98 | dflags = hsc_dflags hsc_env
|
99 | 99 | logger = hsc_logger hsc_env
|
100 | + unit_env = hsc_unit_env hsc_env
|
|
100 | 101 | extra_vars = interactiveInScope (hsc_IC hsc_env)
|
101 | 102 | home_pkg_rules = hugRulesBelow hsc_env (moduleUnitId mod)
|
102 | 103 | (GWIB { gwib_mod = moduleName mod, gwib_isBoot = NotBoot })
|
103 | - name_ppr_ctx = mkNamePprCtx ptc (hsc_unit_env hsc_env) rdr_env
|
|
104 | + name_ppr_ctx = mkNamePprCtx ptc unit_env rdr_env
|
|
104 | 105 | ptc = initPromotionTickContext dflags
|
105 | 106 | -- mod: get the module out of the current HscEnv so we can retrieve it from the monad.
|
106 | 107 | -- This is very convienent for the users of the monad (e.g. plugins do not have to
|
... | ... | @@ -457,6 +457,7 @@ addUnit u = do |
457 | 457 | (homeUnitId home_unit)
|
458 | 458 | (HUG.mkHomeUnitEnv unit_state (Just dbs) dflags (ue_hpt old_unit_env) (Just home_unit))
|
459 | 459 | , ue_eps = ue_eps old_unit_env
|
460 | + , ue_module_graph = ue_module_graph old_unit_env
|
|
460 | 461 | }
|
461 | 462 | setSession $ hscSetFlags dflags $ hsc_env { hsc_unit_env = unit_env }
|
462 | 463 |
... | ... | @@ -2,6 +2,8 @@ |
2 | 2 | module GHC.Driver.Env
|
3 | 3 | ( Hsc(..)
|
4 | 4 | , HscEnv (..)
|
5 | + , hsc_mod_graph
|
|
6 | + , setModuleGraph
|
|
5 | 7 | , hscUpdateFlags
|
6 | 8 | , hscSetFlags
|
7 | 9 | , hsc_home_unit
|
... | ... | @@ -130,6 +132,9 @@ hsc_HUE = ue_currentHomeUnitEnv . hsc_unit_env |
130 | 132 | hsc_HUG :: HscEnv -> HomeUnitGraph
|
131 | 133 | hsc_HUG = ue_home_unit_graph . hsc_unit_env
|
132 | 134 | |
135 | +hsc_mod_graph :: HscEnv -> ModuleGraph
|
|
136 | +hsc_mod_graph = ue_module_graph . hsc_unit_env
|
|
137 | + |
|
133 | 138 | hsc_all_home_unit_ids :: HscEnv -> Set.Set UnitId
|
134 | 139 | hsc_all_home_unit_ids = HUG.allUnits . hsc_HUG
|
135 | 140 | |
... | ... | @@ -139,6 +144,9 @@ hscInsertHPT hmi hsc_env = UnitEnv.insertHpt hmi (hsc_unit_env hsc_env) |
139 | 144 | hscUpdateHUG :: (HomeUnitGraph -> HomeUnitGraph) -> HscEnv -> HscEnv
|
140 | 145 | hscUpdateHUG f hsc_env = hsc_env { hsc_unit_env = updateHug f (hsc_unit_env hsc_env) }
|
141 | 146 | |
147 | +setModuleGraph :: ModuleGraph -> HscEnv -> HscEnv
|
|
148 | +setModuleGraph mod_graph hsc_env = hsc_env { hsc_unit_env = (hsc_unit_env hsc_env) { ue_module_graph = mod_graph } }
|
|
149 | + |
|
142 | 150 | {-
|
143 | 151 | |
144 | 152 | Note [Target code interpreter]
|
... | ... | @@ -220,15 +228,15 @@ hscEPS hsc_env = readIORef (euc_eps (ue_eps (hsc_unit_env hsc_env))) |
220 | 228 | -- | Find all rules in modules that are in the transitive closure of the given
|
221 | 229 | -- module.
|
222 | 230 | hugRulesBelow :: HscEnv -> UnitId -> ModuleNameWithIsBoot -> IO RuleBase
|
223 | -hugRulesBelow hsc uid mn = foldr (flip extendRuleBaseList) emptyRuleBase <$>
|
|
224 | - hugSomeThingsBelowUs (md_rules . hm_details) False hsc uid mn
|
|
231 | +hugRulesBelow hsc_env uid mn = foldr (flip extendRuleBaseList) emptyRuleBase <$>
|
|
232 | + hugSomeThingsBelowUs (md_rules . hm_details) False hsc_env uid mn
|
|
225 | 233 | |
226 | 234 | -- | Get annotations from all modules "below" this one (in the dependency
|
227 | 235 | -- sense) within the home units. If the module is @Nothing@, returns /all/
|
228 | 236 | -- annotations in the home units.
|
229 | 237 | hugAnnsBelow :: HscEnv -> UnitId -> ModuleNameWithIsBoot -> IO AnnEnv
|
230 | -hugAnnsBelow hsc uid mn = foldr (flip extendAnnEnvList) emptyAnnEnv <$>
|
|
231 | - hugSomeThingsBelowUs (md_anns . hm_details) False hsc uid mn
|
|
238 | +hugAnnsBelow hsc_env uid mn = foldr (flip extendAnnEnvList) emptyAnnEnv <$>
|
|
239 | + hugSomeThingsBelowUs (md_anns . hm_details) False hsc_env uid mn
|
|
232 | 240 | |
233 | 241 | -- | Find all COMPLETE pragmas in modules that are in the transitive closure of the
|
234 | 242 | -- given module.
|
... | ... | @@ -260,7 +268,8 @@ hugInstancesBelow hsc_env uid mnwib = do |
260 | 268 | hugSomeThingsBelowUs :: (HomeModInfo -> [a]) -> Bool -> HscEnv -> UnitId -> ModuleNameWithIsBoot -> IO [[a]]
|
261 | 269 | -- An explicit check to see if we are in one-shot mode to avoid poking the ModuleGraph thunk
|
262 | 270 | -- These things are currently stored in the EPS for home packages. (See #25795 for
|
263 | --- progress in removing these kind of checks)
|
|
271 | +-- progress in removing these kind of checks; and making these functions of
|
|
272 | +-- `UnitEnv` rather than `HscEnv`)
|
|
264 | 273 | -- See Note [Downsweep and the ModuleGraph]
|
265 | 274 | hugSomeThingsBelowUs _ _ hsc_env _ _ | isOneShot (ghcMode (hsc_dflags hsc_env)) = return []
|
266 | 275 | hugSomeThingsBelowUs extract include_hi_boot hsc_env uid mn
|
... | ... | @@ -18,7 +18,6 @@ import GHC.Types.Name.Cache |
18 | 18 | import GHC.Types.Target
|
19 | 19 | import GHC.Types.TypeEnv
|
20 | 20 | import GHC.Unit.Finder.Types
|
21 | -import GHC.Unit.Module.Graph
|
|
22 | 21 | import GHC.Unit.Env
|
23 | 22 | import GHC.Utils.Logger
|
24 | 23 | import GHC.Utils.TmpFs
|
... | ... | @@ -65,10 +64,6 @@ data HscEnv |
65 | 64 | hsc_targets :: [Target],
|
66 | 65 | -- ^ The targets (or roots) of the current session
|
67 | 66 | |
68 | - hsc_mod_graph :: ModuleGraph,
|
|
69 | - -- ^ The module graph of the current session
|
|
70 | - -- See Note [Downsweep and the ModuleGraph] for when this is constructed.
|
|
71 | - |
|
72 | 67 | hsc_IC :: InteractiveContext,
|
73 | 68 | -- ^ The context for evaluating interactive statements
|
74 | 69 | |
... | ... | @@ -113,3 +108,4 @@ data HscEnv |
113 | 108 | , hsc_llvm_config :: !LlvmConfigCache
|
114 | 109 | -- ^ LLVM configuration cache.
|
115 | 110 | }
|
111 | + |
... | ... | @@ -332,7 +332,6 @@ newHscEnvWithHUG top_dir top_dynflags cur_unit home_unit_graph = do |
332 | 332 | return HscEnv { hsc_dflags = top_dynflags
|
333 | 333 | , hsc_logger = setLogFlags logger (initLogFlags top_dynflags)
|
334 | 334 | , hsc_targets = []
|
335 | - , hsc_mod_graph = emptyMG
|
|
336 | 335 | , hsc_IC = emptyInteractiveContext dflags
|
337 | 336 | , hsc_NC = nc_var
|
338 | 337 | , hsc_FC = fc_var
|
... | ... | @@ -190,12 +190,12 @@ depanalE diag_wrapper msg excluded_mods allow_dup_roots = do |
190 | 190 | |
191 | 191 | all_errs <- liftIO $ HUG.unitEnv_foldWithKey one_unit_messages (return emptyMessages) (hsc_HUG hsc_env)
|
192 | 192 | logDiagnostics (GhcDriverMessage <$> all_errs)
|
193 | - setSession hsc_env { hsc_mod_graph = mod_graph }
|
|
193 | + setSession (setModuleGraph mod_graph hsc_env)
|
|
194 | 194 | pure (emptyMessages, mod_graph)
|
195 | 195 | else do
|
196 | 196 | -- We don't have a complete module dependency graph,
|
197 | 197 | -- The graph may be disconnected and is unusable.
|
198 | - setSession hsc_env { hsc_mod_graph = emptyMG }
|
|
198 | + setSession (setModuleGraph emptyMG hsc_env)
|
|
199 | 199 | pure (errs, emptyMG)
|
200 | 200 | |
201 | 201 | |
... | ... | @@ -616,7 +616,7 @@ load' mhmi_cache how_much diag_wrapper mHscMessage mod_graph = do |
616 | 616 | -- for any client who might interact with GHC via load'.
|
617 | 617 | -- See Note [Timing of plugin initialization]
|
618 | 618 | initializeSessionPlugins
|
619 | - modifySession $ \hsc_env -> hsc_env { hsc_mod_graph = mod_graph }
|
|
619 | + modifySession (setModuleGraph mod_graph)
|
|
620 | 620 | guessOutputFile
|
621 | 621 | hsc_env <- getSession
|
622 | 622 |
... | ... | @@ -768,8 +768,9 @@ runHscPhase pipe_env hsc_env0 input_fn src_flavour = do |
768 | 768 | -- files. See GHC.Tc.Utils.TcGblEnv.tcg_type_env_var.
|
769 | 769 | -- See also Note [hsc_type_env_var hack]
|
770 | 770 | type_env_var <- newIORef emptyNameEnv
|
771 | - let hsc_env' = hsc_env { hsc_type_env_vars = knotVarsFromModuleEnv (mkModuleEnv [(mod, type_env_var)])
|
|
772 | - , hsc_mod_graph = mg }
|
|
771 | + let hsc_env' =
|
|
772 | + setModuleGraph mg
|
|
773 | + hsc_env { hsc_type_env_vars = knotVarsFromModuleEnv (mkModuleEnv [(mod, type_env_var)]) }
|
|
773 | 774 | |
774 | 775 | |
775 | 776 |
... | ... | @@ -671,7 +671,7 @@ dontLeakTheHUG thing_inside = do |
671 | 671 | -- oneshot mode does not support backpack
|
672 | 672 | -- and we want to avoid prodding the hsc_mod_graph thunk
|
673 | 673 | | isOneShot (ghcMode (hsc_dflags hsc_env)) = False
|
674 | - | mgHasHoles (hsc_mod_graph hsc_env) = True
|
|
674 | + | mgHasHoles (ue_module_graph old_unit_env) = True
|
|
675 | 675 | | otherwise = False
|
676 | 676 | pruneHomeUnitEnv hme = do
|
677 | 677 | -- NB: These are empty HPTs because Iface/Load first consults the HPT
|
... | ... | @@ -683,19 +683,19 @@ dontLeakTheHUG thing_inside = do |
683 | 683 | | otherwise
|
684 | 684 | = do
|
685 | 685 | hug' <- traverse pruneHomeUnitEnv (ue_home_unit_graph old_unit_env)
|
686 | + let !new_mod_graph = emptyMG { mg_mss = panic "cleanTopEnv: mg_mss"
|
|
687 | + , mg_graph = panic "cleanTopEnv: mg_graph"
|
|
688 | + , mg_has_holes = keepFor20509 }
|
|
686 | 689 | return old_unit_env
|
687 | 690 | { ue_home_unit_graph = hug'
|
691 | + , ue_module_graph = new_mod_graph
|
|
688 | 692 | }
|
689 | 693 | in do
|
690 | 694 | !unit_env <- unit_env_io
|
691 | 695 | -- mg_has_holes will be checked again, but nothing else about the module graph
|
692 | - let !new_mod_graph = emptyMG { mg_mss = panic "cleanTopEnv: mg_mss"
|
|
693 | - , mg_graph = panic "cleanTopEnv: mg_graph"
|
|
694 | - , mg_has_holes = keepFor20509 }
|
|
695 | 696 | pure $
|
696 | 697 | hsc_env
|
697 | 698 | { hsc_targets = panic "cleanTopEnv: hsc_targets"
|
698 | - , hsc_mod_graph = new_mod_graph
|
|
699 | 699 | , hsc_IC = panic "cleanTopEnv: hsc_IC"
|
700 | 700 | , hsc_type_env_vars = case maybe_type_vars of
|
701 | 701 | Just vars -> vars
|
... | ... | @@ -2109,7 +2109,7 @@ for the unit portion of the graph, if it's not already been performed. |
2109 | 2109 | withInteractiveModuleNode :: HscEnv -> TcM a -> TcM a
|
2110 | 2110 | withInteractiveModuleNode hsc_env thing_inside = do
|
2111 | 2111 | mg <- liftIO $ downsweepInteractiveImports hsc_env (hsc_IC hsc_env)
|
2112 | - updTopEnv (\env -> env { hsc_mod_graph = mg }) thing_inside
|
|
2112 | + updTopEnv (setModuleGraph mg) thing_inside
|
|
2113 | 2113 | |
2114 | 2114 | |
2115 | 2115 | runTcInteractive :: HscEnv -> TcRn a -> IO (Messages TcRnMessage, Maybe a)
|
... | ... | @@ -23,21 +23,22 @@ |
23 | 23 | -- ┌▽────────────┐ │ │
|
24 | 24 | -- │HomeUnitGraph│ │ │
|
25 | 25 | -- └┬────────────┘ │ │
|
26 | --- ┌▽─────────────────▽┐ │
|
|
27 | --- │UnitEnv │ │
|
|
28 | --- └┬──────────────────┘ │
|
|
29 | --- ┌▽───────────────────────────────────────▽┐
|
|
30 | --- │HscEnv │
|
|
31 | --- └─────────────────────────────────────────┘
|
|
26 | +-- ┌▽─────────────────▽─────────────────────▽┐
|
|
27 | +-- │UnitEnv │
|
|
28 | +-- └┬─────────────-──────────────────────────┘
|
|
29 | +-- │
|
|
30 | +-- │
|
|
31 | +-- ┌▽──────────────────────────────────────▽┐
|
|
32 | +-- │HscEnv │
|
|
33 | +-- └────────────────────────────────────────┘
|
|
32 | 34 | -- @
|
33 | 35 | --
|
34 | --- The 'UnitEnv' references both the 'HomeUnitGraph' (with all the home unit
|
|
35 | --- modules) and the 'ExternalPackageState' (information about all
|
|
36 | --- non-home/external units). The 'HscEnv' references this 'UnitEnv' and the
|
|
37 | --- 'ModuleGraph' (which describes the relationship between the modules being
|
|
38 | --- compiled). The 'HomeUnitGraph' has one 'HomePackageTable' for every unit.
|
|
39 | ---
|
|
40 | --- TODO: Arguably, the 'ModuleGraph' should be part of 'UnitEnv' rather than being in the 'HscEnv'.
|
|
36 | +-- The 'UnitEnv' references the 'HomeUnitGraph' (with all the home unit
|
|
37 | +-- modules), the 'ExternalPackageState' (information about all
|
|
38 | +-- non-home/external units), and the 'ModuleGraph' (which describes the
|
|
39 | +-- relationship between the modules being compiled).
|
|
40 | +-- The 'HscEnv' references this 'UnitEnv'.
|
|
41 | +-- The 'HomeUnitGraph' has one 'HomePackageTable' for every unit.
|
|
41 | 42 | module GHC.Unit.Env
|
42 | 43 | ( UnitEnv (..)
|
43 | 44 | , initUnitEnv
|
... | ... | @@ -119,6 +120,7 @@ import GHC.Unit.Home.ModInfo |
119 | 120 | import GHC.Unit.Home.PackageTable
|
120 | 121 | import GHC.Unit.Home.Graph (HomeUnitGraph, HomeUnitEnv)
|
121 | 122 | import qualified GHC.Unit.Home.Graph as HUG
|
123 | +import GHC.Unit.Module.Graph
|
|
122 | 124 | |
123 | 125 | import GHC.Platform
|
124 | 126 | import GHC.Settings
|
... | ... | @@ -163,6 +165,10 @@ data UnitEnv = UnitEnv |
163 | 165 | |
164 | 166 | , ue_current_unit :: UnitId
|
165 | 167 | |
168 | + , ue_module_graph :: ModuleGraph
|
|
169 | + -- ^ The module graph of the current session
|
|
170 | + -- See Note [Downsweep and the ModuleGraph] for when this is constructed.
|
|
171 | + |
|
166 | 172 | , ue_home_unit_graph :: !HomeUnitGraph
|
167 | 173 | -- See Note [Multiple Home Units]
|
168 | 174 | |
... | ... | @@ -182,6 +188,7 @@ initUnitEnv cur_unit hug namever platform = do |
182 | 188 | return $ UnitEnv
|
183 | 189 | { ue_eps = eps
|
184 | 190 | , ue_home_unit_graph = hug
|
191 | + , ue_module_graph = emptyMG
|
|
185 | 192 | , ue_current_unit = cur_unit
|
186 | 193 | , ue_platform = platform
|
187 | 194 | , ue_namever = namever
|
... | ... | @@ -4680,7 +4680,7 @@ clearHPTs = do |
4680 | 4680 | let pruneHomeUnitEnv hme = liftIO $ do
|
4681 | 4681 | emptyHpt <- emptyHomePackageTable
|
4682 | 4682 | pure hme{ homeUnitEnv_hpt = emptyHpt }
|
4683 | - discardMG hsc = hsc { hsc_mod_graph = GHC.emptyMG }
|
|
4683 | + discardMG hsc = setModuleGraph GHC.emptyMG hsc
|
|
4684 | 4684 | modifySessionM $ \hsc_env -> do
|
4685 | 4685 | hug' <- traverse pruneHomeUnitEnv $ hsc_HUG hsc_env
|
4686 | 4686 | pure $ discardMG $ discardIC $ hscUpdateHUG (const hug') hsc_env
|