+section: compiler

+synopsis: Introduce a cache of home module name providers

+issues: #27055

+mrs: !15888

+description: {

+    This contribution optimizes the algorithm for finding out which home

+    unit provides the module that a certain import declaration refers

+    to. The previous approach has been to simply search all home units

+    in no particular order. This change introduces a cache that allows

+    for efficiently determining those complete home units that provide a

+    certain module name and changes the module-finding algorithm such

+    that it searches these units before the other home units. This leads

+    to significant performance improvements in situations where there

+    are lots of home units.

+}

+import GHC.Unit.Module.Graph

+       (

+           HomeModuleNameProvidersMap,

+           mgHomeModuleNameProvidersMap

+       )

+import Data.Set (Set)

+import qualified Data.Set as Set (empty, intersection, difference, null, toList)

+  let fc           = hsc_FC hsc_env

+      mb_home_unit = hsc_home_unit_maybe hsc_env

+      dflags       = hsc_dflags hsc_env

+      fopts        = initFinderOpts dflags

+    let home_module_name_providers_map = mgHomeModuleNameProvidersMap (hsc_mod_graph hsc_env)

+    findImportedModuleNoHsc fc fopts (hsc_unit_env hsc_env) home_module_name_providers_map mb_home_unit mod pkg_qual

+  -> HomeModuleNameProvidersMap

+findImportedModuleNoHsc fc fopts ue home_module_name_providers_map mb_home_unit mod_name mb_pkg =

+    ThisPkg uid | (homeUnitId <$> mb_home_unit) == Just uid -> home_import

+                | otherwise -> pprPanic "findImportModule" (ppr mod_name $$ ppr mb_pkg $$ ppr (homeUnitId <$> mb_home_unit) $$ ppr uid $$ ppr (map fst all_opts))

+    mb_home_unit_id :: Maybe UnitId

+    mb_home_unit_id = homeUnitId <$> mb_home_unit

+    all_opts :: [(UnitId, FinderOpts)]

+    all_opts = case mb_home_unit_id of

+        Nothing           -> other_fopts

+        Just home_unit_id -> (home_unit_id, fopts) : other_fopts

+    home_import :: IO FindResult

+    home_import = case mb_home_unit of

+        Just home_unit -> findHomeModule fc fopts home_unit mod_name

+        Nothing        -> pure $

+                          NoPackage (panic "findImportedModule: no home-unit")

+    home_pkg_import :: (UnitId, FinderOpts) -> IO FindResult

+        -- If the module is reexported, then look for it as if it was from the

+        -- perspective of that package which reexports it.

+        | Just real_mod_name

+              <- lookupUniqMap (finder_reexportedModules opts) mod_name

+            = findImportedModuleNoHsc fc opts ue home_module_name_providers_map

+                  (Just $ DefiniteHomeUnit uid Nothing)

+                  real_mod_name

+                  NoPkgQual

+        | elementOfUniqSet mod_name (finder_hiddenModules opts)

+            = return (mkHomeHidden uid)

+        | otherwise

+            = findHomePackageModule fc opts uid mod_name

+

+    any_home_import :: IO FindResult

+    any_home_import = foldr1 orIfNotFound $

+                      home_import :| map home_pkg_import other_fopts

+    -- Do not try to be smart and change this to `foldr orIfNotFound home_import

+    -- (map home_pkg_import other_fopts)`, as that would not be the same.

+    -- `home_import` is first because we need to first look within the current

+    -- unit before looking at the other units in order.

+

+    pkg_import :: IO FindResult

+    pkg_import = findExposedPackageModule fc fopts unit_state mod_name mb_pkg

+

+    unqual_import :: IO FindResult

+    unqual_import

+        = any_home_import

+          `orIfNotFound`

+          findExposedPackageModule fc fopts unit_state mod_name NoPkgQual

+

+    unit_state :: UnitState

+    unit_state = case mb_home_unit_id of

+        Nothing           -> ue_homeUnitState ue

+        Just home_unit_id -> HUG.homeUnitEnv_units $

+                             ue_findHomeUnitEnv home_unit_id ue

+

+    home_unit_deps :: Set UnitId

+    home_unit_deps = homeUnitDepends unit_state

+

+    ranked_home_unit_deps :: [UnitId]

+    ranked_home_unit_deps = rankedHomeUnitDeps home_module_name_providers_map

+                                               mod_name

+                                               home_unit_deps

+

+    other_fopts :: [(UnitId, FinderOpts)]

+    other_fopts

+        = [

+              (uid, opts) |

+                  uid <- ranked_home_unit_deps,

+                  let opts = initFinderOpts $

+                             homeUnitEnv_dflags (ue_findHomeUnitEnv uid ue)

+          ]

+

+-- | Yields the unit IDs from the given set as a list with those that refer to

+-- providers of the given home module name coming first. This is to prioritize

+-- such providers during module finding.

+rankedHomeUnitDeps :: HomeModuleNameProvidersMap

+                   -> ModuleName

+                   -> Set UnitId

+                   -> [UnitId]

+rankedHomeUnitDeps _ _ home_unit_deps | Set.null home_unit_deps

+    = []

+-- The special handling of the situation where the dependency set is empty does

+-- not change the result, but it avoids triggering evaluation of the module

+-- graph. This is particularly important in one-shot mode, where the module

+-- graph is not needed. Computing it nevertheless would result in a, possibly

+-- dramatic, increase of memory usage. Worse, GHC would erroneously look for the

