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 assorted perf tweaks - - - - - 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: ===================================== compiler/GHC/Driver/Make.hs ===================================== @@ -113,6 +113,8 @@ import Data.Either ( rights, partitionEithers, lefts ) import qualified Data.Map as Map import qualified Data.Set as Set +import GHC.Data.OsPath (OsPath) +import qualified GHC.Data.OsPath as OsPath import Control.Concurrent ( newQSem, waitQSem, signalQSem, ThreadId, killThread, forkIOWithUnmask ) import qualified GHC.Conc as CC import Control.Concurrent.MVar @@ -246,7 +248,7 @@ depanalPartial excluded_mods allow_dup_roots = do liftIO $ flushFinderCaches (hsc_FC hsc_env) (hsc_unit_env hsc_env) (errs, graph_nodes) <- liftIO $ downsweep - hsc_env (mgModSummaries old_graph) + hsc_env (mgModSummaries old_graph) (Just old_graph) excluded_mods allow_dup_roots let mod_graph = mkModuleGraph graph_nodes @@ -1539,6 +1541,10 @@ warnUnnecessarySourceImports sccs = do -- an import of this module mean. type DownsweepCache = M.Map (UnitId, PkgQual, ModuleNameWithIsBoot) [Either DriverMessages ModSummary] +moduleGraphNodeMap :: ModuleGraph -> M.Map NodeKey ModuleGraphNode +moduleGraphNodeMap graph = + M.fromList [(mkNodeKey node, node) | node <- mgModSummaries' graph] + ----------------------------------------------------------------------------- -- -- | Downsweep (dependency analysis) @@ -1557,6 +1563,8 @@ type DownsweepCache = M.Map (UnitId, PkgQual, ModuleNameWithIsBoot) [Either Driv downsweep :: HscEnv -> [ModSummary] -- ^ Old summaries + -> Maybe ModuleGraph + -- ^ Existing module graph to reuse cached nodes from -> [ModuleName] -- Ignore dependencies on these; treat -- them as if they were package modules -> Bool -- True <=> allow multiple targets to have @@ -1566,10 +1574,10 @@ downsweep :: HscEnv -- The non-error elements of the returned list all have distinct -- (Modules, IsBoot) identifiers, unless the Bool is true in -- which case there can be repeats -downsweep hsc_env old_summaries excl_mods allow_dup_roots = do +downsweep hsc_env old_summaries old_graph excl_mods allow_dup_roots = do n_jobs <- mkWorkerLimit (hsc_dflags hsc_env) new <- rootSummariesParallel n_jobs hsc_env summary - downsweep_imports hsc_env old_summary_map excl_mods allow_dup_roots new + downsweep_imports hsc_env old_summary_map old_graph excl_mods allow_dup_roots new where summary = getRootSummary excl_mods old_summary_map @@ -1578,21 +1586,23 @@ downsweep hsc_env old_summaries excl_mods allow_dup_roots = do -- file was used in. -- Reuse these if we can because the most expensive part of downsweep is -- reading the headers. - old_summary_map :: M.Map (UnitId, FilePath) ModSummary + old_summary_map :: M.Map (UnitId, OsPath) ModSummary old_summary_map = - M.fromList [((ms_unitid ms, msHsFilePath ms), ms) | ms <- old_summaries] + M.fromList [((ms_unitid ms, OsPath.unsafeEncodeUtf (msHsFilePath ms)), ms) | ms <- old_summaries] downsweep_imports :: HscEnv - -> M.Map (UnitId, FilePath) ModSummary + -> M.Map (UnitId, OsPath) ModSummary + -> Maybe ModuleGraph -> [ModuleName] -> Bool -> ([(UnitId, DriverMessages)], [ModSummary]) -> IO ([DriverMessages], [ModuleGraphNode]) -downsweep_imports hsc_env old_summaries excl_mods allow_dup_roots (root_errs, rootSummariesOk) +downsweep_imports hsc_env old_summaries old_graph excl_mods allow_dup_roots (root_errs, rootSummariesOk) = do let root_map = mkRootMap rootSummariesOk checkDuplicates root_map - (deps, map0) <- loopSummaries rootSummariesOk (M.empty, root_map) + let done0 = maybe M.empty moduleGraphNodeMap old_graph + (deps, map0) <- loopSummaries rootSummariesOk (done0, root_map) let closure_errs = checkHomeUnitsClosed (hsc_unit_env hsc_env) let unit_env = hsc_unit_env hsc_env let tmpfs = hsc_tmpfs hsc_env @@ -1723,7 +1733,7 @@ downsweep_imports hsc_env old_summaries excl_mods allow_dup_roots (root_errs, ro getRootSummary :: [ModuleName] -> - M.Map (UnitId, FilePath) ModSummary -> + M.Map (UnitId, OsPath) ModSummary -> HscEnv -> Target -> IO (Either (UnitId, DriverMessages) ModSummary) @@ -2069,7 +2079,7 @@ mkRootMap summaries = Map.fromListWith (flip (++)) summariseFile :: HscEnv -> HomeUnit - -> M.Map (UnitId, FilePath) ModSummary -- old summaries + -> M.Map (UnitId, OsPath) ModSummary -- old summaries -> FilePath -- source file name -> Maybe Phase -- start phase -> Maybe (StringBuffer,UTCTime) @@ -2078,7 +2088,7 @@ summariseFile summariseFile hsc_env' home_unit old_summaries src_fn mb_phase maybe_buf -- we can use a cached summary if one is available and the -- source file hasn't changed, - | Just old_summary <- M.lookup (homeUnitId home_unit, src_fn) old_summaries + | Just old_summary <- M.lookup (homeUnitId home_unit, src_fn_os) old_summaries = do let location = ms_location $ old_summary @@ -2099,6 +2109,7 @@ summariseFile hsc_env' home_unit old_summaries src_fn mb_phase maybe_buf where -- change the main active unit so all operations happen relative to the given unit hsc_env = hscSetActiveHomeUnit home_unit hsc_env' + src_fn_os = OsPath.unsafeEncodeUtf src_fn -- src_fn does not necessarily exist on the filesystem, so we need to -- check what kind of target we are dealing with get_src_hash = case maybe_buf of @@ -2188,7 +2199,7 @@ data SummariseResult = summariseModule :: HscEnv -> HomeUnit - -> M.Map (UnitId, FilePath) ModSummary + -> M.Map (UnitId, OsPath) ModSummary -- ^ Map of old summaries -> IsBootInterface -- True <=> a {-# SOURCE #-} import -> 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 Right ms -> FoundHome ms new_summary_cache_check loc mod src_fn h - | Just old_summary <- Map.lookup ((toUnitId (moduleUnit mod), src_fn)) old_summary_map = + | Just old_summary <- Map.lookup ((toUnitId (moduleUnit mod), src_fn_os)) old_summary_map = -- check the hash on the source file, and -- 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 Nothing -> checkSummaryHash hsc_env (new_summary loc mod src_fn) old_summary loc h | otherwise = new_summary loc mod src_fn h + where + src_fn_os = OsPath.unsafeEncodeUtf src_fn new_summary :: ModLocation -> Module @@ -2328,7 +2341,8 @@ makeNewModSummary hsc_env MakeNewModSummary{..} = do hie_timestamp <- modificationTimeIfExists (ml_hie_file nms_location) extra_sig_imports <- findExtraSigImports hsc_env nms_hsc_src pi_mod_name - (implicit_sigs, _inst_deps) <- implicitRequirementsShallow (hscSetActiveUnitId (moduleUnitId nms_mod) hsc_env) pi_theimps +-- (implicit_sigs, _inst_deps) <- implicitRequirementsShallow (hscSetActiveUnitId (moduleUnitId nms_mod) hsc_env) pi_theimps + let implicit_sigs = [] return $ ModSummary ===================================== compiler/GHC/Linker/Loader.hs ===================================== @@ -355,7 +355,7 @@ loadCmdLineLibs' interp hsc_env pls = snd <$> let hsc' = hscSetActiveUnitId uid hsc_env -- Load potential dependencies first (done', pls') <- foldM (\(done', pls') uid -> load done' uid pls') (done, pls) - (homeUnitDepends (hsc_units hsc')) + (Set.toList (homeUnitDepends (hsc_units hsc'))) pls'' <- loadCmdLineLibs'' interp hsc' pls' return $ (Set.insert uid done', pls'') ===================================== compiler/GHC/Rename/Names.hs ===================================== @@ -475,11 +475,14 @@ renamePkgQual unit_env query mn mb_pkg = case mb_pkg of -- not really correct as pkg_fs is unlikely to be a valid unit-id but -- we will report the failure later... where - home_names = map (\uid -> (uid, mkFastString <$> thisPackageName (homeUnitEnv_dflags (ue_findHomeUnitEnv uid unit_env)))) hpt_deps + home_names = + [ (uid, mkFastString <$> thisPackageName (homeUnitEnv_dflags (ue_findHomeUnitEnv uid unit_env))) + | uid <- S.toList hpt_deps + ] units = ue_units unit_env - hpt_deps :: [UnitId] + hpt_deps :: S.Set UnitId hpt_deps = homeUnitDepends units hscRenameRawPkgQual :: ===================================== compiler/GHC/Unit/Env.hs ===================================== @@ -142,7 +142,7 @@ ue_transitiveHomeDeps uid unit_env = Set.toList (loop Set.empty [uid]) loop acc (uid:uids) | uid `Set.member` acc = loop acc uids | otherwise = - let hue = homeUnitDepends (homeUnitEnv_units (ue_findHomeUnitEnv uid unit_env)) + let hue = Set.toList (homeUnitDepends (homeUnitEnv_units (ue_findHomeUnitEnv uid unit_env))) in loop (Set.insert uid acc) (hue ++ uids) ===================================== compiler/GHC/Unit/Finder.hs ===================================== @@ -68,8 +68,9 @@ import Control.Monad import Data.Time import qualified Data.Map as M import GHC.Driver.Env - ( hsc_home_unit_maybe, HscEnv(hsc_FC, hsc_dflags, hsc_unit_env), hscUnitIndexQuery ) + ( hsc_home_unit_maybe, HscEnv(hsc_FC, hsc_dflags, hsc_unit_env, hsc_mod_graph), hscUnitIndexQuery ) import GHC.Driver.Config.Finder +import GHC.Unit.Module.Graph (mgHomeModuleMap, ModuleNameHomeMap) import qualified Data.Set as Set type FileExt = String -- Filename extension @@ -163,29 +164,35 @@ findImportedModule hsc_env mod pkg_qual = fopts = initFinderOpts dflags in do query <- hscUnitIndexQuery hsc_env - findImportedModuleNoHsc fc fopts (hsc_unit_env hsc_env) query mhome_unit mod pkg_qual + let home_module_map = mgHomeModuleMap (hsc_mod_graph hsc_env) + findImportedModuleNoHsc fc fopts (hsc_unit_env hsc_env) query home_module_map mhome_unit mod pkg_qual findImportedModuleNoHsc :: FinderCache -> FinderOpts -> UnitEnv -> UnitIndexQuery + -> ModuleNameHomeMap -> Maybe HomeUnit -> ModuleName -> PkgQual -> IO FindResult -findImportedModuleNoHsc fc fopts ue query mhome_unit mod_name mb_pkg = +findImportedModuleNoHsc fc fopts ue query home_module_map mhome_unit mod_name mb_pkg = case mb_pkg of NoPkgQual -> unqual_import ThisPkg uid | (homeUnitId <$> mhome_unit) == Just uid -> home_import - | Just os <- lookup uid other_fopts -> home_pkg_import (uid, os) + | Just os <- M.lookup uid other_fopts_map -> home_pkg_import (uid, os) | otherwise -> pprPanic "findImportModule" (ppr mod_name $$ ppr mb_pkg $$ ppr (homeUnitId <$> mhome_unit) $$ ppr uid $$ ppr (map fst all_opts)) OtherPkg _ -> pkg_import where + (complete_units, module_name_map) = home_module_map + module_home_units = M.findWithDefault Set.empty mod_name module_name_map + current_unit_id = homeUnitId <$> mhome_unit all_opts = case mhome_unit of - Nothing -> other_fopts - Just home_unit -> (homeUnitId home_unit, fopts) : other_fopts + Nothing -> other_fopts_list + Just home_unit -> (homeUnitId home_unit, fopts) : other_fopts_list + other_fopts_map = M.fromList other_fopts_list home_import = case mhome_unit of 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 = -- If the module is reexported, then look for it as if it was from the perspective -- of that package which reexports it. | mod_name `Set.member` finder_reexportedModules opts = - findImportedModuleNoHsc fc opts ue query (Just $ DefiniteHomeUnit uid Nothing) mod_name NoPkgQual + findImportedModuleNoHsc fc opts ue query home_module_map (Just $ DefiniteHomeUnit uid Nothing) mod_name NoPkgQual | mod_name `Set.member` finder_hiddenModules opts = return (mkHomeHidden uid) | otherwise = @@ -205,7 +212,7 @@ findImportedModuleNoHsc fc fopts ue query mhome_unit mod_name mb_pkg = -- Do not be smart and change this to `foldr orIfNotFound home_import hs` as -- that is not the same!! home_import is first because we need to look within ourselves -- first before looking at the packages in order. - any_home_import = foldr1 orIfNotFound (home_import: map home_pkg_import other_fopts) + any_home_import = foldr1 orIfNotFound (home_import: map home_pkg_import other_fopts_list) pkg_import = findExposedPackageModule fc fopts units query mod_name mb_pkg @@ -216,9 +223,21 @@ findImportedModuleNoHsc fc fopts ue query mhome_unit mod_name mb_pkg = units = case mhome_unit of Nothing -> ue_units ue Just home_unit -> homeUnitEnv_units $ ue_findHomeUnitEnv (homeUnitId home_unit) ue - hpt_deps :: [UnitId] + hpt_deps :: Set.Set UnitId hpt_deps = homeUnitDepends units - other_fopts = map (\uid -> (uid, initFinderOpts (homeUnitEnv_dflags (ue_findHomeUnitEnv uid ue)))) hpt_deps + dep_providers = Set.intersection module_home_units hpt_deps + known_other_uids = + let providers = maybe dep_providers (\u -> Set.delete u dep_providers) current_unit_id + in Set.toList providers + unknown_units = + let candidates = Set.difference hpt_deps complete_units + excluded = maybe dep_providers (\u -> Set.insert u dep_providers) current_unit_id + in Set.toList (Set.difference candidates excluded) + other_home_uids = known_other_uids ++ unknown_units + other_fopts_list = + [ (uid, initFinderOpts (homeUnitEnv_dflags (ue_findHomeUnitEnv uid ue))) + | uid <- other_home_uids + ] -- | Locate a plugin module requested by the user, for a compiler -- plugin. This consults the same set of exposed packages as ===================================== compiler/GHC/Unit/Module/Graph.hs ===================================== @@ -18,6 +18,8 @@ module GHC.Unit.Module.Graph , mgModSummaries , mgModSummaries' , mgLookupModule + , ModuleNameHomeMap + , mgHomeModuleMap , showModMsg , moduleGraphNodeModule , moduleGraphNodeModSum @@ -153,23 +155,31 @@ instance Outputable ModNodeKeyWithUid where -- check that the module and its hs-boot agree. -- -- The graph is not necessarily stored in topologically-sorted order. Use +type ModuleNameHomeMap = (Set UnitId, Map.Map ModuleName (Set UnitId)) + -- 'GHC.topSortModuleGraph' and 'GHC.Data.Graph.Directed.flattenSCC' to achieve this. data ModuleGraph = ModuleGraph { mg_mss :: [ModuleGraphNode] , mg_graph :: (ReachabilityIndex SummaryNode, NodeKey -> Maybe SummaryNode) -- A cached transitive dependency calculation so that a lot of work is not -- repeated whenever the transitive dependencies need to be calculated (for example, hptInstances) + , mg_home_map :: ModuleNameHomeMap + -- ^ For each module name, which home-unit UnitIds define it together with the set of units for which the listing is complete. } -- | Map a function 'f' over all the 'ModSummaries'. -- To preserve invariants 'f' can't change the isBoot status. mapMG :: (ModSummary -> ModSummary) -> ModuleGraph -> ModuleGraph mapMG f mg@ModuleGraph{..} = mg - { mg_mss = flip fmap mg_mss $ \case - InstantiationNode uid iuid -> InstantiationNode uid iuid - LinkNode uid nks -> LinkNode uid nks - ModuleNode deps ms -> ModuleNode deps (f ms) + { mg_mss = new_mss + , mg_home_map = mkHomeModuleMap new_mss } + where + new_mss = + flip fmap mg_mss $ \case + InstantiationNode uid iuid -> InstantiationNode uid iuid + LinkNode uid nks -> LinkNode uid nks + ModuleNode deps ms -> ModuleNode deps (f ms) unionMG :: ModuleGraph -> ModuleGraph -> ModuleGraph unionMG a b = @@ -177,11 +187,27 @@ unionMG a b = in ModuleGraph { mg_mss = new_mss , mg_graph = mkTransDeps new_mss + , mg_home_map = mkHomeModuleMap new_mss } mkTransDeps :: [ModuleGraphNode] -> (ReachabilityIndex SummaryNode, NodeKey -> Maybe SummaryNode) mkTransDeps = first graphReachability {- module graph is acyclic -} . moduleGraphNodes False +mkHomeModuleMap :: [ModuleGraphNode] -> ModuleNameHomeMap +mkHomeModuleMap nodes = + (complete_units, provider_map) + where + provider_map = + Map.fromListWith Set.union + [ (ms_mod_name ms, Set.singleton (ms_unitid ms)) + | ModuleNode _ ms <- nodes + ] + complete_units = + Set.fromList + [ ms_unitid ms + | ModuleNode _ ms <- nodes + ] + mgModSummaries :: ModuleGraph -> [ModSummary] mgModSummaries mg = [ m | ModuleNode _ m <- mgModSummaries' mg ] @@ -200,8 +226,11 @@ mgLookupModule ModuleGraph{..} m = listToMaybe $ mapMaybe go mg_mss = Just ms go _ = Nothing +mgHomeModuleMap :: ModuleGraph -> ModuleNameHomeMap +mgHomeModuleMap = mg_home_map + emptyMG :: ModuleGraph -emptyMG = ModuleGraph [] (graphReachability emptyGraph, const Nothing) +emptyMG = ModuleGraph [] (graphReachability emptyGraph, const Nothing) (Set.empty, Map.empty) isTemplateHaskellOrQQNonBoot :: ModSummary -> Bool isTemplateHaskellOrQQNonBoot ms = @@ -213,9 +242,12 @@ isTemplateHaskellOrQQNonBoot ms = -- not an element of the ModuleGraph. extendMG :: ModuleGraph -> [NodeKey] -> ModSummary -> ModuleGraph extendMG ModuleGraph{..} deps ms = ModuleGraph - { mg_mss = ModuleNode deps ms : mg_mss - , mg_graph = mkTransDeps (ModuleNode deps ms : mg_mss) + { mg_mss = new_mss + , mg_graph = mkTransDeps new_mss + , mg_home_map = mkHomeModuleMap new_mss } + where + new_mss = ModuleNode deps ms : mg_mss extendMGInst :: ModuleGraph -> UnitId -> InstantiatedUnit -> ModuleGraph extendMGInst mg uid depUnitId = mg ===================================== compiler/GHC/Unit/State.hs ===================================== @@ -469,7 +469,7 @@ data UnitState = UnitState { -- -Wunused-packages warning. explicitUnits :: [(Unit, Maybe PackageArg)], - homeUnitDepends :: [UnitId], + homeUnitDepends :: Set UnitId, -- | This is a full map from 'ModuleName' to all modules which may possibly -- be providing it. These providers may be hidden (but we'll still want @@ -504,7 +504,7 @@ emptyUnitState = UnitState { unwireMap = emptyUniqMap, preloadUnits = [], explicitUnits = [], - homeUnitDepends = [], + homeUnitDepends = Set.empty, moduleNameProvidersMap = emptyUniqMap, pluginModuleNameProvidersMap = emptyUniqMap, requirementContext = emptyUniqMap, @@ -1573,7 +1573,7 @@ mkUnitState logger cfg index = do let !state = UnitState { preloadUnits = dep_preload , explicitUnits = explicit_pkgs - , homeUnitDepends = Set.toList home_unit_deps + , homeUnitDepends = home_unit_deps , unitInfoMap = pkg_db , preloadClosure = emptyUniqSet , moduleNameProvidersMap ===================================== compiler/cbits/genSym.c ===================================== @@ -9,7 +9,19 @@ // // The CPP is thus about the RTS version GHC is linked against, and not the // version of the GHC being built. -#if !MIN_VERSION_GLASGOW_HASKELL(9,9,0,0) + +#if MIN_VERSION_GLASGOW_HASKELL(9,9,0,0) +// Unique64 patch was present in 9.10 and later +#define HAVE_UNIQUE64 1 +#elif !MIN_VERSION_GLASGOW_HASKELL(9,9,0,0) && MIN_VERSION_GLASGOW_HASKELL(9,8,4,0) +// Unique64 patch was backported to 9.8.4 +#define HAVE_UNIQUE64 1 +#elif !MIN_VERSION_GLASGOW_HASKELL(9,7,0,0) && MIN_VERSION_GLASGOW_HASKELL(9,6,7,0) +// Unique64 patch was backported to 9.6.7 +#define HAVE_UNIQUE64 1 +#endif + +#if !defined(HAVE_UNIQUE64) HsWord64 ghc_unique_counter64 = 0; #endif #if !MIN_VERSION_GLASGOW_HASKELL(9,3,0,0) ===================================== ghc/Main.hs ===================================== @@ -893,7 +893,7 @@ checkUnitCycles :: DynFlags -> UnitEnvGraph HomeUnitEnv -> Ghc () checkUnitCycles dflags graph = processSCCs sccs where mkNode :: (UnitId, HomeUnitEnv) -> Node UnitId UnitId - mkNode (uid, hue) = DigraphNode uid uid (homeUnitDepends (homeUnitEnv_units hue)) + mkNode (uid, hue) = DigraphNode uid uid (Set.toList (homeUnitDepends (homeUnitEnv_units hue))) nodes = map mkNode (unitEnv_elts graph) sccs = stronglyConnCompFromEdgedVerticesOrd nodes View it on GitLab: https://gitlab.haskell.org/ghc/ghc/-/commit/b84be5de1bcbb81efb514197f28cbd65... -- View it on GitLab: https://gitlab.haskell.org/ghc/ghc/-/commit/b84be5de1bcbb81efb514197f28cbd65... You're receiving this email because of your account on gitlab.haskell.org.