Torsten Schmits pushed to branch wip/torsten.schmits/unit-index-debug at Glasgow Haskell Compiler / GHC
Commits:
-
36c660e0
by Matthew Pickering at 2025-12-03T20:19:51+01:00
-
d93b96b1
by Matthew Pickering at 2025-12-03T20:19:51+01:00
-
45884d99
by Matthew Pickering at 2025-12-03T20:19:51+01:00
-
17191a26
by Matthew Pickering at 2025-12-03T20:19:51+01:00
-
0278068c
by Matthew Pickering at 2025-12-03T20:20:43+01:00
10 changed files:
- compiler/GHC/Driver/Make.hs
- compiler/GHC/Linker/Loader.hs
- compiler/GHC/Rename/Names.hs
- compiler/GHC/Unit/Env.hs
- compiler/GHC/Unit/Finder.hs
- compiler/GHC/Unit/Module/Graph.hs
- compiler/GHC/Unit/State.hs
- ghc/Main.hs
- testsuite/tests/ghc-api/downsweep/OldModLocation.hs
- testsuite/tests/ghc-api/downsweep/PartialDownsweep.hs
Changes:
| ... | ... | @@ -114,6 +114,8 @@ import Data.Either ( rights, partitionEithers, lefts ) |
| 114 | 114 | import qualified Data.Map as Map
|
| 115 | 115 | import qualified Data.Set as Set
|
| 116 | 116 | |
| 117 | +import GHC.Data.OsPath (OsPath)
|
|
| 118 | +import qualified GHC.Data.OsPath as OsPath
|
|
| 117 | 119 | import Control.Concurrent ( newQSem, waitQSem, signalQSem, ThreadId, killThread, forkIOWithUnmask )
|
| 118 | 120 | import qualified GHC.Conc as CC
|
| 119 | 121 | import Control.Concurrent.MVar
|
| ... | ... | @@ -247,7 +249,7 @@ depanalPartial excluded_mods allow_dup_roots = do |
| 247 | 249 | liftIO $ flushFinderCaches (hsc_FC hsc_env) (hsc_unit_env hsc_env)
|
| 248 | 250 | |
| 249 | 251 | (errs, graph_nodes) <- liftIO $ downsweep
|
| 250 | - hsc_env (mgModSummaries old_graph)
|
|
| 252 | + hsc_env (mgModSummaries old_graph) (Just old_graph)
|
|
| 251 | 253 | excluded_mods allow_dup_roots
|
| 252 | 254 | let
|
| 253 | 255 | mod_graph = mkModuleGraph graph_nodes
|
| ... | ... | @@ -1541,6 +1543,10 @@ warnUnnecessarySourceImports sccs = do |
| 1541 | 1543 | -- an import of this module mean.
|
| 1542 | 1544 | type DownsweepCache = M.Map (UnitId, PkgQual, ModuleNameWithIsBoot) [Either DriverMessages ModSummary]
|
| 1543 | 1545 | |
| 1546 | +moduleGraphNodeMap :: ModuleGraph -> M.Map NodeKey ModuleGraphNode
|
|
| 1547 | +moduleGraphNodeMap graph =
|
|
| 1548 | + M.fromList [(mkNodeKey node, node) | node <- mgModSummaries' graph]
|
|
| 1549 | + |
|
| 1544 | 1550 | -----------------------------------------------------------------------------
|
| 1545 | 1551 | --
|
| 1546 | 1552 | -- | Downsweep (dependency analysis)
|
| ... | ... | @@ -1559,6 +1565,8 @@ type DownsweepCache = M.Map (UnitId, PkgQual, ModuleNameWithIsBoot) [Either Driv |
| 1559 | 1565 | downsweep :: HscEnv
|
| 1560 | 1566 | -> [ModSummary]
|
| 1561 | 1567 | -- ^ Old summaries
|
| 1568 | + -> Maybe ModuleGraph
|
|
| 1569 | + -- ^ Existing module graph to reuse cached nodes from
|
|
| 1562 | 1570 | -> [ModuleName] -- Ignore dependencies on these; treat
|
| 1563 | 1571 | -- them as if they were package modules
|
| 1564 | 1572 | -> Bool -- True <=> allow multiple targets to have
|
| ... | ... | @@ -1568,10 +1576,10 @@ downsweep :: HscEnv |
| 1568 | 1576 | -- The non-error elements of the returned list all have distinct
|
| 1569 | 1577 | -- (Modules, IsBoot) identifiers, unless the Bool is true in
|
| 1570 | 1578 | -- which case there can be repeats
|
| 1571 | -downsweep hsc_env old_summaries excl_mods allow_dup_roots = do
|
|
| 1579 | +downsweep hsc_env old_summaries old_graph excl_mods allow_dup_roots = do
|
|
| 1572 | 1580 | n_jobs <- mkWorkerLimit (hsc_dflags hsc_env)
|
| 1573 | 1581 | new <- rootSummariesParallel n_jobs hsc_env summary
|
| 1574 | - downsweep_imports hsc_env old_summary_map excl_mods allow_dup_roots new
|
|
| 1582 | + downsweep_imports hsc_env old_summary_map old_graph excl_mods allow_dup_roots new
|
|
| 1575 | 1583 | where
|
| 1576 | 1584 | summary = getRootSummary excl_mods old_summary_map
|
| 1577 | 1585 | |
| ... | ... | @@ -1580,21 +1588,23 @@ downsweep hsc_env old_summaries excl_mods allow_dup_roots = do |
| 1580 | 1588 | -- file was used in.
|
| 1581 | 1589 | -- Reuse these if we can because the most expensive part of downsweep is
|
| 1582 | 1590 | -- reading the headers.
|
| 1583 | - old_summary_map :: M.Map (UnitId, FilePath) ModSummary
|
|
| 1591 | + old_summary_map :: M.Map (UnitId, OsPath) ModSummary
|
|
| 1584 | 1592 | old_summary_map =
|
| 1585 | - M.fromList [((ms_unitid ms, msHsFilePath ms), ms) | ms <- old_summaries]
|
|
| 1593 | + M.fromList [((ms_unitid ms, OsPath.unsafeEncodeUtf (msHsFilePath ms)), ms) | ms <- old_summaries]
|
|
| 1586 | 1594 | |
| 1587 | 1595 | downsweep_imports :: HscEnv
|
| 1588 | - -> M.Map (UnitId, FilePath) ModSummary
|
|
| 1596 | + -> M.Map (UnitId, OsPath) ModSummary
|
|
| 1597 | + -> Maybe ModuleGraph
|
|
| 1589 | 1598 | -> [ModuleName]
|
| 1590 | 1599 | -> Bool
|
| 1591 | 1600 | -> ([(UnitId, DriverMessages)], [ModSummary])
|
| 1592 | 1601 | -> IO ([DriverMessages], [ModuleGraphNode])
|
| 1593 | -downsweep_imports hsc_env old_summaries excl_mods allow_dup_roots (root_errs, rootSummariesOk)
|
|
| 1602 | +downsweep_imports hsc_env old_summaries old_graph excl_mods allow_dup_roots (root_errs, rootSummariesOk)
|
|
| 1594 | 1603 | = do
|
| 1595 | 1604 | let root_map = mkRootMap rootSummariesOk
|
| 1596 | 1605 | checkDuplicates root_map
|
| 1597 | - (deps, map0) <- loopSummaries rootSummariesOk (M.empty, root_map)
|
|
| 1606 | + let done0 = maybe M.empty moduleGraphNodeMap old_graph
|
|
| 1607 | + (deps, map0) <- loopSummaries rootSummariesOk (done0, root_map)
|
|
| 1598 | 1608 | let closure_errs = checkHomeUnitsClosed (hsc_unit_env hsc_env)
|
| 1599 | 1609 | let unit_env = hsc_unit_env hsc_env
|
| 1600 | 1610 | let tmpfs = hsc_tmpfs hsc_env
|
| ... | ... | @@ -1725,7 +1735,7 @@ downsweep_imports hsc_env old_summaries excl_mods allow_dup_roots (root_errs, ro |
| 1725 | 1735 | |
| 1726 | 1736 | getRootSummary ::
|
| 1727 | 1737 | [ModuleName] ->
|
| 1728 | - M.Map (UnitId, FilePath) ModSummary ->
|
|
| 1738 | + M.Map (UnitId, OsPath) ModSummary ->
|
|
| 1729 | 1739 | HscEnv ->
|
| 1730 | 1740 | Target ->
|
| 1731 | 1741 | IO (Either (UnitId, DriverMessages) ModSummary)
|
| ... | ... | @@ -2071,7 +2081,7 @@ mkRootMap summaries = Map.fromListWith (flip (++)) |
| 2071 | 2081 | summariseFile
|
| 2072 | 2082 | :: HscEnv
|
| 2073 | 2083 | -> HomeUnit
|
| 2074 | - -> M.Map (UnitId, FilePath) ModSummary -- old summaries
|
|
| 2084 | + -> M.Map (UnitId, OsPath) ModSummary -- old summaries
|
|
| 2075 | 2085 | -> FilePath -- source file name
|
| 2076 | 2086 | -> Maybe Phase -- start phase
|
| 2077 | 2087 | -> Maybe (StringBuffer,UTCTime)
|
| ... | ... | @@ -2080,7 +2090,7 @@ summariseFile |
| 2080 | 2090 | summariseFile hsc_env' home_unit old_summaries src_fn mb_phase maybe_buf
|
| 2081 | 2091 | -- we can use a cached summary if one is available and the
|
| 2082 | 2092 | -- source file hasn't changed,
|
| 2083 | - | Just old_summary <- M.lookup (homeUnitId home_unit, src_fn) old_summaries
|
|
| 2093 | + | Just old_summary <- M.lookup (homeUnitId home_unit, src_fn_os) old_summaries
|
|
| 2084 | 2094 | = do
|
| 2085 | 2095 | let location = ms_location $ old_summary
|
| 2086 | 2096 | |
| ... | ... | @@ -2101,6 +2111,7 @@ summariseFile hsc_env' home_unit old_summaries src_fn mb_phase maybe_buf |
| 2101 | 2111 | where
|
| 2102 | 2112 | -- change the main active unit so all operations happen relative to the given unit
|
| 2103 | 2113 | hsc_env = hscSetActiveHomeUnit home_unit hsc_env'
|
| 2114 | + src_fn_os = OsPath.unsafeEncodeUtf src_fn
|
|
| 2104 | 2115 | -- src_fn does not necessarily exist on the filesystem, so we need to
|
| 2105 | 2116 | -- check what kind of target we are dealing with
|
| 2106 | 2117 | get_src_hash = case maybe_buf of
|
| ... | ... | @@ -2190,7 +2201,7 @@ data SummariseResult = |
| 2190 | 2201 | summariseModule
|
| 2191 | 2202 | :: HscEnv
|
| 2192 | 2203 | -> HomeUnit
|
| 2193 | - -> M.Map (UnitId, FilePath) ModSummary
|
|
| 2204 | + -> M.Map (UnitId, OsPath) ModSummary
|
|
| 2194 | 2205 | -- ^ Map of old summaries
|
| 2195 | 2206 | -> IsBootInterface -- True <=> a {-# SOURCE #-} import
|
| 2196 | 2207 | -> Located ModuleName -- Imported module to be summarised
|
| ... | ... | @@ -2251,7 +2262,7 @@ summariseModule hsc_env' home_unit old_summary_map is_boot (L _ wanted_mod) mb_p |
| 2251 | 2262 | Right ms -> FoundHome ms
|
| 2252 | 2263 | |
| 2253 | 2264 | new_summary_cache_check loc mod src_fn h
|
| 2254 | - | Just old_summary <- Map.lookup ((toUnitId (moduleUnit mod), src_fn)) old_summary_map =
|
|
| 2265 | + | Just old_summary <- Map.lookup ((toUnitId (moduleUnit mod), src_fn_os)) old_summary_map =
|
|
| 2255 | 2266 | |
| 2256 | 2267 | -- check the hash on the source file, and
|
| 2257 | 2268 | -- return the cached summary if it hasn't changed. If the
|
| ... | ... | @@ -2262,6 +2273,8 @@ summariseModule hsc_env' home_unit old_summary_map is_boot (L _ wanted_mod) mb_p |
| 2262 | 2273 | Nothing ->
|
| 2263 | 2274 | checkSummaryHash hsc_env (new_summary loc mod src_fn) old_summary loc h
|
| 2264 | 2275 | | otherwise = new_summary loc mod src_fn h
|
| 2276 | + where
|
|
| 2277 | + src_fn_os = OsPath.unsafeEncodeUtf src_fn
|
|
| 2265 | 2278 | |
| 2266 | 2279 | new_summary :: ModLocation
|
| 2267 | 2280 | -> Module
|
| ... | ... | @@ -358,7 +358,7 @@ loadCmdLineLibs' interp hsc_env pls = snd <$> |
| 358 | 358 | let hsc' = hscSetActiveUnitId uid hsc_env
|
| 359 | 359 | -- Load potential dependencies first
|
| 360 | 360 | (done', pls') <- foldM (\(done', pls') uid -> load done' uid pls') (done, pls)
|
| 361 | - (homeUnitDepends (hsc_units hsc'))
|
|
| 361 | + (Set.toList (homeUnitDepends (hsc_units hsc')))
|
|
| 362 | 362 | pls'' <- loadCmdLineLibs'' interp hsc' pls'
|
| 363 | 363 | return $ (Set.insert uid done', pls'')
|
| 364 | 364 |
| ... | ... | @@ -475,11 +475,14 @@ renamePkgQual unit_env query mn mb_pkg = case mb_pkg of |
| 475 | 475 | -- not really correct as pkg_fs is unlikely to be a valid unit-id but
|
| 476 | 476 | -- we will report the failure later...
|
| 477 | 477 | where
|
| 478 | - home_names = map (\uid -> (uid, mkFastString <$> thisPackageName (homeUnitEnv_dflags (ue_findHomeUnitEnv uid unit_env)))) hpt_deps
|
|
| 478 | + home_names =
|
|
| 479 | + [ (uid, mkFastString <$> thisPackageName (homeUnitEnv_dflags (ue_findHomeUnitEnv uid unit_env)))
|
|
| 480 | + | uid <- S.toList hpt_deps
|
|
| 481 | + ]
|
|
| 479 | 482 | |
| 480 | 483 | units = ue_units unit_env
|
| 481 | 484 | |
| 482 | - hpt_deps :: [UnitId]
|
|
| 485 | + hpt_deps :: S.Set UnitId
|
|
| 483 | 486 | hpt_deps = homeUnitDepends units
|
| 484 | 487 | |
| 485 | 488 | hscRenameRawPkgQual ::
|
| ... | ... | @@ -142,7 +142,7 @@ ue_transitiveHomeDeps uid unit_env = Set.toList (loop Set.empty [uid]) |
| 142 | 142 | loop acc (uid:uids)
|
| 143 | 143 | | uid `Set.member` acc = loop acc uids
|
| 144 | 144 | | otherwise =
|
| 145 | - let hue = homeUnitDepends (homeUnitEnv_units (ue_findHomeUnitEnv uid unit_env))
|
|
| 145 | + let hue = Set.toList (homeUnitDepends (homeUnitEnv_units (ue_findHomeUnitEnv uid unit_env)))
|
|
| 146 | 146 | in loop (Set.insert uid acc) (hue ++ uids)
|
| 147 | 147 | |
| 148 | 148 |
| ... | ... | @@ -68,8 +68,9 @@ import Control.Monad |
| 68 | 68 | import Data.Time
|
| 69 | 69 | import qualified Data.Map as M
|
| 70 | 70 | import GHC.Driver.Env
|
| 71 | - ( hsc_home_unit_maybe, HscEnv(hsc_FC, hsc_dflags, hsc_unit_env), hscUnitIndexQuery )
|
|
| 71 | + ( hsc_home_unit_maybe, HscEnv(hsc_FC, hsc_dflags, hsc_unit_env, hsc_mod_graph), hscUnitIndexQuery )
|
|
| 72 | 72 | import GHC.Driver.Config.Finder
|
| 73 | +import GHC.Unit.Module.Graph (mgHomeModuleMap, ModuleNameHomeMap)
|
|
| 73 | 74 | import qualified Data.Set as Set
|
| 74 | 75 | import qualified Data.List.NonEmpty as NE
|
| 75 | 76 | |
| ... | ... | @@ -163,30 +164,36 @@ findImportedModule hsc_env mod pkg_qual = |
| 163 | 164 | dflags = hsc_dflags hsc_env
|
| 164 | 165 | fopts = initFinderOpts dflags
|
| 165 | 166 | in do
|
| 167 | + let home_module_map = mgHomeModuleMap (hsc_mod_graph hsc_env)
|
|
| 166 | 168 | query <- hscUnitIndexQuery hsc_env
|
| 167 | - findImportedModuleNoHsc fc fopts (hsc_unit_env hsc_env) query mhome_unit mod pkg_qual
|
|
| 169 | + findImportedModuleNoHsc fc fopts (hsc_unit_env hsc_env) query home_module_map mhome_unit mod pkg_qual
|
|
| 168 | 170 | |
| 169 | 171 | findImportedModuleNoHsc
|
| 170 | 172 | :: FinderCache
|
| 171 | 173 | -> FinderOpts
|
| 172 | 174 | -> UnitEnv
|
| 173 | 175 | -> UnitIndexQuery
|
| 176 | + -> ModuleNameHomeMap
|
|
| 174 | 177 | -> Maybe HomeUnit
|
| 175 | 178 | -> ModuleName
|
| 176 | 179 | -> PkgQual
|
| 177 | 180 | -> IO FindResult
|
| 178 | -findImportedModuleNoHsc fc fopts ue query mhome_unit mod_name mb_pkg =
|
|
| 181 | +findImportedModuleNoHsc fc fopts ue query home_module_map mhome_unit mod_name mb_pkg =
|
|
| 179 | 182 | case mb_pkg of
|
| 180 | 183 | NoPkgQual -> unqual_import
|
| 181 | 184 | ThisPkg uid | (homeUnitId <$> mhome_unit) == Just uid -> home_import
|
| 182 | - | Just os <- lookup uid other_fopts -> home_pkg_import (uid, os)
|
|
| 185 | + | Just os <- M.lookup uid other_fopts_map -> home_pkg_import (uid, os)
|
|
| 183 | 186 | | otherwise -> pprPanic "findImportModule" (ppr mod_name $$ ppr mb_pkg $$ ppr (homeUnitId <$> mhome_unit) $$ ppr uid $$ ppr (map fst all_opts))
|
| 184 | 187 | OtherPkg _ -> pkg_import
|
| 185 | 188 | where
|
| 189 | + (complete_units, module_name_map) = home_module_map
|
|
| 190 | + module_home_units = M.findWithDefault Set.empty mod_name module_name_map
|
|
| 191 | + current_unit_id = homeUnitId <$> mhome_unit
|
|
| 186 | 192 | all_opts = case mhome_unit of
|
| 187 | - Nothing -> other_fopts
|
|
| 188 | - Just home_unit -> (homeUnitId home_unit, fopts) : other_fopts
|
|
| 193 | + Nothing -> other_fopts_list
|
|
| 194 | + Just home_unit -> (homeUnitId home_unit, fopts) : other_fopts_list
|
|
| 189 | 195 | |
| 196 | + other_fopts_map = M.fromList other_fopts_list
|
|
| 190 | 197 | |
| 191 | 198 | home_import = case mhome_unit of
|
| 192 | 199 | Just home_unit -> findHomeModule fc fopts home_unit mod_name
|
| ... | ... | @@ -197,7 +204,7 @@ findImportedModuleNoHsc fc fopts ue query mhome_unit mod_name mb_pkg = |
| 197 | 204 | -- If the module is reexported, then look for it as if it was from the perspective
|
| 198 | 205 | -- of that package which reexports it.
|
| 199 | 206 | | mod_name `Set.member` finder_reexportedModules opts =
|
| 200 | - findImportedModuleNoHsc fc opts ue query (Just $ DefiniteHomeUnit uid Nothing) mod_name NoPkgQual
|
|
| 207 | + findImportedModuleNoHsc fc opts ue query home_module_map (Just $ DefiniteHomeUnit uid Nothing) mod_name NoPkgQual
|
|
| 201 | 208 | | mod_name `Set.member` finder_hiddenModules opts =
|
| 202 | 209 | return (mkHomeHidden uid)
|
| 203 | 210 | | otherwise =
|
| ... | ... | @@ -206,7 +213,7 @@ findImportedModuleNoHsc fc fopts ue query mhome_unit mod_name mb_pkg = |
| 206 | 213 | -- Do not be smart and change this to `foldr orIfNotFound home_import hs` as
|
| 207 | 214 | -- that is not the same!! home_import is first because we need to look within ourselves
|
| 208 | 215 | -- first before looking at the packages in order.
|
| 209 | - any_home_import = foldr1 orIfNotFound (home_import: map home_pkg_import other_fopts)
|
|
| 216 | + any_home_import = foldr1 orIfNotFound (home_import: map home_pkg_import other_fopts_list)
|
|
| 210 | 217 | |
| 211 | 218 | pkg_import = findExposedPackageModule fc fopts units query mod_name mb_pkg
|
| 212 | 219 | |
| ... | ... | @@ -217,9 +224,21 @@ findImportedModuleNoHsc fc fopts ue query mhome_unit mod_name mb_pkg = |
| 217 | 224 | units = case mhome_unit of
|
| 218 | 225 | Nothing -> ue_units ue
|
| 219 | 226 | Just home_unit -> homeUnitEnv_units $ ue_findHomeUnitEnv (homeUnitId home_unit) ue
|
| 220 | - hpt_deps :: [UnitId]
|
|
| 227 | + hpt_deps :: Set.Set UnitId
|
|
| 221 | 228 | hpt_deps = homeUnitDepends units
|
| 222 | - other_fopts = map (\uid -> (uid, initFinderOpts (homeUnitEnv_dflags (ue_findHomeUnitEnv uid ue)))) hpt_deps
|
|
| 229 | + dep_providers = Set.intersection module_home_units hpt_deps
|
|
| 230 | + known_other_uids =
|
|
| 231 | + let providers = maybe dep_providers (\u -> Set.delete u dep_providers) current_unit_id
|
|
| 232 | + in Set.toList providers
|
|
| 233 | + unknown_units =
|
|
| 234 | + let candidates = Set.difference hpt_deps complete_units
|
|
| 235 | + excluded = maybe dep_providers (\u -> Set.insert u dep_providers) current_unit_id
|
|
| 236 | + in Set.toList (Set.difference candidates excluded)
|
|
| 237 | + other_home_uids = known_other_uids ++ unknown_units
|
|
| 238 | + other_fopts_list =
|
|
| 239 | + [ (uid, initFinderOpts (homeUnitEnv_dflags (ue_findHomeUnitEnv uid ue)))
|
|
| 240 | + | uid <- other_home_uids
|
|
| 241 | + ]
|
|
| 223 | 242 | |
| 224 | 243 | -- | Locate a plugin module requested by the user, for a compiler
|
| 225 | 244 | -- plugin. This consults the same set of exposed packages as
|
| ... | ... | @@ -18,6 +18,8 @@ module GHC.Unit.Module.Graph |
| 18 | 18 | , mgModSummaries
|
| 19 | 19 | , mgModSummaries'
|
| 20 | 20 | , mgLookupModule
|
| 21 | + , ModuleNameHomeMap
|
|
| 22 | + , mgHomeModuleMap
|
|
| 21 | 23 | , showModMsg
|
| 22 | 24 | , moduleGraphNodeModule
|
| 23 | 25 | , moduleGraphNodeModSum
|
| ... | ... | @@ -153,23 +155,31 @@ instance Outputable ModNodeKeyWithUid where |
| 153 | 155 | -- check that the module and its hs-boot agree.
|
| 154 | 156 | --
|
| 155 | 157 | -- The graph is not necessarily stored in topologically-sorted order. Use
|
| 158 | +type ModuleNameHomeMap = (Set UnitId, Map.Map ModuleName (Set UnitId))
|
|
| 159 | + |
|
| 156 | 160 | -- 'GHC.topSortModuleGraph' and 'GHC.Data.Graph.Directed.flattenSCC' to achieve this.
|
| 157 | 161 | data ModuleGraph = ModuleGraph
|
| 158 | 162 | { mg_mss :: [ModuleGraphNode]
|
| 159 | 163 | , mg_graph :: (ReachabilityIndex SummaryNode, NodeKey -> Maybe SummaryNode)
|
| 160 | 164 | -- A cached transitive dependency calculation so that a lot of work is not
|
| 161 | 165 | -- repeated whenever the transitive dependencies need to be calculated (for example, hptInstances)
|
| 166 | + , mg_home_map :: ModuleNameHomeMap
|
|
| 167 | + -- ^ For each module name, which home-unit UnitIds define it together with the set of units for which the listing is complete.
|
|
| 162 | 168 | }
|
| 163 | 169 | |
| 164 | 170 | -- | Map a function 'f' over all the 'ModSummaries'.
|
| 165 | 171 | -- To preserve invariants 'f' can't change the isBoot status.
|
| 166 | 172 | mapMG :: (ModSummary -> ModSummary) -> ModuleGraph -> ModuleGraph
|
| 167 | 173 | mapMG f mg@ModuleGraph{..} = mg
|
| 168 | - { mg_mss = flip fmap mg_mss $ \case
|
|
| 169 | - InstantiationNode uid iuid -> InstantiationNode uid iuid
|
|
| 170 | - LinkNode uid nks -> LinkNode uid nks
|
|
| 171 | - ModuleNode deps ms -> ModuleNode deps (f ms)
|
|
| 174 | + { mg_mss = new_mss
|
|
| 175 | + , mg_home_map = mkHomeModuleMap new_mss
|
|
| 172 | 176 | }
|
| 177 | + where
|
|
| 178 | + new_mss =
|
|
| 179 | + flip fmap mg_mss $ \case
|
|
| 180 | + InstantiationNode uid iuid -> InstantiationNode uid iuid
|
|
| 181 | + LinkNode uid nks -> LinkNode uid nks
|
|
| 182 | + ModuleNode deps ms -> ModuleNode deps (f ms)
|
|
| 173 | 183 | |
| 174 | 184 | unionMG :: ModuleGraph -> ModuleGraph -> ModuleGraph
|
| 175 | 185 | unionMG a b =
|
| ... | ... | @@ -177,11 +187,27 @@ unionMG a b = |
| 177 | 187 | in ModuleGraph {
|
| 178 | 188 | mg_mss = new_mss
|
| 179 | 189 | , mg_graph = mkTransDeps new_mss
|
| 190 | + , mg_home_map = mkHomeModuleMap new_mss
|
|
| 180 | 191 | }
|
| 181 | 192 | |
| 182 | 193 | mkTransDeps :: [ModuleGraphNode] -> (ReachabilityIndex SummaryNode, NodeKey -> Maybe SummaryNode)
|
| 183 | 194 | mkTransDeps = first graphReachability {- module graph is acyclic -} . moduleGraphNodes False
|
| 184 | 195 | |
| 196 | +mkHomeModuleMap :: [ModuleGraphNode] -> ModuleNameHomeMap
|
|
| 197 | +mkHomeModuleMap nodes =
|
|
| 198 | + (complete_units, provider_map)
|
|
| 199 | + where
|
|
| 200 | + provider_map =
|
|
| 201 | + Map.fromListWith Set.union
|
|
| 202 | + [ (ms_mod_name ms, Set.singleton (ms_unitid ms))
|
|
| 203 | + | ModuleNode _ ms <- nodes
|
|
| 204 | + ]
|
|
| 205 | + complete_units =
|
|
| 206 | + Set.fromList
|
|
| 207 | + [ ms_unitid ms
|
|
| 208 | + | ModuleNode _ ms <- nodes
|
|
| 209 | + ]
|
|
| 210 | + |
|
| 185 | 211 | mgModSummaries :: ModuleGraph -> [ModSummary]
|
| 186 | 212 | mgModSummaries mg = [ m | ModuleNode _ m <- mgModSummaries' mg ]
|
| 187 | 213 | |
| ... | ... | @@ -200,8 +226,11 @@ mgLookupModule ModuleGraph{..} m = listToMaybe $ mapMaybe go mg_mss |
| 200 | 226 | = Just ms
|
| 201 | 227 | go _ = Nothing
|
| 202 | 228 | |
| 229 | +mgHomeModuleMap :: ModuleGraph -> ModuleNameHomeMap
|
|
| 230 | +mgHomeModuleMap = mg_home_map
|
|
| 231 | + |
|
| 203 | 232 | emptyMG :: ModuleGraph
|
| 204 | -emptyMG = ModuleGraph [] (graphReachability emptyGraph, const Nothing)
|
|
| 233 | +emptyMG = ModuleGraph [] (graphReachability emptyGraph, const Nothing) (Set.empty, Map.empty)
|
|
| 205 | 234 | |
| 206 | 235 | isTemplateHaskellOrQQNonBoot :: ModSummary -> Bool
|
| 207 | 236 | isTemplateHaskellOrQQNonBoot ms =
|
| ... | ... | @@ -213,9 +242,12 @@ isTemplateHaskellOrQQNonBoot ms = |
| 213 | 242 | -- not an element of the ModuleGraph.
|
| 214 | 243 | extendMG :: ModuleGraph -> [NodeKey] -> ModSummary -> ModuleGraph
|
| 215 | 244 | extendMG ModuleGraph{..} deps ms = ModuleGraph
|
| 216 | - { mg_mss = ModuleNode deps ms : mg_mss
|
|
| 217 | - , mg_graph = mkTransDeps (ModuleNode deps ms : mg_mss)
|
|
| 245 | + { mg_mss = new_mss
|
|
| 246 | + , mg_graph = mkTransDeps new_mss
|
|
| 247 | + , mg_home_map = mkHomeModuleMap new_mss
|
|
| 218 | 248 | }
|
| 249 | + where
|
|
| 250 | + new_mss = ModuleNode deps ms : mg_mss
|
|
| 219 | 251 | |
| 220 | 252 | extendMGInst :: ModuleGraph -> UnitId -> InstantiatedUnit -> ModuleGraph
|
| 221 | 253 | extendMGInst mg uid depUnitId = mg
|
| ... | ... | @@ -469,7 +469,7 @@ data UnitState = UnitState { |
| 469 | 469 | -- -Wunused-packages warning.
|
| 470 | 470 | explicitUnits :: [(Unit, Maybe PackageArg)],
|
| 471 | 471 | |
| 472 | - homeUnitDepends :: [UnitId],
|
|
| 472 | + homeUnitDepends :: Set UnitId,
|
|
| 473 | 473 | |
| 474 | 474 | -- | This is a full map from 'ModuleName' to all modules which may possibly
|
| 475 | 475 | -- be providing it. These providers may be hidden (but we'll still want
|
| ... | ... | @@ -504,7 +504,7 @@ emptyUnitState = UnitState { |
| 504 | 504 | unwireMap = emptyUniqMap,
|
| 505 | 505 | preloadUnits = [],
|
| 506 | 506 | explicitUnits = [],
|
| 507 | - homeUnitDepends = [],
|
|
| 507 | + homeUnitDepends = Set.empty,
|
|
| 508 | 508 | moduleNameProvidersMap = emptyUniqMap,
|
| 509 | 509 | pluginModuleNameProvidersMap = emptyUniqMap,
|
| 510 | 510 | requirementContext = emptyUniqMap,
|
| ... | ... | @@ -1573,7 +1573,7 @@ mkUnitState logger cfg index = do |
| 1573 | 1573 | let !state = UnitState
|
| 1574 | 1574 | { preloadUnits = dep_preload
|
| 1575 | 1575 | , explicitUnits = explicit_pkgs
|
| 1576 | - , homeUnitDepends = Set.toList home_unit_deps
|
|
| 1576 | + , homeUnitDepends = home_unit_deps
|
|
| 1577 | 1577 | , unitInfoMap = pkg_db
|
| 1578 | 1578 | , preloadClosure = emptyUniqSet
|
| 1579 | 1579 | , moduleNameProvidersMap
|
| ... | ... | @@ -893,7 +893,7 @@ checkUnitCycles :: DynFlags -> UnitEnvGraph HomeUnitEnv -> Ghc () |
| 893 | 893 | checkUnitCycles dflags graph = processSCCs sccs
|
| 894 | 894 | where
|
| 895 | 895 | mkNode :: (UnitId, HomeUnitEnv) -> Node UnitId UnitId
|
| 896 | - mkNode (uid, hue) = DigraphNode uid uid (homeUnitDepends (homeUnitEnv_units hue))
|
|
| 896 | + mkNode (uid, hue) = DigraphNode uid uid (Set.toList (homeUnitDepends (homeUnitEnv_units hue)))
|
|
| 897 | 897 | nodes = map mkNode (unitEnv_elts graph)
|
| 898 | 898 | |
| 899 | 899 | sccs = stronglyConnCompFromEdgedVerticesOrd nodes
|
| ... | ... | @@ -47,13 +47,13 @@ main = do |
| 47 | 47 | |
| 48 | 48 | liftIO $ do
|
| 49 | 49 | |
| 50 | - _emss <- downsweep hsc_env [] [] False
|
|
| 50 | + _emss <- downsweep hsc_env [] Nothing [] False
|
|
| 51 | 51 | |
| 52 | 52 | flushFinderCaches (hsc_FC hsc_env) (hsc_unit_env hsc_env)
|
| 53 | 53 | createDirectoryIfMissing False "mydir"
|
| 54 | 54 | renameFile "B.hs" "mydir/B.hs"
|
| 55 | 55 | |
| 56 | - (_, nodes) <- downsweep hsc_env [] [] False
|
|
| 56 | + (_, nodes) <- downsweep hsc_env [] Nothing [] False
|
|
| 57 | 57 | |
| 58 | 58 | -- If 'checkSummaryTimestamp' were to call 'addHomeModuleToFinder' with
|
| 59 | 59 | -- (ms_location old_summary) like summariseFile used to instead of
|
| ... | ... | @@ -168,7 +168,7 @@ go label mods cnd = |
| 168 | 168 | setTargets [tgt]
|
| 169 | 169 | |
| 170 | 170 | hsc_env <- getSession
|
| 171 | - (_, nodes) <- liftIO $ downsweep hsc_env [] [] False
|
|
| 171 | + (_, nodes) <- liftIO $ downsweep hsc_env [] Nothing [] False
|
|
| 172 | 172 | |
| 173 | 173 | it label $ cnd (mapMaybe moduleGraphNodeModSum nodes)
|
| 174 | 174 |