+-- sources of modules, which would, for example, cause test `boot1` to fail with

+-- the following error message:

+--

+--     B.hs:3:1: error: [GHC-87110]

+--         Could not find module ‘A’.

+--         Use -v to see a list of the files searched for.

+--       |

+--     3 | import {-# source #-} A

+--       | ^^^^^^^^^^^^^^^^^^^^^^^

+rankedHomeUnitDeps home_module_name_providers_map mod_name home_unit_deps

+    = Set.toList cached_deps ++ Set.toList uncached_deps

+    where

+

+    cached_providers :: Set UnitId

+    cached_providers = lookupWithDefaultUniqMap home_module_name_providers_map

+                                                Set.empty

+                                                mod_name

+

+    cached_deps :: Set UnitId

+    cached_deps = Set.intersection home_unit_deps cached_providers

+

+    uncached_deps :: Set UnitId

+    uncached_deps = Set.difference home_unit_deps cached_providers

+  let mb_home_unit = hsc_home_unit_maybe hsc_env

+  findPluginModuleNoHsc fc (initFinderOpts (hsc_dflags hsc_env)) units mb_home_unit mod_name

+findExactModuleNoHsc fc fopts other_fopts unit_state mb_home_unit mod is_boot = do

+  res <- case mb_home_unit of

+   , HomeModuleNameProvidersMap

+   , mgHomeModuleNameProvidersMap

+import Data.Set (Set)

+import qualified Data.Set as Set

+import Data.Map (Map)

+import GHC.Types.Unique.Map (UniqMap, emptyUniqMap, listToUniqMap_C)

+  , mg_home_module_name_providers_map :: HomeModuleNameProvidersMap

+    -- ^ For each module name, which home units provide it.

+type HomeModuleNameProvidersMap = UniqMap ModuleName (Set UnitId)

+

+mkHomeModuleNameProvidersMap :: [ModuleGraphNode] -> HomeModuleNameProvidersMap

+mkHomeModuleNameProvidersMap nodes

+    = listToUniqMap_C Set.union $

+      [

+          (moduleName, Set.singleton unitID) |

+              ModuleNode _ moduleNodeInfo <- nodes,

+              let moduleName = moduleNodeInfoModuleName moduleNodeInfo,

+              let unitID     = moduleNodeInfoUnitId moduleNodeInfo

+      ]

+

+mgHomeModuleNameProvidersMap :: ModuleGraph -> HomeModuleNameProvidersMap

+mgHomeModuleNameProvidersMap = mg_home_module_name_providers_map

+

+                         emptyUniqMap

+    node_types :: Map NodeKey (Either ModuleNodeType ModuleGraphInvariantError)

+checkAllDependenciesInGraph :: Map NodeKey (Either ModuleNodeType ModuleGraphInvariantError)

+checkFixedModuleInvariant :: Map NodeKey (Either ModuleNodeType ModuleGraphInvariantError)

+  { mg_mss = new_mss

+  , mg_home_module_name_providers_map = mkHomeModuleNameProvidersMap new_mss

+  where

+    new_mss =

+      flip fmap mg_mss $ \case

+        InstantiationNode uid iuid -> InstantiationNode uid iuid

+        LinkNode uid nks -> LinkNode uid nks

+        ModuleNode deps (ModuleNodeFixed key loc)  -> ModuleNode deps (ModuleNodeFixed key loc)

+        ModuleNode deps (ModuleNodeCompile ms) -> ModuleNode deps (ModuleNodeCompile (f ms))

+        UnitNode deps uid -> UnitNode deps uid

+newtype NodeMap a = NodeMap { unNodeMap :: Map NodeKey a }

+    node_map :: Map ZeroScopeKey ZeroSummaryNode

+    node_map :: Map (NodeKey, ModuleStage) StageSummaryNode

+    { mg_mss = new_mss

+    , mg_graph =  mkTransDeps new_mss

+    , mg_loop_graph = mkTransLoopDeps new_mss

+    , mg_zero_graph = mkTransZeroDeps new_mss

+    , mg_home_module_name_providers_map = mkHomeModuleNameProvidersMap new_mss

+  where

+    new_mss = node : mg_mss

+      fragile(27248),

+	'$(PYTHON)' genMultiComp.py 20 20

+	TEST_HC='$(TEST_HC)' TEST_HC_OPTS='$(TEST_HC_OPTS)' ./run

+

+MultiComponentModulesRecomp100:

+	'$(PYTHON)' genMultiComp.py 100 20

+       pre_cmd('$PYTHON ./genMultiComp.py 20 20'),

+test('MultiComponentModulesRecomp100',

+     [ collect_compiler_runtime(2),

+       pre_cmd('$MAKE -s --no-print-directory MultiComponentModulesRecomp100'),

+       extra_files(['genMultiComp.py']),

+       compile_timeout_multiplier(5)

+     ],

+     multiunit_compile,

+     [['unitp%d' % n for n in range(100)], '-fno-code -fwrite-interface -v0'])

+

+test('MultiComponentModules100',

+     [ collect_compiler_runtime(2),

+       pre_cmd('$PYTHON ./genMultiComp.py 100 20'),

+       extra_files(['genMultiComp.py']),

+       compile_timeout_multiplier(5)

+     ],

+     multiunit_compile,

+     [['unitp%d' % n for n in range(100)], '-fno-code -fwrite-interface -v0'])

+

+import sys

+packages = int(sys.argv[1])

+modules_per = int(sys.argv[2])