Wolfgang Jeltsch pushed to branch wip/jeltsch/more-efficient-home-unit-imports-finding at Glasgow Haskell Compiler / GHC

Commits:

2 changed files:

Changes:

  • compiler/GHC/Unit/Finder.hs
    ... ... @@ -44,7 +44,11 @@ import GHC.Data.OsPath
    44 44 
     import GHC.Unit.Env
    45 45 
     import GHC.Unit.Types
    46 46 
     import GHC.Unit.Module
    47 
    -import GHC.Unit.Module.Graph (ModuleNameHomeMap (..), mgHomeModuleMap)
    47 
    +import GHC.Unit.Module.Graph
    48 
    +       (
    49 
    +           CompleteUnits (cu_inventory, cu_providers),
    50 
    +           mgCompleteUnits
    51 
    +       )
    48 52 
     import GHC.Unit.Home
    49 53 
     import GHC.Unit.Home.Graph (UnitEnvGraph)
    50 54 
     import qualified GHC.Unit.Home.Graph as HUG
    ... ... @@ -178,13 +182,13 @@ getDirHash dir = do
    178 182
    179 183 
     findImportedModule :: HscEnv -> ModuleName -> PkgQual -> IO FindResult
    180 184 
     findImportedModule hsc_env mod pkg_qual =
    181 
    -  let fc        = hsc_FC hsc_env
    182 
    -      mhome_unit = hsc_home_unit_maybe hsc_env
    183 
    -      dflags    = hsc_dflags hsc_env
    184 
    -      fopts     = initFinderOpts dflags
    185 
    +  let fc           = hsc_FC hsc_env
    186 
    +      mb_home_unit = hsc_home_unit_maybe hsc_env
    187 
    +      dflags       = hsc_dflags hsc_env
    188 
    +      fopts        = initFinderOpts dflags
    185 189 
       in do
    186 
    -    let home_module_map = mgHomeModuleMap (hsc_mod_graph hsc_env)
    187 
    -    findImportedModuleNoHsc fc fopts (hsc_unit_env hsc_env) home_module_map mhome_unit mod pkg_qual
    190 
    +    let complete_home_units = mgCompleteUnits (hsc_mod_graph hsc_env)
    191 
    +    findImportedModuleNoHsc fc fopts (hsc_unit_env hsc_env) complete_home_units mb_home_unit mod pkg_qual
    188 192
    189 193 
     findImportedModuleWithIsBoot :: HscEnv -> ModuleName -> IsBootInterface -> PkgQual -> IO FindResult
    190 194 
     findImportedModuleWithIsBoot hsc_env mod is_boot pkg_qual = do
    ... ... @@ -197,27 +201,26 @@ findImportedModuleNoHsc
    197 201 
       :: FinderCache
    198 202 
       -> FinderOpts
    199 203 
       -> UnitEnv
    200 
    -  -> ModuleNameHomeMap
    204 
    +  -> CompleteUnits
    201 205 
       -> Maybe HomeUnit
    202 206 
       -> ModuleName
    203 207 
       -> PkgQual
    204 208 
       -> IO FindResult
    205 
    -findImportedModuleNoHsc fc fopts ue home_module_map mhome_unit mod_name mb_pkg =
    209 
    +findImportedModuleNoHsc fc fopts ue complete_home_units mb_home_unit mod_name mb_pkg =
    206 210 
       case mb_pkg of
    207 211 
         NoPkgQual  -> unqual_import
    208 
    -    ThisPkg uid | (homeUnitId <$> mhome_unit) == Just uid -> home_import
    212 
    +    ThisPkg uid | (homeUnitId <$> mb_home_unit) == Just uid -> home_import
    209 213 
                     | Just os <- lookup uid other_fopts -> home_pkg_import (uid, os)
    210 
    -                | otherwise -> pprPanic "findImportModule" (ppr mod_name $$ ppr mb_pkg $$ ppr (homeUnitId <$> mhome_unit) $$ ppr uid $$ ppr (map fst all_opts))
    214 
    +                | otherwise -> pprPanic "findImportModule" (ppr mod_name $$ ppr mb_pkg $$ ppr (homeUnitId <$> mb_home_unit) $$ ppr uid $$ ppr (map fst all_opts))
    211 215 
         OtherPkg _ -> pkg_import
    212 216 
       where
    213 
    -    ModuleNameHomeMap complete_units module_name_map = home_module_map
    214 
    -    module_home_units = M.findWithDefault Set.empty mod_name module_name_map
    215 
    -    current_unit_id = homeUnitId <$> mhome_unit
    216 
    -    all_opts = case current_unit_id of
    217 
    +    cached_module_providers = M.findWithDefault Set.empty mod_name (cu_providers complete_home_units)
    218 
    +    mb_home_unit_id = homeUnitId <$> mb_home_unit
    219 
    +    all_opts = case mb_home_unit_id of
    217 220 
                     Nothing -> other_fopts
    218 221 
                     Just home_unit_id -> (home_unit_id, fopts) : other_fopts
    219 222
    220 
    -    home_import = case mhome_unit of
    223 
    +    home_import = case mb_home_unit of
    221 224 
                        Just home_unit -> findHomeModule fc fopts home_unit mod_name
    222 225 
                        Nothing -> pure $ NoPackage (panic "findImportedModule: no home-unit")
    223 226
    ... ... @@ -226,7 +229,7 @@ findImportedModuleNoHsc fc fopts ue home_module_map mhome_unit mod_name mb_pkg =
    226 229 
           -- If the module is reexported, then look for it as if it was from the perspective
    227 230 
           -- of that package which reexports it.
    228 231 
           | Just real_mod_name <- lookupUniqMap (finder_reexportedModules opts) mod_name =
    229 
    -        findImportedModuleNoHsc fc opts ue home_module_map (Just $ DefiniteHomeUnit uid Nothing) real_mod_name NoPkgQual
    232 
    +        findImportedModuleNoHsc fc opts ue complete_home_units (Just $ DefiniteHomeUnit uid Nothing) real_mod_name NoPkgQual
    230 233 
           | elementOfUniqSet mod_name (finder_hiddenModules opts) =
    231 234 
             return (mkHomeHidden uid)
    232 235 
           | otherwise =
    ... ... @@ -243,23 +246,23 @@ findImportedModuleNoHsc fc fopts ue home_module_map mhome_unit mod_name mb_pkg =
    243 246 
                         `orIfNotFound`
    244 247 
                         findExposedPackageModule fc fopts units mod_name NoPkgQual
    245 248
    246 
    -    units     = case current_unit_id of
    249 
    +    units     = case mb_home_unit_id of
    247 250 
                       Nothing -> ue_homeUnitState ue
    248 251 
                       Just home_unit_id -> HUG.homeUnitEnv_units $ ue_findHomeUnitEnv home_unit_id ue
    249 252 
         hpt_deps :: Set.Set UnitId
    250 253 
         hpt_deps = homeUnitDepends units
    251 
    -    dep_providers = Set.intersection module_home_units hpt_deps
    252 
    -    known_other_uids =
    253 
    -      let providers = maybe dep_providers (\u -> Set.delete u dep_providers) current_unit_id
    254 
    -      in Set.toList providers
    255 
    -    unknown_units =
    256 
    -      let candidates = Set.difference hpt_deps complete_units
    257 
    -          excluded = maybe dep_providers (\u -> Set.insert u dep_providers) current_unit_id
    254 
    +    cached_providing_deps = Set.intersection cached_module_providers hpt_deps
    255 
    +    other_cached_providing_deps =
    256 
    +      Set.toList $
    257 
    +      maybe cached_providing_deps (\u -> Set.delete u cached_providing_deps) mb_home_unit_id
    258 
    +    uncached_providing_deps =
    259 
    +      let candidates = Set.difference hpt_deps (cu_inventory complete_home_units)
    260 
    +          excluded = maybe cached_providing_deps (\u -> Set.insert u cached_providing_deps) mb_home_unit_id
    258 261 
           in Set.toList (Set.difference candidates excluded)
    259 
    -    other_home_uids = known_other_uids ++ unknown_units
    262 
    +    other_providing_deps = other_cached_providing_deps ++ uncached_providing_deps
    260 263 
         other_fopts =
    261 264 
           [ (uid, initFinderOpts (homeUnitEnv_dflags (ue_findHomeUnitEnv uid ue)))
    262 
    -      | uid <- other_home_uids
    265 
    +      | uid <- other_providing_deps
    263 266 
           ]
    264 267
    265 268 
     -- | Locate a plugin module requested by the user, for a compiler
    ... ... @@ -278,15 +281,15 @@ findPluginModule :: HscEnv -> ModuleName -> IO FindResult
    278 281 
     findPluginModule hsc_env mod_name = do
    279 282 
       let fc = hsc_FC hsc_env
    280 283 
       let units = hsc_units hsc_env
    281 
    -  let mhome_unit = hsc_home_unit_maybe hsc_env
    282 
    -  findPluginModuleNoHsc fc (initFinderOpts (hsc_dflags hsc_env)) units mhome_unit mod_name
    284 
    +  let mb_home_unit = hsc_home_unit_maybe hsc_env
    285 
    +  findPluginModuleNoHsc fc (initFinderOpts (hsc_dflags hsc_env)) units mb_home_unit mod_name
    283 286
    284 287
    285 288 
     -- | A version of findExactModule which takes the exact parts of the HscEnv it needs
    286 289 
     -- directly.
    287 290 
     findExactModuleNoHsc :: FinderCache -> FinderOpts -> UnitEnvGraph FinderOpts -> UnitState -> Maybe HomeUnit -> InstalledModule -> IsBootInterface -> IO InstalledFindResult
    288 
    -findExactModuleNoHsc fc fopts other_fopts unit_state mhome_unit mod is_boot = do
    289 
    -  res <- case mhome_unit of
    291 
    +findExactModuleNoHsc fc fopts other_fopts unit_state mb_home_unit mod is_boot = do
    292 
    +  res <- case mb_home_unit of
    290 293 
         Just home_unit
    291 294 
          | isHomeInstalledModule home_unit mod
    292 295 
             -> findInstalledHomeModule fc fopts (homeUnitId home_unit) (moduleName mod)

  • compiler/GHC/Unit/Module/Graph.hs
    ... ... @@ -67,8 +67,8 @@ module GHC.Unit.Module.Graph
    67 67 
        , mgLookupModule
    68 68 
        , mgLookupModuleName
    69 69 
        , mgHasHoles
    70 
    -   , ModuleNameHomeMap (ModuleNameHomeMap)
    71 
    -   , mgHomeModuleMap
    70 
    +   , CompleteUnits (CompleteUnits, cu_inventory, cu_providers)
    71 
    +   , mgCompleteUnits
    72 72 
        , showModMsg
    73 73
    74 74 
         -- ** Reachability queries
    ... ... @@ -205,18 +205,21 @@ data ModuleGraph = ModuleGraph
    205 205 
       -- Cached computation, whether any of the ModuleGraphNode are isHoleModule,
    206 206 
       -- This is only used for a hack in GHC.Iface.Load to do with backpack, please
    207 207 
       -- remove this at the earliest opportunity.
    208 
    -  , mg_home_map :: ModuleNameHomeMap
    208 
    +  , mg_complete_units :: CompleteUnits
    209 209 
         -- ^ For each module name, which home unit UnitIds define it together with the set of units for which the listing is complete.
    210 210 
       }
    211 211
    212 
    -data ModuleNameHomeMap = ModuleNameHomeMap !(Set UnitId)
    213 
    -                                           !(Map ModuleName (Set UnitId))
    212 
    +data CompleteUnits = CompleteUnits
    213 
    +                     {
    214 
    +                         cu_inventory :: !(Set UnitId),
    215 
    +                         cu_providers :: !(Map ModuleName (Set UnitId))
    216 
    +                     }
    214 217
    215 
    -mkHomeModuleMap :: [ModuleGraphNode] -> ModuleNameHomeMap
    216 
    -mkHomeModuleMap nodes = ModuleNameHomeMap completeUnits providerMap where
    218 
    +mkCompleteUnits :: [ModuleGraphNode] -> CompleteUnits
    219 
    +mkCompleteUnits nodes = CompleteUnits inventory providers where
    217 220
    218 
    -    providerMap :: Map ModuleName (Set UnitId)
    219 
    -    providerMap
    221 
    +    providers :: Map ModuleName (Set UnitId)
    222 
    +    providers
    220 223 
             = Map.fromListWith Set.union $
    221 224 
               [
    222 225 
                   (moduleName, Set.singleton unitID) |
    ... ... @@ -225,11 +228,11 @@ mkHomeModuleMap nodes = ModuleNameHomeMap completeUnits providerMap where
    225 228 
                       let unitID     = moduleNodeInfoUnitId moduleNodeInfo
    226 229 
               ]
    227 230
    228 
    -    completeUnits :: Set UnitId
    229 
    -    completeUnits = Set.unions (Map.elems providerMap)
    231 
    +    inventory :: Set UnitId
    232 
    +    inventory = Set.unions (Map.elems providers)
    230 233
    231 
    -mgHomeModuleMap :: ModuleGraph -> ModuleNameHomeMap
    232 
    -mgHomeModuleMap = mg_home_map
    234 
    +mgCompleteUnits :: ModuleGraph -> CompleteUnits
    235 
    +mgCompleteUnits = mg_complete_units
    233 236
    234 237 
     -- | Why do we ever need to construct empty graphs? Is it because of one shot mode?
    235 238 
     emptyMG :: ModuleGraph
    ... ... @@ -237,7 +240,7 @@ emptyMG = ModuleGraph [] (graphReachability emptyGraph, const Nothing)
    237 240 
                              (graphReachability emptyGraph, const Nothing)
    238 241 
                              (graphReachability emptyGraph, const Nothing)
    239 242 
                              False
    240 
    -                         (ModuleNameHomeMap Set.empty Map.empty)
    243 
    +                         (CompleteUnits Set.empty Map.empty)
    241 244
    242 245 
     -- | Construct a module graph. This function should be the only entry point for
    243 246 
     -- building a 'ModuleGraph', since it is supposed to be built once and never modified.
    ... ... @@ -513,7 +516,7 @@ isEmptyMG = null . mg_mss
    513 516 
     mapMG :: (ModSummary -> ModSummary) -> ModuleGraph -> ModuleGraph
    514 517 
     mapMG f mg@ModuleGraph{..} = mg
    515 518 
       { mg_mss = new_mss
    516 
    -  , mg_home_map = mkHomeModuleMap new_mss
    519 
    +  , mg_complete_units = mkCompleteUnits new_mss
    517 520 
       }
    518 521 
       where
    519 522 
         new_mss =
    ... ... @@ -1086,7 +1089,7 @@ extendMG ModuleGraph{..} node =
    1086 1089 
         , mg_loop_graph = mkTransLoopDeps new_mss
    1087 1090 
         , mg_zero_graph = mkTransZeroDeps new_mss
    1088 1091 
         , mg_has_holes = mg_has_holes || maybe False isHsigFile (moduleNodeInfoHscSource =<< mgNodeIsModule node)
    1089 
    -    , mg_home_map = mkHomeModuleMap new_mss
    1092 
    +    , mg_complete_units = mkCompleteUnits new_mss
    1090 1093 
         }
    1091 1094 
       where
    1092 1095 
         new_mss = node : mg_mss

    • —
    View it on GitLab.
    You're receiving this email because of your account on gitlab.haskell.org. Manage all notifications · Help