Andreas Klebinger pushed to branch wip/andreask/ghc_par at Glasgow Haskell Compiler / GHC Commits: cde2e390 by Andreas Klebinger at 2026-03-07T13:39:29+00:00 Refactored splitting. Broke it into parts to make it easier to understand. - - - - - 82d089c0 by Andreas Klebinger at 2026-03-07T16:48:25+00:00 Make sure CoreMerge reattaches unstable unfoldings - - - - - 8de36fbf by Andreas Klebinger at 2026-03-07T21:14:07+00:00 testsuite: Ignore compilation unit header in output comparison - - - - - 775a5b9f by Andreas Klebinger at 2026-03-07T21:50:09+00:00 Some useless checks - - - - - dd3df12c by Andreas Klebinger at 2026-03-07T22:57:33+00:00 Possible fixes to simplifier/specConstr from the bot - - - - - 5527b495 by Andreas Klebinger at 2026-03-08T09:29:51+00:00 merge/split around late cse - - - - - 15a3537c by Andreas Klebinger at 2026-03-08T09:35:41+00:00 Make CSE work independently over compilation units - - - - - e02db7ea by Andreas Klebinger at 2026-03-08T10:00:25+00:00 Keep rules attributed to units in the simplifier - - - - - 08faa984 by Andreas Klebinger at 2026-03-08T13:42:08+00:00 Some vibe based fixes - - - - - 12 changed files: - compiler/GHC/Core/Opt/CSE.hs - compiler/GHC/Core/Opt/Monad.hs - compiler/GHC/Core/Opt/OccurAnal.hs - compiler/GHC/Core/Opt/Pipeline.hs - compiler/GHC/Core/Opt/Simplify.hs - compiler/GHC/Core/Opt/SpecConstr.hs - compiler/GHC/Core/Opt/Specialise.hs - + compiler/GHC/Core/Opt/Split.hs - compiler/GHC/Core/SimpleOpt.hs - compiler/GHC/Core/Subst.hs - compiler/ghc.cabal.in - testsuite/driver/testlib.py Changes: ===================================== compiler/GHC/Core/Opt/CSE.hs ===================================== @@ -380,18 +380,18 @@ body/rest of the module. -} cseProgram :: CoreProgram -> CoreProgram -cseProgram comp_units - = snd (mapAccumL cse_comp_unit init_env comp_units) +cseProgram = map cseCoreCompUnit + +cseCoreCompUnit :: CoreCompUnit -> CoreCompUnit +cseCoreCompUnit (CoreCompUnit unit_binds unit_rules) + = CoreCompUnit binds' unit_rules where - init_env = emptyCSEnv $ - mkInScopeSetList (bindersOfBinds (concatMap coreCompUnitBinds comp_units)) - -- Put all top-level binders into scope; it is possible to have - -- forward references. See Note [Glomming] in GHC.Core.Opt.OccurAnal - -- Missing this caused #25468 - - cse_comp_unit env (CoreCompUnit binds unit_rules) - = let (env', binds') = mapAccumL (cseBind TopLevel) env binds - in (env', CoreCompUnit binds' unit_rules) + init_env = emptyCSEnv $ + mkInScopeSetList (bindersOfBinds unit_binds) + -- Put all top-level binders in this compilation unit into + -- scope; it is possible to have forward references. + -- See Note [Glomming] in GHC.Core.Opt.OccurAnal. + (_env', binds') = mapAccumL (cseBind TopLevel) init_env unit_binds cseBind :: TopLevelFlag -> CSEnv -> CoreBind -> (CSEnv, CoreBind) cseBind toplevel env (NonRec b e) ===================================== compiler/GHC/Core/Opt/Monad.hs ===================================== @@ -16,7 +16,7 @@ module GHC.Core.Opt.Monad ( -- ** Reading from the monad getModule, - initRuleEnv, getExternalRuleBase, + initRuleEnv, getHomeRuleBase, getExternalRuleBase, getDynFlags, getPackageFamInstEnv, getInteractiveContext, getUniqTag, ===================================== compiler/GHC/Core/Opt/OccurAnal.hs ===================================== @@ -28,7 +28,6 @@ core expression with (hopefully) improved usage information. module GHC.Core.Opt.OccurAnal ( occurAnalysePgm, occurAnalyseCompUnit, - occurSplitPgm, occurAnalyseExpr, occurAnalyseExpr_Prep, zapLambdaBndrs ) where @@ -57,7 +56,6 @@ import GHC.Types.Id.Info import GHC.Types.InlinePragma ( ActivationGhc, isAlwaysActive ) import GHC.Types.Basic import GHC.Types.Tickish -import GHC.Types.Name (isExternalName, nameModule) import GHC.Types.Var.Set import GHC.Types.Var.Env import GHC.Types.Var @@ -70,14 +68,12 @@ import GHC.Utils.Misc import GHC.Builtin.Names( runRWKey ) import GHC.Unit.Module( Module ) -import qualified Data.IntMap.Strict as IntMap -import qualified Data.IntSet as IntSet import Data.List (mapAccumL) {- ************************************************************************ * * - occurAnalysePgm, occurAnalyseExpr, occurSplitPgm + occurAnalysePgm, occurAnalyseExpr * * ************************************************************************ @@ -99,140 +95,6 @@ occurAnalyseExpr_Prep expr = expr' where WUD _ expr' = occAnal (initOccEnv { occ_allow_weak_joins = True }) expr --- After optimizations a rule might no longer reference binders from this module. --- In these cases we return them here and then add them to mg_rules. -occurSplitPgm :: Module -> [CoreRule] -> CoreCompUnit -> ([CoreCompUnit], [CoreRule]) -occurSplitPgm mod imp_rules (CoreCompUnit unit_binds unit_rules) - = - -- pprTrace "occurSplitPgm" - -- ( vcat [ - -- text "imp", - -- ppr imp_rules, - -- text "unit", - -- ppr (unit_rules, unit_binds) - -- ] - -- ) - (zipWith mk_comp_unit comp_pairs [0..], rules_for_imps) - where - CoreCompUnit occ_binds _ = - occurAnalyseCompUnit mod (const True) (const True) imp_rules - (CoreCompUnit unit_binds unit_rules) - - pairs = flattenBinds occ_binds - bndrs = map fst pairs - bndr_set = mkVarSet bndrs - - imp_rule_edges :: ImpRuleEdges - imp_rule_edges = mkImpRuleEdges imp_rules - - -- If a unit rule mentions multiple local binders, they must end up in - -- the same component; otherwise the rule cannot be attached to any one - -- split unit without creating cross-unit references. - rule_fv_edges :: IdEnv VarSet - rule_fv_edges - = foldr (plusVarEnv_C unionVarSet) emptyVarEnv - [ mapVarEnv (const local_rule_fvs) (getUniqSet local_rule_fvs) - | rule <- unit_rules - , let local_rule_fvs = ruleFreeVars rule `intersectVarSet` bndr_set - ] - - dir_nodes :: [Node Unique (Id, CoreExpr)] - dir_nodes = map mk_dir_node pairs - - mk_dir_node (bndr, rhs) - = DigraphNode { node_payload = (bndr, rhs) - , node_key = varUnique bndr - , node_dependencies = nonDetKeysUniqSet deps - } - where - deps = traced_fvs `intersectVarSet` bndr_set - - traced_fvs = -- pprTrace "occurSplitPgm: binder fvs before unit assignment" - -- (ppr bndr $$ text "fvs:" <+> ppr dep_fvs) - dep_fvs - - dep_fvs = exprFreeIds rhs - `unionVarSet` bndrRuleAndUnfoldingIds bndr - `unionVarSet` localRuleDeps bndr - `unionVarSet` impRuleDeps bndr - - impRuleDeps b = foldr unionVarSet emptyVarSet [ vs | (_, vs) <- lookupImpRules imp_rule_edges b ] - - localRuleDeps b = lookupVarEnv rule_fv_edges b `orElse` emptyVarSet - - incoming_edges :: UniqFM Unique [Unique] - incoming_edges = foldr add_incoming emptyUFM dir_nodes - where - add_incoming DigraphNode { node_key = src, node_dependencies = dests } incoming - = foldr (\dest acc -> addToUFM_C (++) acc dest [src]) incoming dests - -- TODO: AI Garbage? - - -- We probably really should just do this on a undirected graph instead. - undir_nodes :: [Node Unique (Id, CoreExpr)] - undir_nodes = - [ node { node_dependencies = node_dependencies node ++ lookupWithDefaultUFM incoming_edges [] (node_key node) } - | node <- dir_nodes - ] - - comp_pairs :: [[(Id, CoreExpr)]] - comp_pairs = map scc_payloads (stronglyConnCompFromEdgedVerticesUniq undir_nodes) - - component_bndrs :: [[Id]] - component_bndrs = map (map fst) comp_pairs - - mk_comp_unit prs i = CoreCompUnit (mk_comp_binds prs) (component_rules i) - - mk_comp_binds [pr] = [NonRec (fst pr) (snd pr)] - mk_comp_binds prs = [Rec prs] - - (component_rule_map, rules_for_imps) = foldr assign_rule (IntMap.empty, []) unit_rules - - assign_rule rule (rule_map, imp_rules_acc) - = case rule_comp_index rule of - Just i -> (IntMap.insertWith (++) i [rule] rule_map, imp_rules_acc) - Nothing -> (rule_map, rule : imp_rules_acc) - - component_rules i = IntMap.findWithDefault [] i component_rule_map - - rule_comp_index rule - = case rule_component_indices of - [i] -> Just i - [] -> Nothing - is -> pprPanic "occurSplitPgm" - (text "Rule free vars span multiple components" - $$ text "rule:" <+> ppr rule - $$ text "components:" <+> ppr is - $$ text "rule_fvs:" <+> pprVarsWithModule (nonDetEltsUniqSet rule_fvs) - $$ vcat [ text "component" <+> int i <> colon <+> ppr hits - | (i, hits) <- component_hits ]) - where - rule_component_indices :: [Int] - rule_component_indices = IntSet.toList $ IntSet.fromList - [ i - | (ids, i) <- zip component_bndrs [0..] - , not (isEmptyVarSet (local_rule_fvs `intersectVarSet` mkVarSet ids)) - ] - - rule_fvs = ruleFreeVars rule - local_rule_fvs = rule_fvs `intersectVarSet` bndr_set - component_hits = - [ (i, local_rule_fvs `intersectVarSet` mkVarSet ids) - | (ids, i) <- zip component_bndrs [0..] - , not (isEmptyVarSet (local_rule_fvs `intersectVarSet` mkVarSet ids)) - ] - - scc_payloads (AcyclicSCC p) = [p] - scc_payloads (CyclicSCC ps) = ps - - pprVarsWithModule :: [Var] -> SDoc - pprVarsWithModule vars = braces (fsep (punctuate comma (map pprVarWithModule vars))) - - pprVarWithModule :: Var -> SDoc - pprVarWithModule v - | isExternalName n = ppr v <+> parens (ppr (nameModule n)) - | otherwise = ppr v - where - n = varName v - occurAnalyseCompUnit :: Module -> (Id -> Bool) ===================================== compiler/GHC/Core/Opt/Pipeline.hs ===================================== @@ -14,7 +14,7 @@ import GHC.Driver.DynFlags import GHC.Driver.Plugins ( withPlugins, installCoreToDos ) import GHC.Driver.Env import GHC.Driver.Config (initSimpleOpts) -import GHC.Driver.Config.Core.Lint ( endPass ) +import GHC.Driver.Config.Core.Lint ( endPass, initLintConfig ) import GHC.Driver.Config.Core.Opt.LiberateCase ( initLiberateCaseOpts ) import GHC.Driver.Config.Core.Opt.Simplify ( initSimplifyOpts, initSimplMode, initGentleSimplMode ) import GHC.Driver.Config.Core.Opt.WorkWrap ( initWorkWrapOpts ) @@ -22,12 +22,12 @@ import GHC.Driver.Config.Core.Rules ( initRuleOpts ) import GHC.Platform.Ways ( hasWay, Way(WayProf) ) import GHC.Core -import GHC.Core.SimpleOpt (simpleOptPgm) +import GHC.Core.SimpleOpt (simpleOptPgm, defaultSimpleOpts, so_inline, so_uf_opts) import GHC.Core.Opt.CSE ( cseProgram ) import GHC.Core.Rules ( RuleBase, ruleCheckProgram, getRules ) import GHC.Core.Ppr ( pprCoreProgram, pprRules ) import GHC.Core.Utils ( dumpIdInfoOfProgram ) -import GHC.Core.Lint ( lintAnnots ) +import GHC.Core.Lint ( lintAnnots, lintCoreProgram', displayLintResults ) import GHC.Core.Lint.Interactive ( interactiveInScope ) import GHC.Core.Opt.Simplify ( simplifyExpr, simplifyPgm ) import GHC.Core.Opt.Simplify.Monad @@ -43,7 +43,7 @@ import GHC.Core.Opt.DmdAnal import GHC.Core.Opt.CprAnal ( cprAnalProgram ) import GHC.Core.Opt.CallArity ( callArityAnalProgram ) import GHC.Core.Opt.Exitify ( exitifyProgram ) -import GHC.Core.Opt.OccurAnal ( occurSplitPgm ) +import GHC.Core.Opt.Split ( splitCompUnit, checkNameClashes ) import GHC.Core.Opt.WorkWrap ( wwTopBinds ) import GHC.Core.Opt.CallerCC ( addCallerCostCentres ) import GHC.Core.LateCC.TopLevelBinds (topLevelBindsCCMG) @@ -320,7 +320,11 @@ getCoreToDo dflags hpt_rule_base extra_vars -- in wheel-sieve1), and I'm guessing that SpecConstr can too -- And CSE is a very cheap pass. So it seems worth doing here. runWhen ((liberate_case || spec_constr) && cse) $ CoreDoPasses - [ CoreCSE, simplify "post-final-cse" ], + [ runWhen split_core CoreMerge + , CoreCSE + , runWhen split_core CoreSplit + , simplify "post-final-cse" + ], --------- End of -O2 passes -------------- @@ -457,6 +461,7 @@ doCorePass pass guts = do dflags <- getDynFlags us <- getUniqueSupplyM p_fam_env <- getPackageFamInstEnv + let extra_vars = interactiveInScope (hsc_IC hsc_env) let platform = targetPlatform dflags let fam_envs = (p_fam_env, mg_fam_inst_env guts) let updateBinds f = return $ guts { mg_binds = f (mg_binds guts) } @@ -478,14 +483,16 @@ doCorePass pass guts = do updateBindsAndRulesM (desugarOpt dflags logger (mg_module guts)) CoreSplit -> {-# SCC "CoreSplit" #-} - do { let split_res = map (occurSplitPgm (mg_module guts) (mg_rules guts)) (mg_binds guts) + do { let split_res = map (splitCompUnit (mg_module guts) (mg_rules guts)) (mg_binds guts) binds' = concatMap fst split_res rules' = mg_rules guts ++ concatMap snd split_res ; return guts { mg_binds = binds', mg_rules = rules' } } CoreMerge -> {-# SCC "CoreMerge" #-} do { let binds_before = mg_binds guts + _ = checkNameClashes binds_before binds_after = flattenCoreProgram binds_before + _ = checkNameClashes binds_after ; liftIO $ Logger.putDumpFileMaybe logger Opt_D_dump_split_core "Core before merge" @@ -497,7 +504,33 @@ doCorePass pass guts = do "Core after merge" FormatCore (pprCoreProgram binds_after) - ; return $ guts { mg_binds = binds_after } } + ; liftIO $ do + let warns_and_errs = lintCoreProgram' + (initLintConfig dflags extra_vars) + binds_after + (mg_rules guts) + True + displayLintResults logger + (text "CoreMerge after flattenCoreProgram") + (pprCoreProgram binds_after) + warns_and_errs + ; let minimal_things = defaultSimpleOpts + { so_inline = False + , so_uf_opts = unfoldingOpts dflags } + (binds_w_unfolds, rules_for_imps, occ_anald_binds) = simpleOptPgm + minimal_things + (mg_module guts) + binds_after + (mg_rules guts) + _ = checkNameClashes binds_w_unfolds + ; liftIO $ + Logger.putDumpFileMaybe logger Opt_D_dump_split_core + "Core after re-attaching unfolds" + FormatCore + (pprCoreProgram occ_anald_binds) + + ; return $ guts { mg_binds = binds_w_unfolds + , mg_rules = rules_for_imps } } CoreDoSimplify opts -> {-# SCC "Simplify" #-} liftIOWithCount $ simplifyPgm logger (hsc_unit_env hsc_env) name_ppr_ctx opts guts ===================================== compiler/GHC/Core/Opt/Simplify.hs ===================================== @@ -10,6 +10,7 @@ import GHC.Prelude import GHC.Driver.Flags import GHC.Core +import GHC.Core.FVs (ruleFreeVars) import GHC.Core.Rules import GHC.Core.Ppr ( pprCoreBindings, pprCoreExpr ) import GHC.Core.Opt.OccurAnal ( occurAnalysePgm, occurAnalyseExpr ) @@ -38,10 +39,10 @@ import GHC.Unit.Module.ModGuts import GHC.Types.Id import GHC.Types.Id.Info import GHC.Types.InlinePragma -import GHC.Types.Var.Set import GHC.Types.Var.Env import GHC.Types.Tickish import GHC.Types.Unique.FM +import GHC.Types.Var.Set import Control.Monad import Data.Foldable ( for_ ) @@ -240,7 +241,7 @@ simplifyPgm' logger unit_env name_ppr_ctx opts -- number of iterations we actually completed return ( "Simplifier bailed out", iteration_no - 1 , totalise counts_so_far - , dyn_no_binds { dsd_binds = [CoreCompUnit bind_list unit_rules], dsd_rules = local_rules } ) + , dyn_no_binds { dsd_binds = binds, dsd_rules = local_rules } ) -- Try and force thunks off the binds; significantly reduces -- space usage, especially with -O. JRS, 000620. @@ -271,38 +272,19 @@ simplifyPgm' logger unit_env name_ppr_ctx opts -- (b) local rules (substituted), including unit rules from `binds` -- Forcing base_rule_env to avoid unnecessary allocations. -- Not doing so results in +25.6% allocations of LargeRecord. - ; !base_rule_env = updLocalRules hpt_rule_env (local_rules ++ unit_rules) - - ; read_eps_rules :: IO PackageRuleBase - ; read_eps_rules = eps_rule_base <$> ueEPS unit_env - - ; read_rule_env :: IO RuleEnv - ; read_rule_env = updExternalPackageRules base_rule_env <$> read_eps_rules - ; fam_envs = (eps_fam_inst_env eps, fam_inst_env) ; simpl_env = mkSimplEnv mode fam_envs } ; - -- Simplify the program - ((binds1, rules1, unit_rules1), counts1) <- - initSmpl logger read_rule_env top_env_cfg sz $ - do { (floats, env1) <- {-# SCC "SimplTopBinds" #-} - simplTopBinds simpl_env tagged_bind_list - - -- Apply the substitution to rules defined in this module - -- for imported Ids. Eg RULE map my_f = blah - -- If we have a substitution my_f :-> other_f, we'd better - -- apply it to the rule to, or it'll never match - ; rules1 <- simplImpRules env1 local_rules - ; unit_rules1 <- simplImpRules env1 unit_rules - - ; return (getTopFloatBinds floats, rules1, unit_rules1) } ; + -- Simplify each compilation unit independently + ((binds1, rules1), counts1) <- + simpl_comp_units simpl_env local_rules tagged_binds sz ; -- Stop if nothing happened; don't dump output -- See Note [Which transformations are innocuous] in GHC.Core.Opt.Stats if isZeroSimplCount counts1 then return ( "Simplifier reached fixed point", iteration_no , totalise (counts1 : counts_so_far) -- Include "free" ticks - , dyn_no_binds { dsd_binds = [CoreCompUnit binds1 unit_rules1], dsd_rules = rules1 } ) + , dyn_no_binds { dsd_binds = binds1, dsd_rules = rules1 } ) else do { -- Short out indirections -- We do this *after* at least one run of the simplifier @@ -312,26 +294,77 @@ simplifyPgm' logger unit_env name_ppr_ctx opts -- -- ToDo: alas, this means that indirection-shorting does not happen at all -- if the simplifier does nothing (not common, I know, but unsavoury) - let { binds2 = {-# SCC "ZapInd" #-} shortOutIndirections binds1 } ; + let { binds2 = {-# SCC "ZapInd" #-} + [ CoreCompUnit (shortOutIndirections unit_binds) unit_rules' + | CoreCompUnit unit_binds unit_rules' <- binds1 ] } ; -- Dump the result of this iteration dump_end_iteration logger dump_core_sizes name_ppr_ctx iteration_no counts1 - [CoreCompUnit binds2 unit_rules1] rules1 ; + binds2 rules1 ; for_ (so_pass_result_cfg opts) $ \pass_result_cfg -> - lintPassResult logger pass_result_cfg [CoreCompUnit binds2 unit_rules1] rules1 ; + lintPassResult logger pass_result_cfg binds2 rules1 ; -- Loop - do_iteration (iteration_no + 1) (counts1:counts_so_far) [CoreCompUnit binds2 unit_rules1] rules1 + do_iteration (iteration_no + 1) (counts1:counts_so_far) binds2 rules1 } } where bind_list = concatMap coreCompUnitBinds binds - unit_rules = concatMap cu_rules binds -- Remember the counts_so_far are reversed totalise :: [SimplCount] -> SimplCount totalise = foldr (\c acc -> acc `plusSimplCount` c) (zeroSimplCount $ logHasDumpFlag logger Opt_D_dump_simpl_stats) + -- Keep top-level in-scope sets per-unit until CoreMerge. + simpl_comp_units + :: SimplEnv + -> [CoreRule] + -> CoreProgram + -> Int + -> IO ((CoreProgram, [CoreRule]), SimplCount) + simpl_comp_units simpl_env rules0 units0 sz = go rules0 [] zero_counts units0 + where + zero_counts = zeroSimplCount $ logHasDumpFlag logger Opt_D_dump_simpl_stats + + go !rules acc !counts [] = return ((reverse acc, rules), counts) + go !rules acc !counts (CoreCompUnit unit_binds unit_rules' : rest) = do + let unit_bndrs = mkVarSet (bindersOfBinds unit_binds) + (visible_rules, hidden_rules) = partitionVisibleImpRules unit_bndrs rules + !base_rule_env = updLocalRules hpt_rule_env (visible_rules ++ unit_rules') + read_eps_rules = eps_rule_base <$> ueEPS unit_env + read_rule_env = updExternalPackageRules base_rule_env <$> read_eps_rules + + ((unit1, visible_rules1), counts1) <- + initSmpl logger read_rule_env top_env_cfg sz $ do + (floats, env1) <- {-# SCC "SimplTopBindsUnit" #-} + simplTopBinds simpl_env unit_binds + + -- Apply substitutions from this unit to imported-head rules and + -- the unit's own rules. Keep each unit's local rules separate. + visible_rules1 <- simplImpRules env1 visible_rules + unit_rules1 <- simplImpRules env1 unit_rules' + + let unit_binds1 = getTopFloatBinds floats + pure (CoreCompUnit unit_binds1 unit_rules1, visible_rules1) + + let rules1 = visible_rules1 ++ hidden_rules + go rules1 (unit1 : acc) (counts `plusSimplCount` counts1) rest + + partitionVisibleImpRules :: VarSet -> [CoreRule] -> ([CoreRule], [CoreRule]) + partitionVisibleImpRules unit_bndrs = foldr go_rule ([], []) + where + go_rule rule (visible, hidden) + | rule_mentions_unit = (rule : visible, hidden) + | rule_has_local_fvs = (visible, rule : hidden) + | otherwise = (rule : visible, hidden) + where + local_fvs = ruleFreeVars rule `intersectVarSet` all_local_bndrs + rule_has_local_fvs = not (isEmptyVarSet local_fvs) + rule_mentions_unit = not (isEmptyVarSet (local_fvs `intersectVarSet` unit_bndrs)) + + all_local_bndrs :: VarSet + all_local_bndrs = mkVarSet (bindersOfBinds (concatMap coreCompUnitBinds (dsd_binds dyn))) + dump_end_iteration :: Logger -> Bool -> NamePprCtx -> Int -> SimplCount -> CoreProgram -> [CoreRule] -> IO () dump_end_iteration logger dump_core_sizes name_ppr_ctx iteration_no counts binds rules ===================================== compiler/GHC/Core/Opt/SpecConstr.hs ===================================== @@ -794,9 +794,12 @@ specConstrProgram guts scTopCompUnits :: ScEnv -> CoreProgram -> UniqSM (ScUsage, CoreProgram, [SpecFailWarning]) scTopCompUnits _env [] = return (nullUsage, [], []) scTopCompUnits env (CoreCompUnit unit_binds unit_rules:units) = do - (unit_usg, unit_binds', unit_warnings) <- scTopBinds env unit_binds - (units_usg, units', units_warnings) <- scTopCompUnits env units - return (unit_usg `combineUsage` units_usg, CoreCompUnit unit_binds' unit_rules : units', unit_warnings ++ units_warnings) + let unit_env = initScCompUnitEnv env unit_binds + (_unit_usg, unit_binds', unit_warnings) <- scTopBinds unit_env unit_binds + (_units_usg, units', units_warnings) <- scTopCompUnits env units + -- Before CoreMerge, different compilation units may legitimately reuse the + -- same top-level Id/Unique, so we must not combine ScUsage across units. + return (nullUsage, CoreCompUnit unit_binds' unit_rules : units', unit_warnings ++ units_warnings) scTopBinds :: ScEnv -> [InBind] -> UniqSM (ScUsage, [OutBind], [SpecFailWarning]) scTopBinds _env [] = return (nullUsage, [], []) @@ -1009,18 +1012,19 @@ initScEnv guts ; this_mod <- getModule ; return (SCE { sc_opts = initScOpts dflags this_mod, sc_force = False, - sc_subst = init_subst, + sc_subst = mkEmptySubst emptyInScopeSet, sc_how_bound = emptyVarEnv, sc_vals = emptyVarEnv, sc_annotations = anns }) } + +initScCompUnitEnv :: ScEnv -> [InBind] -> ScEnv +initScCompUnitEnv env unit_binds + = env { sc_subst = mkEmptySubst in_scope } where - init_subst = mkEmptySubst $ foldl' addCompUnitBndrs emptyInScopeSet (mg_binds guts) - -- Acccount for top-level bindings that are not in dependency order; - -- see Note [Glomming] in GHC.Core.Opt.OccurAnal - -- Easiest thing is to bring all the top level binders into scope at once, - -- as if at once, as if all the top-level decls were mutually recursive. - addCompUnitBndrs scope (CoreCompUnit unit_binds _) = - scope `extendInScopeSetBndrs` unit_binds + in_scope = emptyInScopeSet `extendInScopeSetBndrs` unit_binds + -- Account for top-level bindings that are not in dependency order; + -- see Note [Glomming] in GHC.Core.Opt.OccurAnal. + -- Crucially, only add binders from the current compilation unit. data HowBound = RecFun -- These are the recursive functions for which -- we seek interesting call patterns @@ -1443,7 +1447,8 @@ scBind top_lvl env (NonRec bndr rhs) do_body -- but found some regressions (see !8135). So I backed off. = do { (rhs_usage, rhs', ws_rhs) <- scExpr env rhs - -- At top level, we've already put all binders into scope; see initScEnv + -- At top level, we've already put the current compilation unit's + -- binders into scope; see initScCompUnitEnv. -- Hence no need to call `extendBndr`. But we still want to -- extend the `ValueEnv` to record the value of this binder. ; let body_env = extendValEnv env bndr (isValue (sc_vals env) rhs') @@ -1491,7 +1496,8 @@ scBind top_lvl env (Rec prs) do_body (rhs_env1,bndrs') | isTopLevel top_lvl = (env, bndrs) | otherwise = extendRecBndrs env bndrs - -- At top level, we've already put all binders into scope; see initScEnv + -- At top level, we've already put the current compilation unit's + -- binders into scope; see initScCompUnitEnv. rhs_env2 = extendHowBound rhs_env1 bndrs' RecFun ===================================== compiler/GHC/Core/Opt/Specialise.hs ===================================== @@ -65,6 +65,7 @@ import GHC.Utils.Outputable import GHC.Utils.Panic import GHC.Unit.Module( Module ) +import GHC.Unit.Module.Deps ( Dependencies ) import GHC.Unit.Module.ModGuts import GHC.Core.Unfold @@ -641,10 +642,9 @@ Hence, the invariant is this: -- | Specialise calls to type-class overloaded functions occurring in a program. specProgram :: ModGuts -> CoreM ModGuts specProgram guts = do - rule_env <- initRuleEnv guts let static = StaticSpecInput { ssi_module = mg_module guts - , ssi_rule_env = rule_env + , ssi_deps = mg_deps guts } dyn = DynamicSpecData { dsd_binds = mg_binds guts @@ -655,7 +655,7 @@ specProgram guts = do data StaticSpecInput = StaticSpecInput { ssi_module :: !Module - , ssi_rule_env :: !RuleEnv + , ssi_deps :: !Dependencies } data DynamicSpecData = DynamicSpecData @@ -680,20 +680,26 @@ specProgram' static dyn -- | Specialise calls to type-class overloaded functions occurring in a program. specCompUnit :: StaticSpecInput -> DynFlags -> CoreCompUnit -> CoreM CoreCompUnit specCompUnit static dflags (CoreCompUnit unit_binds unit_rules) - = do { (unit_binds', uds) <- runSpecM (go unit_binds) + = do { hpt_rules <- getHomeRuleBase + ; eps_rules <- getExternalRuleBase + ; let rule_env = mkRuleEnv (ssi_module static) (ssi_deps static) [] [unit] + eps_rules hpt_rules + top_env = SE { se_subst = Core.mkEmptySubst in_scope + , se_module = ssi_module static + , se_rules = rule_env + , se_dflags = dflags } + ; (unit_binds', uds) <- runSpecM (go top_env unit_binds) ; (spec_rules, spec_binds) <- specImports top_env uds ; return (CoreCompUnit (spec_binds ++ unit_binds') (spec_rules ++ unit_rules)) } where - top_env = SE { se_subst = Core.mkEmptySubst in_scope - , se_module = ssi_module static - , se_rules = ssi_rule_env static - , se_dflags = dflags } + unit = CoreCompUnit unit_binds unit_rules in_scope = mkInScopeSetBndrs unit_binds - go [] = return ([], emptyUDs) - go (bind:binds) = do (bind', binds', uds') <- specBind TopLevel top_env bind $ \_ -> - go binds - return (bind' ++ binds', uds') + go _ [] = return ([], emptyUDs) + go env (bind:binds) + = do (bind', binds', uds') <- specBind TopLevel env bind $ \_ -> + go env binds + return (bind' ++ binds', uds') {- Note [Wrap bindings returned by specImports] ===================================== compiler/GHC/Core/Opt/Split.hs ===================================== @@ -0,0 +1,271 @@ +{-# LANGUAGE ViewPatterns #-} + +module GHC.Core.Opt.Split + ( splitCompUnit + , checkNameClashes + ) where + +import GHC.Prelude hiding ( head, init, last ) + +import GHC.Core +import GHC.Core.FVs +import GHC.Core.Opt.OccurAnal (occurAnalyseCompUnit) + +import GHC.Data.Graph.Directed (SCC(..), Node(..), stronglyConnCompFromEdgedVerticesUniq) +import GHC.Data.Maybe (orElse) + +import GHC.Types.Unique.Set +import GHC.Types.Name (isExternalName, nameModule) +import GHC.Types.Id (realIdUnfolding) +import GHC.Types.Var.Set +import GHC.Types.Var.Env +import GHC.Types.Var + +import GHC.Utils.Outputable +import GHC.Utils.Panic + +import GHC.Unit.Module (Module) + +import qualified Data.IntMap.Strict as IntMap +import qualified Data.IntSet as IntSet +import Data.List (find) + +{- Note [Splitting core programs] +~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~ +splitCompUnit splits a single compilation unit into multiple. +To do so we: + +Initially we run OccAnal on the compilation unit. I don't think it's strictly neccessary +but it zaps fragile unfoldings which speeds up and gets rid of glomming. +We will try getting rid of this later. + +We split imported rules into those which only concern imported rules and those mentioning +local binders (called unit_rules). + +Rules mentioning local binders introduce edges between any local binders they mention. + +Next we build the graph nodes from binders: +* Fully nodes have one key, the first Id the binder defines. Their node data is the binder itself. +* Pseudo nodes for every id the binder defines (tail $ bindersOf bind) with no data. + +Now we introduce edges: + * For binders from the first id to all other defined ids and those it mentions as fv + let key = (head bindersOf bind) + let edges = map (\x -> (key, x)) bindersOf bind ++ map (\x -> (key, x)) (bindFreeVars bind) + * For rules if they mention local binders introduce edges between any local binders they mention. + +* All edges computed so far are directional. So we take all edges and also add their reversed version. + +* After this we split the graph into independent components. + +* As the last step we assign each unit rule to a unit from which it mentions variables +-} + +data DepGraphNode + = BindNode + { depNodeKey :: !Var + , depNodeBind :: CoreBind + } + | PseudoNode + { depNodeKey :: !Var } + +type Edge = (Var, Var) + +-- | Is the given variable defined in the given module. +varFromModule :: Module -> Var -> Bool +varFromModule _ var = isLocalId var + +maybeRuleEdges :: Module -> CoreRule -> Maybe [Edge] +maybeRuleEdges this_module rule = + case local_fvs of + [] -> Nothing + [_] -> Just [] + _ -> Just (zip local_fvs (drop 1 local_fvs)) + where + local_fvs = filter (varFromModule this_module) (nonDetEltsUniqSet (ruleFreeVars rule)) + +bindNode :: VarSet -> CoreBind -> ([DepGraphNode], [Edge]) +bindNode local_top_bndrs bind = + case bindersOf bind of + [] -> ([], []) + key:rest -> + let split_fvs = bindSplitFreeVars local_top_bndrs bind + intern_edges = map (\v -> (key, v)) rest + ext_edges = map (\v -> (key, v)) (nonDetEltsUniqSet split_fvs) + node = BindNode key bind + pseudo_nodes = map PseudoNode rest + in (node : pseudo_nodes, intern_edges ++ ext_edges) + +bindSplitFreeVars :: VarSet -> CoreBind -> VarSet +bindSplitFreeVars local_top_bndrs bind = + close_over_imported_unfoldings (bindMentionedVars bind `unionVarSet` bindBndrInfoVars bind) + where + close_over_imported_unfoldings fvs = go emptyVarSet fvs + + go !seen !fvs = + case pick_new_import (fvs `minusVarSet` seen) of + Nothing -> fvs + Just v -> + let unfolding_fvs = unfoldingRefs v + local_unfolding_fvs = unfolding_fvs `intersectVarSet` local_top_bndrs + in go (extendVarSet seen v) (fvs `unionVarSet` local_unfolding_fvs `unionVarSet` unfolding_fvs) + + pick_new_import vars = + find pickable (nonDetEltsUniqSet vars) + + pickable v = isId v && not (v `elemVarSet` local_top_bndrs) + + unfoldingRefs v = + case maybeUnfoldingTemplate (realIdUnfolding v) of + Just rhs -> exprSomeFreeVars (const True) rhs + Nothing -> emptyVarSet + +bindMentionedVars :: CoreBind -> VarSet +bindMentionedVars (NonRec _ rhs) = exprSomeFreeVars (const True) rhs +bindMentionedVars (Rec prs) = exprsSomeFreeVars (const True) (map snd prs) + +bindBndrInfoVars :: CoreBind -> VarSet +bindBndrInfoVars bind = + mkVarSet $ + concatMap (dVarSetElems . bndrRuleAndUnfoldingVarsDSet) (bindersOf bind) + +type Edges = IdEnv [Var] + +-- Split core binders takes directed edges treating them as undirected by adding the reverse edge internally. +splitCoreBinders :: [DepGraphNode] -> [Edge] -> [(VarSet, [CoreBind])] +splitCoreBinders nodes edges = + [ (mkVarSet (concatMap bindersOf binds), binds) + | comp_nodes <- map scc_payloads (stronglyConnCompFromEdgedVerticesUniq (map mk_graph_node nodes)) + , let binds = [ b | BindNode { depNodeBind = b } <- comp_nodes ] + ] + where + key_set = mkVarSet (map depNodeKey nodes) + undirected_edges = foldr add_edge emptyVarEnv (edges ++ map reverse_edge edges) + + add_edge :: Edge -> Edges -> Edges + add_edge (src, dst) env = extendVarEnv_C (++) env src [dst] + + reverse_edge :: Edge -> Edge + reverse_edge (src, dst) = (dst, src) + + mk_graph_node node + = DigraphNode + { node_payload = node + , node_key = varUnique key + , node_dependencies = + [ varUnique dst + | dst <- lookupVarEnv undirected_edges key `orElse` [] + , elemVarSet dst key_set + ] + } + where + key = depNodeKey node + + scc_payloads (AcyclicSCC p) = [p] + scc_payloads (CyclicSCC ps) = ps + +assignLocalRules + :: [CoreRule] + -> [(VarSet, [CoreBind])] + -> ([(VarSet, [CoreBind], [CoreRule])], [CoreRule]) +assignLocalRules unit_rules binder_components = + (components_with_rules, rules_without_component) + where + (component_rule_map, rules_without_component) + = foldr assign_rule (IntMap.empty, []) unit_rules + + assign_rule rule (rule_map, no_comp_rules) + = case rule_comp_indices rule of + [i] -> (IntMap.insertWith (++) i [rule] rule_map, no_comp_rules) + [] -> (rule_map, rule : no_comp_rules) + is -> pprPanic "splitCompUnit" + ( text "Rule free vars span multiple components" + $$ text "rule:" <+> ppr rule + $$ text "components:" <+> ppr is + $$ text "rule_fvs:" <+> pprVarsWithModule (nonDetEltsUniqSet (ruleFreeVars rule)) + $$ vcat [ text "component" <+> int i <> colon <+> ppr hits + | (i, hits) <- comp_hits rule ] ) + + rule_comp_indices rule + = IntSet.toList $ IntSet.fromList + [ i + | ((bndrs, _), i) <- zip binder_components [0..] + , not (isEmptyVarSet (ruleFreeVars rule `intersectVarSet` bndrs)) + ] + + comp_hits rule = + [ (i, ruleFreeVars rule `intersectVarSet` bndrs) + | ((bndrs, _), i) <- zip binder_components [0..] + , not (isEmptyVarSet (ruleFreeVars rule `intersectVarSet` bndrs)) + ] + + components_with_rules = + [ (bndrs, binds, IntMap.findWithDefault [] i component_rule_map) + | ((bndrs, binds), i) <- zip binder_components [0..] + ] + +pprVarsWithModule :: [Var] -> SDoc +pprVarsWithModule vars = braces (fsep (punctuate comma (map pprVarWithModule vars))) + +pprVarWithModule :: Var -> SDoc +pprVarWithModule v + | isExternalName n = ppr v <+> parens (ppr (nameModule n)) + | otherwise = ppr v + where + n = varName v + +-- After optimizations a rule might no longer reference binders from this module. +-- In these cases we return them here and then add them to mg_rules. +splitCompUnit :: Module -> [CoreRule] -> CoreCompUnit -> ([CoreCompUnit], [CoreRule]) +splitCompUnit this_module imp_rules unit + = let comp_units = map mk_comp_unit components_with_rules + in checkNameClashes comp_units `seq` + (comp_units, rules_for_imps ++ rules_without_component) + where + CoreCompUnit occ_binds unit_rules = + occurAnalyseCompUnit this_module (const True) (const True) imp_rules unit + + top_level_bndrs = bindersOfBinds occ_binds + checked_bndrs = + assertPpr (all isLocalVar top_level_bndrs) + ( text "splitCompUnit: non-local top-level binder(s)" + $$ ppr top_level_bndrs ) + top_level_bndrs + + local_top_bndrs = mkVarSet checked_bndrs + + (bind_nodes, bind_edges) + = checked_bndrs `seq` + foldr (\b (ns, es) -> let (ns', es') = bindNode local_top_bndrs b in (ns' ++ ns, es' ++ es)) + ([], []) + occ_binds + + rule_edge_pairs = [ (r, maybeRuleEdges this_module r) | r <- unit_rules ] + rule_edges = concat [ es | (_, Just es) <- rule_edge_pairs ] + rules_for_imps = [ r | (r, Nothing) <- rule_edge_pairs ] + unit_rules_local = [ r | (r, Just _) <- rule_edge_pairs ] + + all_edges = bind_edges ++ rule_edges + binder_components = splitCoreBinders bind_nodes all_edges + (components_with_rules, rules_without_component) = + assignLocalRules unit_rules_local binder_components + + mk_comp_unit (_, binds, rules) = CoreCompUnit binds rules + +checkNameClashes :: [CoreCompUnit] -> () +checkNameClashes comp_units + | null dup_bndrs = () + | otherwise + = pprPanic "checkNameClashes" + ( text "Duplicate top-level binders across split compilation units" + $$ ppr dup_bndrs ) + where + all_bndrs = concatMap (bindersOfBinds . coreCompUnitBinds) comp_units + + dup_bndrs :: [Var] + dup_bndrs = go emptyVarSet all_bndrs + + go _ [] = [] + go seen (b:bs) + | b `elemVarSet` seen = b : go seen bs + | otherwise = go (extendVarSet seen b) bs ===================================== compiler/GHC/Core/SimpleOpt.hs ===================================== @@ -205,7 +205,8 @@ simpleOptPgm opts this_mod binds rules = do_unit (env, comp_units') (CoreCompUnit unit_binds unit_rules) = let (env', unit_binds') = foldl' do_one (env, []) unit_binds - in (env', CoreCompUnit (reverse unit_binds') unit_rules : comp_units') + unit_rules' = map (substRule (soe_subst env') id) unit_rules + in (env', CoreCompUnit (reverse unit_binds') unit_rules' : comp_units') do_one (env, binds') bind = case simple_opt_bind env bind TopLevel of ===================================== compiler/GHC/Core/Subst.hs ===================================== @@ -13,7 +13,7 @@ module GHC.Core.Subst ( -- ** Substituting into expressions and related types deShadowBinds, deShadowCompUnits, - substRuleInfo, substRulesForImportedIds, + substRule, substRuleInfo, substRulesForImportedIds, substTyUnchecked, substCo, substExpr, substExprSC, substBind, substBindSC, substUnfolding, substUnfoldingSC, lookupIdSubst, lookupIdSubst_maybe, substIdType, substIdOcc, ===================================== compiler/ghc.cabal.in ===================================== @@ -393,6 +393,7 @@ Library GHC.Core.Opt.Simplify.Utils GHC.Core.Opt.SpecConstr GHC.Core.Opt.Specialise + GHC.Core.Opt.Split GHC.Core.Opt.StaticArgs GHC.Core.Opt.Stats GHC.Core.Opt.WorkWrap ===================================== testsuite/driver/testlib.py ===================================== @@ -2842,7 +2842,21 @@ def _normalised_outputs(expected_file: Path, return expected, actual def _sorted_lines(s: str) -> str: - return '\n'.join(sorted(s.splitlines())) + return '\n'.join(sorted(_drop_split_comp_unit_headers(s.splitlines()))) + +def _drop_split_comp_unit_headers(lines: List[str]) -> List[str]: + kept: List[str] = [] + i = 0 + while i < len(lines): + # Ignore an empty line immediately followed by the split-core unit header. + if i + 1 < len(lines) \ + and lines[i] == '' \ + and lines[i + 1].startswith('=== Start of new compilation unit'): + i += 2 + continue + kept.append(lines[i]) + i += 1 + return kept def _is_reordered_output_mismatch(expected_file: Path, actual_file: Path, View it on GitLab: https://gitlab.haskell.org/ghc/ghc/-/compare/452dc62605ce22373b537529ae385d6... -- View it on GitLab: https://gitlab.haskell.org/ghc/ghc/-/compare/452dc62605ce22373b537529ae385d6... You're receiving this email because of your account on gitlab.haskell.org.