Torsten Schmits pushed to branch wip/torsten.schmits/mwb-perf-tuning at Glasgow Haskell Compiler / GHC
Commits:
-
b84be5de
by Matthew Pickering at 2025-12-05T11:20:25+01:00
9 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
- compiler/cbits/genSym.c
- ghc/Main.hs
Changes:
| ... | ... | @@ -113,6 +113,8 @@ import Data.Either ( rights, partitionEithers, lefts ) |
| 113 | 113 | import qualified Data.Map as Map
|
| 114 | 114 | import qualified Data.Set as Set
|
| 115 | 115 | |
| 116 | +import GHC.Data.OsPath (OsPath)
|
|
| 117 | +import qualified GHC.Data.OsPath as OsPath
|
|
| 116 | 118 | import Control.Concurrent ( newQSem, waitQSem, signalQSem, ThreadId, killThread, forkIOWithUnmask )
|
| 117 | 119 | import qualified GHC.Conc as CC
|
| 118 | 120 | import Control.Concurrent.MVar
|
| ... | ... | @@ -246,7 +248,7 @@ depanalPartial excluded_mods allow_dup_roots = do |
| 246 | 248 | liftIO $ flushFinderCaches (hsc_FC hsc_env) (hsc_unit_env hsc_env)
|
| 247 | 249 | |
| 248 | 250 | (errs, graph_nodes) <- liftIO $ downsweep
|
| 249 | - hsc_env (mgModSummaries old_graph)
|
|
| 251 | + hsc_env (mgModSummaries old_graph) (Just old_graph)
|
|
| 250 | 252 | excluded_mods allow_dup_roots
|
| 251 | 253 | let
|
| 252 | 254 | mod_graph = mkModuleGraph graph_nodes
|
| ... | ... | @@ -1539,6 +1541,10 @@ warnUnnecessarySourceImports sccs = do |
| 1539 | 1541 | -- an import of this module mean.
|
| 1540 | 1542 | type DownsweepCache = M.Map (UnitId, PkgQual, ModuleNameWithIsBoot) [Either DriverMessages ModSummary]
|
| 1541 | 1543 | |
| 1544 | +moduleGraphNodeMap :: ModuleGraph -> M.Map NodeKey ModuleGraphNode
|
|
| 1545 | +moduleGraphNodeMap graph =
|
|
| 1546 | + M.fromList [(mkNodeKey node, node) | node <- mgModSummaries' graph]
|
|
| 1547 | + |
|
| 1542 | 1548 | -----------------------------------------------------------------------------
|
| 1543 | 1549 | --
|
| 1544 | 1550 | -- | Downsweep (dependency analysis)
|
| ... | ... | @@ -1557,6 +1563,8 @@ type DownsweepCache = M.Map (UnitId, PkgQual, ModuleNameWithIsBoot) [Either Driv |
| 1557 | 1563 | downsweep :: HscEnv
|
| 1558 | 1564 | -> [ModSummary]
|
| 1559 | 1565 | -- ^ Old summaries
|
| 1566 | + -> Maybe ModuleGraph
|
|
| 1567 | + -- ^ Existing module graph to reuse cached nodes from
|
|
| 1560 | 1568 | -> [ModuleName] -- Ignore dependencies on these; treat
|
| 1561 | 1569 | -- them as if they were package modules
|
| 1562 | 1570 | -> Bool -- True <=> allow multiple targets to have
|
| ... | ... | @@ -1566,10 +1574,10 @@ downsweep :: HscEnv |
| 1566 | 1574 | -- The non-error elements of the returned list all have distinct
|
| 1567 | 1575 | -- (Modules, IsBoot) identifiers, unless the Bool is true in
|
| 1568 | 1576 | -- which case there can be repeats
|
| 1569 | -downsweep hsc_env old_summaries excl_mods allow_dup_roots = do
|
|
| 1577 | +downsweep hsc_env old_summaries old_graph excl_mods allow_dup_roots = do
|
|
| 1570 | 1578 | n_jobs <- mkWorkerLimit (hsc_dflags hsc_env)
|
| 1571 | 1579 | new <- rootSummariesParallel n_jobs hsc_env summary
|
| 1572 | - downsweep_imports hsc_env old_summary_map excl_mods allow_dup_roots new
|
|
| 1580 | + downsweep_imports hsc_env old_summary_map old_graph excl_mods allow_dup_roots new
|
|
| 1573 | 1581 | where
|
| 1574 | 1582 | summary = getRootSummary excl_mods old_summary_map
|
| 1575 | 1583 | |
| ... | ... | @@ -1578,21 +1586,23 @@ downsweep hsc_env old_summaries excl_mods allow_dup_roots = do |
| 1578 | 1586 | -- file was used in.
|
| 1579 | 1587 | -- Reuse these if we can because the most expensive part of downsweep is
|
| 1580 | 1588 | -- reading the headers.
|
| 1581 | - old_summary_map :: M.Map (UnitId, FilePath) ModSummary
|
|
| 1589 | + old_summary_map :: M.Map (UnitId, OsPath) ModSummary
|
|
| 1582 | 1590 | old_summary_map =
|
| 1583 | - M.fromList [((ms_unitid ms, msHsFilePath ms), ms) | ms <- old_summaries]
|
|
| 1591 | + M.fromList [((ms_unitid ms, OsPath.unsafeEncodeUtf (msHsFilePath ms)), ms) | ms <- old_summaries]
|
|
| 1584 | 1592 | |
| 1585 | 1593 | downsweep_imports :: HscEnv
|
| 1586 | - -> M.Map (UnitId, FilePath) ModSummary
|
|
| 1594 | + -> M.Map (UnitId, OsPath) ModSummary
|
|
| 1595 | + -> Maybe ModuleGraph
|
|
| 1587 | 1596 | -> [ModuleName]
|
| 1588 | 1597 | -> Bool
|
| 1589 | 1598 | -> ([(UnitId, DriverMessages)], [ModSummary])
|
| 1590 | 1599 | -> IO ([DriverMessages], [ModuleGraphNode])
|
| 1591 | -downsweep_imports hsc_env old_summaries excl_mods allow_dup_roots (root_errs, rootSummariesOk)
|
|
| 1600 | +downsweep_imports hsc_env old_summaries old_graph excl_mods allow_dup_roots (root_errs, rootSummariesOk)
|
|
| 1592 | 1601 | = do
|
| 1593 | 1602 | let root_map = mkRootMap rootSummariesOk
|
| 1594 | 1603 | checkDuplicates root_map
|
| 1595 | - (deps, map0) <- loopSummaries rootSummariesOk (M.empty, root_map)
|
|
| 1604 | + let done0 = maybe M.empty moduleGraphNodeMap old_graph
|
|
| 1605 | + (deps, map0) <- loopSummaries rootSummariesOk (done0, root_map)
|
|
| 1596 | 1606 | let closure_errs = checkHomeUnitsClosed (hsc_unit_env hsc_env)
|
| 1597 | 1607 | let unit_env = hsc_unit_env hsc_env
|
| 1598 | 1608 | let tmpfs = hsc_tmpfs hsc_env
|
| ... | ... | @@ -1723,7 +1733,7 @@ downsweep_imports hsc_env old_summaries excl_mods allow_dup_roots (root_errs, ro |
| 1723 | 1733 | |
| 1724 | 1734 | getRootSummary ::
|
| 1725 | 1735 | [ModuleName] ->
|
| 1726 | - M.Map (UnitId, FilePath) ModSummary ->
|
|
| 1736 | + M.Map (UnitId, OsPath) ModSummary ->
|
|
| 1727 | 1737 | HscEnv ->
|
| 1728 | 1738 | Target ->
|
| 1729 | 1739 | IO (Either (UnitId, DriverMessages) ModSummary)
|
| ... | ... | @@ -2069,7 +2079,7 @@ mkRootMap summaries = Map.fromListWith (flip (++)) |
| 2069 | 2079 | summariseFile
|
| 2070 | 2080 | :: HscEnv
|
| 2071 | 2081 | -> HomeUnit
|
| 2072 | - -> M.Map (UnitId, FilePath) ModSummary -- old summaries
|
|
| 2082 | + -> M.Map (UnitId, OsPath) ModSummary -- old summaries
|
|
| 2073 | 2083 | -> FilePath -- source file name
|
| 2074 | 2084 | -> Maybe Phase -- start phase
|
| 2075 | 2085 | -> Maybe (StringBuffer,UTCTime)
|
| ... | ... | @@ -2078,7 +2088,7 @@ summariseFile |
| 2078 | 2088 | summariseFile hsc_env' home_unit old_summaries src_fn mb_phase maybe_buf
|
| 2079 | 2089 | -- we can use a cached summary if one is available and the
|
| 2080 | 2090 | -- source file hasn't changed,
|
| 2081 | - | Just old_summary <- M.lookup (homeUnitId home_unit, src_fn) old_summaries
|
|
| 2091 | + | Just old_summary <- M.lookup (homeUnitId home_unit, src_fn_os) old_summaries
|
|
| 2082 | 2092 | = do
|
| 2083 | 2093 | let location = ms_location $ old_summary
|
| 2084 | 2094 | |
| ... | ... | @@ -2099,6 +2109,7 @@ summariseFile hsc_env' home_unit old_summaries src_fn mb_phase maybe_buf |
| 2099 | 2109 | where
|
| 2100 | 2110 | -- change the main active unit so all operations happen relative to the given unit
|
| 2101 | 2111 | hsc_env = hscSetActiveHomeUnit home_unit hsc_env'
|
| 2112 | + src_fn_os = OsPath.unsafeEncodeUtf src_fn
|
|
| 2102 | 2113 | -- src_fn does not necessarily exist on the filesystem, so we need to
|
| 2103 | 2114 | -- check what kind of target we are dealing with
|
| 2104 | 2115 | get_src_hash = case maybe_buf of
|
| ... | ... | @@ -2188,7 +2199,7 @@ data SummariseResult = |
| 2188 | 2199 | summariseModule
|
| 2189 | 2200 | :: HscEnv
|
| 2190 | 2201 | -> HomeUnit
|
| 2191 | - -> M.Map (UnitId, FilePath) ModSummary
|
|
| 2202 | + -> M.Map (UnitId, OsPath) ModSummary
|
|
| 2192 | 2203 | -- ^ Map of old summaries
|
| 2193 | 2204 | -> IsBootInterface -- True <=> a {-# SOURCE #-} import
|
| 2194 | 2205 | -> Located ModuleName -- Imported module to be summarised
|
| ... | ... | @@ -2249,7 +2260,7 @@ summariseModule hsc_env' home_unit old_summary_map is_boot (L _ wanted_mod) mb_p |
| 2249 | 2260 | Right ms -> FoundHome ms
|
| 2250 | 2261 | |
| 2251 | 2262 | new_summary_cache_check loc mod src_fn h
|
| 2252 | - | Just old_summary <- Map.lookup ((toUnitId (moduleUnit mod), src_fn)) old_summary_map =
|
|
| 2263 | + | Just old_summary <- Map.lookup ((toUnitId (moduleUnit mod), src_fn_os)) old_summary_map =
|
|
| 2253 | 2264 | |
| 2254 | 2265 | -- check the hash on the source file, and
|
| 2255 | 2266 | -- return the cached summary if it hasn't changed. If the
|
| ... | ... | @@ -2260,6 +2271,8 @@ summariseModule hsc_env' home_unit old_summary_map is_boot (L _ wanted_mod) mb_p |
| 2260 | 2271 | Nothing ->
|
| 2261 | 2272 | checkSummaryHash hsc_env (new_summary loc mod src_fn) old_summary loc h
|
| 2262 | 2273 | | otherwise = new_summary loc mod src_fn h
|
| 2274 | + where
|
|
| 2275 | + src_fn_os = OsPath.unsafeEncodeUtf src_fn
|
|
| 2263 | 2276 | |
| 2264 | 2277 | new_summary :: ModLocation
|
| 2265 | 2278 | -> Module
|
| ... | ... | @@ -2328,7 +2341,8 @@ makeNewModSummary hsc_env MakeNewModSummary{..} = do |
| 2328 | 2341 | hie_timestamp <- modificationTimeIfExists (ml_hie_file nms_location)
|
| 2329 | 2342 | |
| 2330 | 2343 | extra_sig_imports <- findExtraSigImports hsc_env nms_hsc_src pi_mod_name
|
| 2331 | - (implicit_sigs, _inst_deps) <- implicitRequirementsShallow (hscSetActiveUnitId (moduleUnitId nms_mod) hsc_env) pi_theimps
|
|
| 2344 | +-- (implicit_sigs, _inst_deps) <- implicitRequirementsShallow (hscSetActiveUnitId (moduleUnitId nms_mod) hsc_env) pi_theimps
|
|
| 2345 | + let implicit_sigs = []
|
|
| 2332 | 2346 | |
| 2333 | 2347 | return $
|
| 2334 | 2348 | ModSummary
|
| ... | ... | @@ -355,7 +355,7 @@ loadCmdLineLibs' interp hsc_env pls = snd <$> |
| 355 | 355 | let hsc' = hscSetActiveUnitId uid hsc_env
|
| 356 | 356 | -- Load potential dependencies first
|
| 357 | 357 | (done', pls') <- foldM (\(done', pls') uid -> load done' uid pls') (done, pls)
|
| 358 | - (homeUnitDepends (hsc_units hsc'))
|
|
| 358 | + (Set.toList (homeUnitDepends (hsc_units hsc')))
|
|
| 359 | 359 | pls'' <- loadCmdLineLibs'' interp hsc' pls'
|
| 360 | 360 | return $ (Set.insert uid done', pls'')
|
| 361 | 361 |
| ... | ... | @@ -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 | |
| 75 | 76 | type FileExt = String -- Filename extension
|
| ... | ... | @@ -163,29 +164,35 @@ findImportedModule hsc_env mod pkg_qual = |
| 163 | 164 | fopts = initFinderOpts dflags
|
| 164 | 165 | in do
|
| 165 | 166 | query <- hscUnitIndexQuery hsc_env
|
| 166 | - findImportedModuleNoHsc fc fopts (hsc_unit_env hsc_env) query mhome_unit mod pkg_qual
|
|
| 167 | + let home_module_map = mgHomeModuleMap (hsc_mod_graph hsc_env)
|
|
| 168 | + findImportedModuleNoHsc fc fopts (hsc_unit_env hsc_env) query home_module_map mhome_unit mod pkg_qual
|
|
| 167 | 169 | |
| 168 | 170 | findImportedModuleNoHsc
|
| 169 | 171 | :: FinderCache
|
| 170 | 172 | -> FinderOpts
|
| 171 | 173 | -> UnitEnv
|
| 172 | 174 | -> UnitIndexQuery
|
| 175 | + -> ModuleNameHomeMap
|
|
| 173 | 176 | -> Maybe HomeUnit
|
| 174 | 177 | -> ModuleName
|
| 175 | 178 | -> PkgQual
|
| 176 | 179 | -> IO FindResult
|
| 177 | -findImportedModuleNoHsc fc fopts ue query mhome_unit mod_name mb_pkg =
|
|
| 180 | +findImportedModuleNoHsc fc fopts ue query home_module_map mhome_unit mod_name mb_pkg =
|
|
| 178 | 181 | case mb_pkg of
|
| 179 | 182 | NoPkgQual -> unqual_import
|
| 180 | 183 | ThisPkg uid | (homeUnitId <$> mhome_unit) == Just uid -> home_import
|
| 181 | - | Just os <- lookup uid other_fopts -> home_pkg_import (uid, os)
|
|
| 184 | + | Just os <- M.lookup uid other_fopts_map -> home_pkg_import (uid, os)
|
|
| 182 | 185 | | otherwise -> pprPanic "findImportModule" (ppr mod_name $$ ppr mb_pkg $$ ppr (homeUnitId <$> mhome_unit) $$ ppr uid $$ ppr (map fst all_opts))
|
| 183 | 186 | OtherPkg _ -> pkg_import
|
| 184 | 187 | where
|
| 188 | + (complete_units, module_name_map) = home_module_map
|
|
| 189 | + module_home_units = M.findWithDefault Set.empty mod_name module_name_map
|
|
| 190 | + current_unit_id = homeUnitId <$> mhome_unit
|
|
| 185 | 191 | all_opts = case mhome_unit of
|
| 186 | - Nothing -> other_fopts
|
|
| 187 | - Just home_unit -> (homeUnitId home_unit, fopts) : other_fopts
|
|
| 192 | + Nothing -> other_fopts_list
|
|
| 193 | + Just home_unit -> (homeUnitId home_unit, fopts) : other_fopts_list
|
|
| 188 | 194 | |
| 195 | + other_fopts_map = M.fromList other_fopts_list
|
|
| 189 | 196 | |
| 190 | 197 | home_import = case mhome_unit of
|
| 191 | 198 | Just home_unit -> findHomeModule fc fopts home_unit mod_name
|
| ... | ... | @@ -196,7 +203,7 @@ findImportedModuleNoHsc fc fopts ue query mhome_unit mod_name mb_pkg = |
| 196 | 203 | -- If the module is reexported, then look for it as if it was from the perspective
|
| 197 | 204 | -- of that package which reexports it.
|
| 198 | 205 | | mod_name `Set.member` finder_reexportedModules opts =
|
| 199 | - findImportedModuleNoHsc fc opts ue query (Just $ DefiniteHomeUnit uid Nothing) mod_name NoPkgQual
|
|
| 206 | + findImportedModuleNoHsc fc opts ue query home_module_map (Just $ DefiniteHomeUnit uid Nothing) mod_name NoPkgQual
|
|
| 200 | 207 | | mod_name `Set.member` finder_hiddenModules opts =
|
| 201 | 208 | return (mkHomeHidden uid)
|
| 202 | 209 | | otherwise =
|
| ... | ... | @@ -205,7 +212,7 @@ findImportedModuleNoHsc fc fopts ue query mhome_unit mod_name mb_pkg = |
| 205 | 212 | -- Do not be smart and change this to `foldr orIfNotFound home_import hs` as
|
| 206 | 213 | -- that is not the same!! home_import is first because we need to look within ourselves
|
| 207 | 214 | -- first before looking at the packages in order.
|
| 208 | - any_home_import = foldr1 orIfNotFound (home_import: map home_pkg_import other_fopts)
|
|
| 215 | + any_home_import = foldr1 orIfNotFound (home_import: map home_pkg_import other_fopts_list)
|
|
| 209 | 216 | |
| 210 | 217 | pkg_import = findExposedPackageModule fc fopts units query mod_name mb_pkg
|
| 211 | 218 | |
| ... | ... | @@ -216,9 +223,21 @@ findImportedModuleNoHsc fc fopts ue query mhome_unit mod_name mb_pkg = |
| 216 | 223 | units = case mhome_unit of
|
| 217 | 224 | Nothing -> ue_units ue
|
| 218 | 225 | Just home_unit -> homeUnitEnv_units $ ue_findHomeUnitEnv (homeUnitId home_unit) ue
|
| 219 | - hpt_deps :: [UnitId]
|
|
| 226 | + hpt_deps :: Set.Set UnitId
|
|
| 220 | 227 | hpt_deps = homeUnitDepends units
|
| 221 | - other_fopts = map (\uid -> (uid, initFinderOpts (homeUnitEnv_dflags (ue_findHomeUnitEnv uid ue)))) hpt_deps
|
|
| 228 | + dep_providers = Set.intersection module_home_units hpt_deps
|
|
| 229 | + known_other_uids =
|
|
| 230 | + let providers = maybe dep_providers (\u -> Set.delete u dep_providers) current_unit_id
|
|
| 231 | + in Set.toList providers
|
|
| 232 | + unknown_units =
|
|
| 233 | + let candidates = Set.difference hpt_deps complete_units
|
|
| 234 | + excluded = maybe dep_providers (\u -> Set.insert u dep_providers) current_unit_id
|
|
| 235 | + in Set.toList (Set.difference candidates excluded)
|
|
| 236 | + other_home_uids = known_other_uids ++ unknown_units
|
|
| 237 | + other_fopts_list =
|
|
| 238 | + [ (uid, initFinderOpts (homeUnitEnv_dflags (ue_findHomeUnitEnv uid ue)))
|
|
| 239 | + | uid <- other_home_uids
|
|
| 240 | + ]
|
|
| 222 | 241 | |
| 223 | 242 | -- | Locate a plugin module requested by the user, for a compiler
|
| 224 | 243 | -- 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
|
| ... | ... | @@ -9,7 +9,19 @@ |
| 9 | 9 | //
|
| 10 | 10 | // The CPP is thus about the RTS version GHC is linked against, and not the
|
| 11 | 11 | // version of the GHC being built.
|
| 12 | -#if !MIN_VERSION_GLASGOW_HASKELL(9,9,0,0)
|
|
| 12 | + |
|
| 13 | +#if MIN_VERSION_GLASGOW_HASKELL(9,9,0,0)
|
|
| 14 | +// Unique64 patch was present in 9.10 and later
|
|
| 15 | +#define HAVE_UNIQUE64 1
|
|
| 16 | +#elif !MIN_VERSION_GLASGOW_HASKELL(9,9,0,0) && MIN_VERSION_GLASGOW_HASKELL(9,8,4,0)
|
|
| 17 | +// Unique64 patch was backported to 9.8.4
|
|
| 18 | +#define HAVE_UNIQUE64 1
|
|
| 19 | +#elif !MIN_VERSION_GLASGOW_HASKELL(9,7,0,0) && MIN_VERSION_GLASGOW_HASKELL(9,6,7,0)
|
|
| 20 | +// Unique64 patch was backported to 9.6.7
|
|
| 21 | +#define HAVE_UNIQUE64 1
|
|
| 22 | +#endif
|
|
| 23 | + |
|
| 24 | +#if !defined(HAVE_UNIQUE64)
|
|
| 13 | 25 | HsWord64 ghc_unique_counter64 = 0;
|
| 14 | 26 | #endif
|
| 15 | 27 | #if !MIN_VERSION_GLASGOW_HASKELL(9,3,0,0)
|
| ... | ... | @@ -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
|