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,6 +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
    48 
    +       (
    49 
    +           HomeModuleNameProvidersMap,
    50 
    +           mgHomeModuleNameProvidersMap
    51 
    +       )
    47 52 
     import GHC.Unit.Home
    48 53 
     import GHC.Unit.Home.Graph (UnitEnvGraph)
    49 54 
     import qualified GHC.Unit.Home.Graph as HUG
    ... ... @@ -72,7 +77,8 @@ import GHC.Driver.Config.Finder
    72 77 
     import GHC.Types.Unique.Set
    73 78 
     import qualified Data.List as L(sort)
    74 79 
     import Data.List.NonEmpty ( NonEmpty (..) )
    75 
    -import qualified Data.Set as Set (toList)
    80 
    +import Data.Set (Set)
    81 
    +import qualified Data.Set as Set (empty, intersection, difference, null, toList)
    76 82 
     import qualified System.Directory as SD
    77 83 
     import qualified System.OsPath as OsPath
    78 84 
     import qualified Data.List.NonEmpty as NE
    ... ... @@ -177,12 +183,13 @@ getDirHash dir = do
    177 183
    178 184 
     findImportedModule :: HscEnv -> ModuleName -> PkgQual -> IO FindResult
    179 185 
     findImportedModule hsc_env mod pkg_qual =
    180 
    -  let fc        = hsc_FC hsc_env
    181 
    -      mhome_unit = hsc_home_unit_maybe hsc_env
    182 
    -      dflags    = hsc_dflags hsc_env
    183 
    -      fopts     = initFinderOpts dflags
    186 
    +  let fc           = hsc_FC hsc_env
    187 
    +      mb_home_unit = hsc_home_unit_maybe hsc_env
    188 
    +      dflags       = hsc_dflags hsc_env
    189 
    +      fopts        = initFinderOpts dflags
    184 190 
       in do
    185 
    -    findImportedModuleNoHsc fc fopts (hsc_unit_env hsc_env) mhome_unit mod pkg_qual
    191 
    +    let home_module_name_providers_map = mgHomeModuleNameProvidersMap (hsc_mod_graph hsc_env)
    192 
    +    findImportedModuleNoHsc fc fopts (hsc_unit_env hsc_env) home_module_name_providers_map mb_home_unit mod pkg_qual
    186 193
    187 194 
     findImportedModuleWithIsBoot :: HscEnv -> ModuleName -> IsBootInterface -> PkgQual -> IO FindResult
    188 195 
     findImportedModuleWithIsBoot hsc_env mod is_boot pkg_qual = do
    ... ... @@ -195,55 +202,118 @@ findImportedModuleNoHsc
    195 202 
       :: FinderCache
    196 203 
       -> FinderOpts
    197 204 
       -> UnitEnv
    205 
    +  -> HomeModuleNameProvidersMap
    198 206 
       -> Maybe HomeUnit
    199 207 
       -> ModuleName
    200 208 
       -> PkgQual
    201 209 
       -> IO FindResult
    202 
    -findImportedModuleNoHsc fc fopts ue mhome_unit mod_name mb_pkg =
    210 
    +findImportedModuleNoHsc fc fopts ue home_module_name_providers_map mb_home_unit mod_name mb_pkg =
    203 211 
       case mb_pkg of
    204 212 
         NoPkgQual  -> unqual_import
    205 
    -    ThisPkg uid | (homeUnitId <$> mhome_unit) == Just uid -> home_import
    213 
    +    ThisPkg uid | (homeUnitId <$> mb_home_unit) == Just uid -> home_import
    206 214 
                     | Just os <- lookup uid other_fopts -> home_pkg_import (uid, os)
    207 
    -                | otherwise -> pprPanic "findImportModule" (ppr mod_name $$ ppr mb_pkg $$ ppr (homeUnitId <$> mhome_unit) $$ ppr uid $$ ppr (map fst all_opts))
    215 
    +                | otherwise -> pprPanic "findImportModule" (ppr mod_name $$ ppr mb_pkg $$ ppr (homeUnitId <$> mb_home_unit) $$ ppr uid $$ ppr (map fst all_opts))
    208 216 
         OtherPkg _ -> pkg_import
    209 217 
       where
    210 
    -    all_opts = case mhome_unit of
    211 
    -                Nothing -> other_fopts
    212 
    -                Just home_unit -> (homeUnitId home_unit, fopts) : other_fopts
    213 
    -
    214 
    -
    215 
    -    home_import = case mhome_unit of
    216 
    -                   Just home_unit -> findHomeModule fc fopts home_unit mod_name
    217 
    -                   Nothing -> pure $ NoPackage (panic "findImportedModule: no home-unit")
    218 
    -
    219 218
    219 
    +    mb_home_unit_id :: Maybe UnitId
    220 
    +    mb_home_unit_id = homeUnitId <$> mb_home_unit
    221 
    +
    222 
    +    all_opts :: [(UnitId, FinderOpts)]
    223 
    +    all_opts = case mb_home_unit_id of
    224 
    +        Nothing           -> other_fopts
    225 
    +        Just home_unit_id -> (home_unit_id, fopts) : other_fopts
    226 
    +
    227 
    +    home_import :: IO FindResult
    228 
    +    home_import = case mb_home_unit of
    229 
    +        Just home_unit -> findHomeModule fc fopts home_unit mod_name
    230 
    +        Nothing        -> pure $
    231 
    +                          NoPackage (panic "findImportedModule: no home-unit")
    232 
    +
    233 
    +    {-
    234 
    +        If the module is reexported, then look for it as if it was from the
    235 
    +        perspective of that package which reexports it.
    236 
    +    -}
    237 
    +    home_pkg_import :: (UnitId, FinderOpts) -> IO FindResult
    220 238 
         home_pkg_import (uid, opts)
    221 
    -      -- If the module is reexported, then look for it as if it was from the perspective
    222 
    -      -- of that package which reexports it.
    223 
    -      | Just real_mod_name <- lookupUniqMap (finder_reexportedModules opts) mod_name =
    224 
    -        findImportedModuleNoHsc fc opts ue (Just $ DefiniteHomeUnit uid Nothing) real_mod_name NoPkgQual
    225 
    -      | elementOfUniqSet mod_name (finder_hiddenModules opts) =
    226 
    -        return (mkHomeHidden uid)
    227 
    -      | otherwise =
    228 
    -        findHomePackageModule fc opts uid mod_name
    229 
    -
    230 
    -    -- Do not be smart and change this to `foldr orIfNotFound home_import hs` as
    231 
    -    -- that is not the same!! home_import is first because we need to look within ourselves
    232 
    -    -- first before looking at the packages in order.
    233 
    -    any_home_import = foldr1 orIfNotFound (home_import:| map home_pkg_import other_fopts)
    234 
    -
    235 
    -    pkg_import    = findExposedPackageModule fc fopts units  mod_name mb_pkg
    236 
    -
    237 
    -    unqual_import = any_home_import
    238 
    -                    `orIfNotFound`
    239 
    -                    findExposedPackageModule fc fopts units mod_name NoPkgQual
    240 
    -
    241 
    -    units     = case mhome_unit of
    242 
    -                  Nothing -> ue_homeUnitState ue
    243 
    -                  Just home_unit -> HUG.homeUnitEnv_units $ ue_findHomeUnitEnv (homeUnitId home_unit) ue
    244 
    -    hpt_deps :: [UnitId]
    245 
    -    hpt_deps  = Set.toList (homeUnitDepends units)
    246 
    -    other_fopts  = map (\uid -> (uid, initFinderOpts (homeUnitEnv_dflags (ue_findHomeUnitEnv uid ue)))) hpt_deps
    239 
    +        | Just real_mod_name
    240 
    +              <- lookupUniqMap (finder_reexportedModules opts) mod_name
    241 
    +            = findImportedModuleNoHsc fc opts ue home_module_name_providers_map
    242 
    +                  (Just $ DefiniteHomeUnit uid Nothing)
    243 
    +                  real_mod_name
    244 
    +                  NoPkgQual
    245 
    +        | elementOfUniqSet mod_name (finder_hiddenModules opts)
    246 
    +            = return (mkHomeHidden uid)
    247 
    +        | otherwise
    248 
    +            = findHomePackageModule fc opts uid mod_name
    249 
    +
    250 
    +    any_home_import :: IO FindResult
    251 
    +    any_home_import = foldr1 orIfNotFound $
    252 
    +                      home_import :| map home_pkg_import other_fopts
    253 
    +    {-
    254 
    +        Do not try to be smart and change this to `foldr orIfNotFound
    255 
    +        home_import (map home_pkg_import other_fopts)`, as that would not be the
    256 
    +        same. `home_import` is first because we need to first look within the
    257 
    +        current unit before looking at the other units in order.
    258 
    +    -}
    259 
    +
    260 
    +    pkg_import :: IO FindResult
    261 
    +    pkg_import = findExposedPackageModule fc fopts unit_state mod_name mb_pkg
    262 
    +
    263 
    +    unqual_import :: IO FindResult
    264 
    +    unqual_import
    265 
    +        = any_home_import
    266 
    +          `orIfNotFound`
    267 
    +          findExposedPackageModule fc fopts unit_state mod_name NoPkgQual
    268 
    +
    269 
    +    unit_state :: UnitState
    270 
    +    unit_state = case mb_home_unit_id of
    271 
    +        Nothing           -> ue_homeUnitState ue
    272 
    +        Just home_unit_id -> HUG.homeUnitEnv_units $
    273 
    +                             ue_findHomeUnitEnv home_unit_id ue
    274 
    +
    275 
    +    home_unit_deps :: Set UnitId
    276 
    +    home_unit_deps = homeUnitDepends unit_state
    277 
    +
    278 
    +    ranked_home_unit_deps :: [UnitId]
    279 
    +    ranked_home_unit_deps = rankedHomeUnitDeps home_module_name_providers_map
    280 
    +                                               mod_name
    281 
    +                                               home_unit_deps
    282 
    +
    283 
    +    other_fopts :: [(UnitId, FinderOpts)]
    284 
    +    other_fopts
    285 
    +        = [
    286 
    +              (uid, opts) |
    287 
    +                  uid <- ranked_home_unit_deps,
    288 
    +                  let opts = initFinderOpts $
    289 
    +                             homeUnitEnv_dflags (ue_findHomeUnitEnv uid ue)
    290 
    +          ]
    291 
    +
    292 
    +rankedHomeUnitDeps :: HomeModuleNameProvidersMap
    293 
    +                   -> ModuleName
    294 
    +                   -> Set UnitId
    295 
    +                   -> [UnitId]
    296 
    +rankedHomeUnitDeps _ _ home_unit_deps | Set.null home_unit_deps
    297 
    +    = []
    298 
    +rankedHomeUnitDeps home_module_name_providers_map mod_name home_unit_deps
    299 
    +    = Set.toList cached_deps ++ Set.toList uncached_deps
    300 
    +    where
    301 
    +
    302 
    +    cached_providers :: Set UnitId
    303 
    +    cached_providers = lookupWithDefaultUniqMap home_module_name_providers_map
    304 
    +                                                Set.empty
    305 
    +                                                mod_name
    306 
    +
    307 
    +    cached_deps :: Set UnitId
    308 
    +    cached_deps = Set.intersection home_unit_deps cached_providers
    309 
    +
    310 
    +    uncached_deps :: Set UnitId
    311 
    +    uncached_deps = Set.difference home_unit_deps cached_providers
    312 
    +{-
    313 
    +    The special handling of the situation where the dependency set is empty does
    314 
    +    not change the result, but it avoids triggering evaluation of the module
    315 
    +    graph.
    316 
    +-}
    247 317
    248 318 
     -- | Locate a plugin module requested by the user, for a compiler
    249 319 
     -- plugin.  This consults the same set of exposed packages as
    ... ... @@ -261,15 +331,15 @@ findPluginModule :: HscEnv -> ModuleName -> IO FindResult
    261 331 
     findPluginModule hsc_env mod_name = do
    262 332 
       let fc = hsc_FC hsc_env
    263 333 
       let units = hsc_units hsc_env
    264 
    -  let mhome_unit = hsc_home_unit_maybe hsc_env
    265 
    -  findPluginModuleNoHsc fc (initFinderOpts (hsc_dflags hsc_env)) units mhome_unit mod_name
    334 
    +  let mb_home_unit = hsc_home_unit_maybe hsc_env
    335 
    +  findPluginModuleNoHsc fc (initFinderOpts (hsc_dflags hsc_env)) units mb_home_unit mod_name
    266 336
    267 337
    268 338 
     -- | A version of findExactModule which takes the exact parts of the HscEnv it needs
    269 339 
     -- directly.
    270 340 
     findExactModuleNoHsc :: FinderCache -> FinderOpts -> UnitEnvGraph FinderOpts -> UnitState -> Maybe HomeUnit -> InstalledModule -> IsBootInterface -> IO InstalledFindResult
    271 
    -findExactModuleNoHsc fc fopts other_fopts unit_state mhome_unit mod is_boot = do
    272 
    -  res <- case mhome_unit of
    341 
    +findExactModuleNoHsc fc fopts other_fopts unit_state mb_home_unit mod is_boot = do
    342 
    +  res <- case mb_home_unit of
    273 343 
         Just home_unit
    274 344 
          | isHomeInstalledModule home_unit mod
    275 345 
             -> findInstalledHomeModule fc fopts (homeUnitId home_unit) (moduleName mod)

  • compiler/GHC/Unit/Module/Graph.hs
    ... ... @@ -67,6 +67,8 @@ module GHC.Unit.Module.Graph
    67 67 
        , mgLookupModule
    68 68 
        , mgLookupModuleName
    69 69 
        , mgHasHoles
    70 
    +   , HomeModuleNameProvidersMap
    71 
    +   , mgHomeModuleNameProvidersMap
    70 72 
        , showModMsg
    71 73
    72 74 
         -- ** Reachability queries
    ... ... @@ -156,10 +158,12 @@ import GHC.Unit.Module.ModIface
    156 158 
     import GHC.Utils.Misc ( partitionWith )
    157 159
    158 160 
     import System.FilePath
    161 
    +import Data.Set (Set)
    162 
    +import qualified Data.Set as Set
    163 
    +import Data.Map (Map)
    159 164 
     import qualified Data.Map as Map
    160 165 
     import GHC.Types.Unique.DSet
    161 
    -import qualified Data.Set as Set
    162 
    -import Data.Set (Set)
    166 
    +import GHC.Types.Unique.Map (UniqMap, emptyUniqMap, listToUniqMap_C)
    163 167 
     import GHC.Unit.Module
    164 168 
     import GHC.Unit.Module.ModNodeKey
    165 169 
     import GHC.Unit.Module.Stage
    ... ... @@ -202,14 +206,32 @@ data ModuleGraph = ModuleGraph
    202 206 
       -- Cached computation, whether any of the ModuleGraphNode are isHoleModule,
    203 207 
       -- This is only used for a hack in GHC.Iface.Load to do with backpack, please
    204 208 
       -- remove this at the earliest opportunity.
    209 
    +  , mg_home_module_name_providers_map :: HomeModuleNameProvidersMap
    210 
    +    -- ^ For each module name, which home units provide it.
    205 211 
       }
    206 212
    213 
    +type HomeModuleNameProvidersMap = UniqMap ModuleName (Set UnitId)
    214 
    +
    215 
    +mkHomeModuleNameProvidersMap :: [ModuleGraphNode] -> HomeModuleNameProvidersMap
    216 
    +mkHomeModuleNameProvidersMap nodes
    217 
    +    = listToUniqMap_C Set.union $
    218 
    +      [
    219 
    +          (moduleName, Set.singleton unitID) |
    220 
    +              ModuleNode _ moduleNodeInfo <- nodes,
    221 
    +              let moduleName = moduleNodeInfoModuleName moduleNodeInfo,
    222 
    +              let unitID     = moduleNodeInfoUnitId moduleNodeInfo
    223 
    +      ]
    224 
    +
    225 
    +mgHomeModuleNameProvidersMap :: ModuleGraph -> HomeModuleNameProvidersMap
    226 
    +mgHomeModuleNameProvidersMap = mg_home_module_name_providers_map
    227 
    +
    207 228 
     -- | Why do we ever need to construct empty graphs? Is it because of one shot mode?
    208 229 
     emptyMG :: ModuleGraph
    209 230 
     emptyMG = ModuleGraph [] (graphReachability emptyGraph, const Nothing)
    210 231 
                              (graphReachability emptyGraph, const Nothing)
    211 232 
                              (graphReachability emptyGraph, const Nothing)
    212 233 
                              False
    234 
    +                         emptyUniqMap
    213 235
    214 236 
     -- | Construct a module graph. This function should be the only entry point for
    215 237 
     -- building a 'ModuleGraph', since it is supposed to be built once and never modified.
    ... ... @@ -308,7 +330,7 @@ checkModuleGraph ModuleGraph{..} =
    308 330 
       where
    309 331 
         duplicate_errs = rights (Map.elems node_types)
    310 332
    311 
    -    node_types :: Map.Map NodeKey (Either ModuleNodeType ModuleGraphInvariantError)
    333 
    +    node_types :: Map NodeKey (Either ModuleNodeType ModuleGraphInvariantError)
    312 334 
         node_types = Map.fromListWithKey go [ (mkNodeKey n, Left (moduleNodeType n)) | n <- mg_mss ]
    313 335 
           where
    314 336 
             -- Multiple nodes with the same key are not allowed.
    ... ... @@ -319,7 +341,7 @@ checkModuleGraph ModuleGraph{..} =
    319 341
    320 342 
     -- | Check that all dependencies in the graph are present in the node_types map.
    321 343 
     -- This is a helper function used by checkModuleGraph.
    322 
    -checkAllDependenciesInGraph :: Map.Map NodeKey (Either ModuleNodeType ModuleGraphInvariantError)
    344 
    +checkAllDependenciesInGraph :: Map NodeKey (Either ModuleNodeType ModuleGraphInvariantError)
    323 345 
                                 -> ModuleGraphNode
    324 346 
                                 -> Maybe ModuleGraphInvariantError
    325 347 
     checkAllDependenciesInGraph node_types node =
    ... ... @@ -334,7 +356,7 @@ checkAllDependenciesInGraph node_types node =
    334 356 
     -- | Check if for the fixed module node invariant:
    335 357 
     --
    336 358 
     --   Fixed nodes can only depend on other fixed nodes.
    337 
    -checkFixedModuleInvariant :: Map.Map NodeKey (Either ModuleNodeType ModuleGraphInvariantError)
    359 
    +checkFixedModuleInvariant :: Map NodeKey (Either ModuleNodeType ModuleGraphInvariantError)
    338 360 
                     -> ModuleGraphNode
    339 361 
                     -> Maybe ModuleGraphInvariantError
    340 362 
     checkFixedModuleInvariant node_types node = case node of
    ... ... @@ -484,13 +506,17 @@ isEmptyMG = null . mg_mss
    484 506 
     -- To preserve invariants, 'f' can't change the isBoot status.
    485 507 
     mapMG :: (ModSummary -> ModSummary) -> ModuleGraph -> ModuleGraph
    486 508 
     mapMG f mg@ModuleGraph{..} = mg
    487 
    -  { mg_mss = flip fmap mg_mss $ \case
    488 
    -      InstantiationNode uid iuid -> InstantiationNode uid iuid
    489 
    -      LinkNode uid nks -> LinkNode uid nks
    490 
    -      ModuleNode deps (ModuleNodeFixed key loc)  -> ModuleNode deps (ModuleNodeFixed key loc)
    491 
    -      ModuleNode deps (ModuleNodeCompile ms) -> ModuleNode deps (ModuleNodeCompile (f ms))
    492 
    -      UnitNode deps uid -> UnitNode deps uid
    509 
    +  { mg_mss = new_mss
    510 
    +  , mg_home_module_name_providers_map = mkHomeModuleNameProvidersMap new_mss
    493 511 
       }
    512 
    +  where
    513 
    +    new_mss =
    514 
    +      flip fmap mg_mss $ \case
    515 
    +        InstantiationNode uid iuid -> InstantiationNode uid iuid
    516 
    +        LinkNode uid nks -> LinkNode uid nks
    517 
    +        ModuleNode deps (ModuleNodeFixed key loc)  -> ModuleNode deps (ModuleNodeFixed key loc)
    518 
    +        ModuleNode deps (ModuleNodeCompile ms) -> ModuleNode deps (ModuleNodeCompile (f ms))
    519 
    +        UnitNode deps uid -> UnitNode deps uid
    494 520
    495 521 
     -- | Map a function 'f' over all the 'ModSummaries', in 'IO'.
    496 522 
     -- To preserve invariants, 'f' can't change the isBoot status.
    ... ... @@ -856,7 +882,7 @@ moduleNodeInfoBootString mn@(ModuleNodeFixed {}) =
    856 882 
     -- described in the export list haddocks.
    857 883 
     --------------------------------------------------------------------------------
    858 884
    859 
    -newtype NodeMap a = NodeMap { unNodeMap :: Map.Map NodeKey a }
    885 
    +newtype NodeMap a = NodeMap { unNodeMap :: Map NodeKey a }
    860 886 
       deriving (Functor, Traversable, Foldable)
    861 887
    862 888 
     -- | Transitive dependencies, including SOURCE edges
    ... ... @@ -932,7 +958,7 @@ moduleGraphNodesZero summaries =
    932 958 
         lookup_key :: ZeroScopeKey -> Maybe Int
    933 959 
         lookup_key = fmap zeroSummaryNodeKey . lookup_node
    934 960
    935 
    -    node_map :: Map.Map ZeroScopeKey ZeroSummaryNode
    961 
    +    node_map :: Map ZeroScopeKey ZeroSummaryNode
    936 962 
         node_map =
    937 963 
           Map.fromList [ (s, node)
    938 964 
                        | node <- nodes
    ... ... @@ -1031,7 +1057,7 @@ moduleGraphNodesStages summaries =
    1031 1057 
         lookup_key ::  (NodeKey, ModuleStage) -> Maybe Int
    1032 1058 
         lookup_key = fmap stageSummaryNodeKey . lookup_node
    1033 1059
    1034 
    -    node_map :: Map.Map (NodeKey, ModuleStage) StageSummaryNode
    1060 
    +    node_map :: Map (NodeKey, ModuleStage) StageSummaryNode
    1035 1061 
         node_map =
    1036 1062 
           Map.fromList [ (s, node)
    1037 1063 
                        | node <- nodes
    ... ... @@ -1049,10 +1075,13 @@ moduleGraphNodesStages summaries =
    1049 1075 
     extendMG :: ModuleGraph -> ModuleGraphNode -> ModuleGraph
    1050 1076 
     extendMG ModuleGraph{..} node =
    1051 1077 
       ModuleGraph
    1052 
    -    { mg_mss = node : mg_mss
    1053 
    -    , mg_graph =  mkTransDeps (node : mg_mss)
    1054 
    -    , mg_loop_graph = mkTransLoopDeps (node : mg_mss)
    1055 
    -    , mg_zero_graph = mkTransZeroDeps (node : mg_mss)
    1078 
    +    { mg_mss = new_mss
    1079 
    +    , mg_graph =  mkTransDeps new_mss
    1080 
    +    , mg_loop_graph = mkTransLoopDeps new_mss
    1081 
    +    , mg_zero_graph = mkTransZeroDeps new_mss
    1056 1082 
         , mg_has_holes = mg_has_holes || maybe False isHsigFile (moduleNodeInfoHscSource =<< mgNodeIsModule node)
    1083 
    +    , mg_home_module_name_providers_map = mkHomeModuleNameProvidersMap new_mss
    1057 1084 
         }
    1085 
    +  where
    1086 
    +    new_mss = node : mg_mss
    1058 1087

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