Matthew Pickering pushed to branch wip/module_graph_mode at Glasgow Haskell Compiler / GHC

Commits:

12 changed files:

Changes:

  • compiler/GHC.hs
    ... ... @@ -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
     
    

  • compiler/GHC/Core/Opt/Pipeline.hs
    ... ... @@ -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
    

  • compiler/GHC/Driver/Backpack.hs
    ... ... @@ -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
     
    

  • compiler/GHC/Driver/Env.hs
    ... ... @@ -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
    

  • compiler/GHC/Driver/Env/Types.hs
    ... ... @@ -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
    +

  • compiler/GHC/Driver/Main.hs
    ... ... @@ -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
    

  • compiler/GHC/Driver/Make.hs
    ... ... @@ -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
     
    

  • compiler/GHC/Driver/Pipeline/Execute.hs
    ... ... @@ -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
     
    

  • compiler/GHC/Iface/Load.hs
    ... ... @@ -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
    

  • compiler/GHC/Tc/Module.hs
    ... ... @@ -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)
    

  • compiler/GHC/Unit/Env.hs
    ... ... @@ -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
    

  • ghc/GHCi/UI.hs
    ... ... @@ -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