Simon Peyton Jones pushed to branch wip/T23109a at Glasgow Haskell Compiler / GHC Commits: acc7c29d by Simon Peyton Jones at 2025-05-26T10:21:37+01:00 Revert "Always try rules and inlining before simplifying args" This reverts commit 29117fad96e827f1768ca0ac2ba811929ace76f4. - - - - - 2da3fb2c by Simon Peyton Jones at 2025-05-26T10:21:55+01:00 Revert "Try inlining after simplifying the arguments" This reverts commit fb2d5dee8f50052bb3cc0bcaec37de7884d631eb. - - - - - 4d2a8804 by Simon Peyton Jones at 2025-05-26T11:23:49+01:00 Inline top-level used-one things ... until final phase. This makes a difference in LargeRecord, where we can inline lots of dictionaries Just before FinalPhase we do a float-out with floatConsts=True, so we don't want to undo it by inlining them again. - - - - - 5 changed files: - compiler/GHC/Core/Opt/Simplify.hs - compiler/GHC/Core/Opt/Simplify/Env.hs - compiler/GHC/Core/Opt/Simplify/Iteration.hs - compiler/GHC/Core/Opt/Simplify/Utils.hs - compiler/GHC/Driver/Config/Core/Opt/Simplify.hs Changes: ===================================== compiler/GHC/Core/Opt/Simplify.hs ===================================== @@ -156,7 +156,7 @@ simplifyPgm logger unit_env name_ppr_ctx opts && logHasDumpFlag logger Opt_D_dump_simpl_stats) $ logDumpMsg logger "Simplifier statistics for following pass" - (vcat [text termination_msg <+> text "after" <+> ppr (it_count-1) + (vcat [text termination_msg <+> text "after" <+> ppr it_count <+> text "iterations", blankLine, pprSimplCount counts_out]) @@ -240,8 +240,7 @@ simplifyPgm logger unit_env name_ppr_ctx opts ; read_rule_env = updExternalPackageRules base_rule_env <$> read_eps_rules ; fam_envs = (eps_fam_inst_env eps, fam_inst_env) - ; iter_mode = mode { sm_first_iter = iteration_no ==1 } - ; simpl_env = mkSimplEnv iter_mode fam_envs } ; + ; simpl_env = mkSimplEnv mode fam_envs } ; -- Simplify the program ((binds1, rules1), counts1) <- ===================================== compiler/GHC/Core/Opt/Simplify/Env.hs ===================================== @@ -272,35 +272,32 @@ seUnfoldingOpts env = sm_uf_opts (seMode env) -- See Note [The environments of the Simplify pass] data SimplMode = SimplMode -- See comments in GHC.Core.Opt.Simplify.Monad - { sm_phase :: !CompilerPhase - , sm_names :: ![String] -- ^ Name(s) of the phase - , sm_first_iter :: !Bool -- ^ True <=> first iteration - -- False <=> second or subsequent iteration - , sm_rules :: !Bool -- ^ Whether RULES are enabled - , sm_inline :: !Bool -- ^ Whether inlining is enabled - , sm_eta_expand :: !Bool -- ^ Whether eta-expansion is enabled - , sm_cast_swizzle :: !Bool -- ^ Do we swizzle casts past lambdas? - , sm_uf_opts :: !UnfoldingOpts -- ^ Unfolding options - , sm_case_case :: !Bool -- ^ Whether case-of-case is enabled - , sm_pre_inline :: !Bool -- ^ Whether pre-inlining is enabled - , sm_float_enable :: !FloatEnable -- ^ Whether to enable floating out + { sm_phase :: !CompilerPhase + , sm_names :: ![String] -- ^ Name(s) of the phase + , sm_rules :: !Bool -- ^ Whether RULES are enabled + , sm_inline :: !Bool -- ^ Whether inlining is enabled + , sm_eta_expand :: !Bool -- ^ Whether eta-expansion is enabled + , sm_cast_swizzle :: !Bool -- ^ Do we swizzle casts past lambdas? + , sm_uf_opts :: !UnfoldingOpts -- ^ Unfolding options + , sm_case_case :: !Bool -- ^ Whether case-of-case is enabled + , sm_pre_inline :: !Bool -- ^ Whether pre-inlining is enabled + , sm_float_enable :: !FloatEnable -- ^ Whether to enable floating out , sm_do_eta_reduction :: !Bool - , sm_arity_opts :: !ArityOpts - , sm_rule_opts :: !RuleOpts - , sm_case_folding :: !Bool - , sm_case_merge :: !Bool - , sm_co_opt_opts :: !OptCoercionOpts -- ^ Coercion optimiser options + , sm_arity_opts :: !ArityOpts + , sm_rule_opts :: !RuleOpts + , sm_case_folding :: !Bool + , sm_case_merge :: !Bool + , sm_co_opt_opts :: !OptCoercionOpts -- ^ Coercion optimiser options } instance Outputable SimplMode where ppr (SimplMode { sm_phase = p , sm_names = ss - , sm_first_iter = fi, sm_rules = r, sm_inline = i + , sm_rules = r, sm_inline = i , sm_cast_swizzle = cs , sm_eta_expand = eta, sm_case_case = cc }) = text "SimplMode" <+> braces ( sep [ text "Phase =" <+> ppr p <+> brackets (text (concat $ intersperse "," ss)) <> comma - , pp_flag fi (text "first-iter") <> comma , pp_flag i (text "inline") <> comma , pp_flag r (text "rules") <> comma , pp_flag eta (text "eta-expand") <> comma ===================================== compiler/GHC/Core/Opt/Simplify/Iteration.hs ===================================== @@ -2342,21 +2342,10 @@ simplOutId env fun cont -- Normal case for (f e1 .. en) simplOutId env fun cont - = do { rule_base <- getSimplRules + = -- Try rewrite rules: Plan (BEFORE) in Note [When to apply rewrite rules] + do { rule_base <- getSimplRules ; let rules_for_me = getRules rule_base fun - arg_info = mkArgInfo env fun rules_for_me cont out_args = contOutArgs env cont :: [OutExpr] - - -- If we are not in the first iteration, we have already tried rules and inlining - -- at the end of the previous iteration; no need to repeat that --- ; if not (sm_first_iter (seMode env)) --- then rebuildCall env arg_info cont --- else --- Do this BEFORE so that we can take advantage of single-occ inlines --- Example: T21839c which takes an extra Simplifier iteration after w/w --- if you don't do this - - -- Try rewrite rules: Plan (BEFORE) in Note [When to apply rewrite rules] ; mb_match <- if not (null rules_for_me) && (isClassOpId fun || activeUnfolding (seMode env) fun) then tryRules env rules_for_me fun out_args @@ -2368,14 +2357,16 @@ simplOutId env fun cont -- Try inlining do { logger <- getLogger - ; mb_inline <- tryInlining env logger fun (contArgs cont) + ; mb_inline <- tryInlining env logger fun cont ; case mb_inline of{ - Just expr -> simplExprF env expr cont ; + Just expr -> do { checkedTick (UnfoldingDone fun) + ; simplExprF env expr cont } ; Nothing -> -- Neither worked, so just rebuild - rebuildCall env arg_info cont - } } } } + do { let arg_info = mkArgInfo env fun rules_for_me cont + ; rebuildCall env arg_info cont + } } } } } --------------------------------------------------------- -- Dealing with a call site @@ -2447,39 +2438,28 @@ rebuildCall env fun_info ---------- No further useful info, revert to generic rebuild ------------ rebuildCall env (ArgInfo { ai_fun = fun, ai_args = rev_args, ai_rules = rules }) cont + | null rules + = rebuild env (argInfoExpr fun rev_args) cont + | otherwise -- Try rules again: Plan (AFTER) in Note [When to apply rewrite rules] = do { let args = reverse rev_args - - -- Try rules again: Plan (AFTER) in Note [When to apply rewrite rules] - ; mb_match <- if null rules - then return Nothing - else tryRules env rules fun (map argSpecArg args) - ; case mb_match of { + ; mb_match <- tryRules env rules fun (map argSpecArg args) + ; case mb_match of Just (rule_arity, rhs) -> simplExprF env rhs $ - pushSimplifiedArgs env (drop rule_arity args) cont ; - Nothing -> - - do { logger <- getLogger - ; mb_inline <- tryInlining env logger fun (null args, argSummaries env args, cont) - ; case mb_inline of - Just body -> simplExprF env body $ - pushSimplifiedArgs env args cont - Nothing -> rebuild env (argInfoExpr fun rev_args) cont - } } } + pushSimplifiedArgs env (drop rule_arity args) cont + Nothing -> rebuild env (argInfoExpr fun rev_args) cont } ----------------------------------- -tryInlining :: SimplEnv -> Logger -> OutId - -> (Bool, [ArgSummary], SimplCont) - -> SimplM (Maybe OutExpr) -tryInlining env logger fun (lone_variable, arg_infos, call_cont) - | Just expr <- callSiteInline env logger fun lone_variable arg_infos interesting_cont - = do { dump_inline expr call_cont - ; checkedTick (UnfoldingDone fun) +tryInlining :: SimplEnv -> Logger -> OutId -> SimplCont -> SimplM (Maybe OutExpr) +tryInlining env logger var cont + | Just expr <- callSiteInline env logger var lone_variable arg_infos interesting_cont + = do { dump_inline expr cont ; return (Just expr) } | otherwise = return Nothing where + (lone_variable, arg_infos, call_cont) = contArgs cont interesting_cont = interestingCallContext env call_cont log_inlining doc @@ -2490,12 +2470,12 @@ tryInlining env logger fun (lone_variable, arg_infos, call_cont) dump_inline unfolding cont | not (logHasDumpFlag logger Opt_D_dump_inlinings) = return () | not (logHasDumpFlag logger Opt_D_verbose_core2core) - = when (isExternalName (idName fun)) $ + = when (isExternalName (idName var)) $ log_inlining $ - sep [text "Inlining done:", nest 4 (ppr fun)] + sep [text "Inlining done:", nest 4 (ppr var)] | otherwise = log_inlining $ - sep [text "Inlining done: " <> ppr fun, + sep [text "Inlining done: " <> ppr var, nest 4 (vcat [text "Inlined fn: " <+> nest 2 (ppr unfolding), text "Cont: " <+> ppr cont])] ===================================== compiler/GHC/Core/Opt/Simplify/Utils.hs ===================================== @@ -24,7 +24,7 @@ module GHC.Core.Opt.Simplify.Utils ( SimplCont(..), DupFlag(..), FromWhat(..), StaticEnv, isSimplified, contIsStop, contIsDupable, contResultType, contHoleType, contHoleScaling, - contIsTrivial, contArgs, contIsRhs, argSummaries, + contIsTrivial, contArgs, contIsRhs, countArgs, contOutArgs, dropContArgs, mkBoringStop, mkRhsStop, mkLazyArgStop, interestingCallContext, @@ -537,11 +537,15 @@ contArgs cont lone _ = True go args (ApplyToVal { sc_arg = arg, sc_env = se, sc_cont = k }) - = go (argSummary se arg : args) k + = go (is_interesting arg se : args) k go args (ApplyToTy { sc_cont = k }) = go args k go args (CastIt { sc_cont = k }) = go args k go args k = (False, reverse args, k) + is_interesting arg se = interestingArg se arg + -- Do *not* use short-cutting substitution here + -- because we want to get as much IdInfo as possible + contOutArgs :: SimplEnv -> SimplCont -> [OutExpr] -- Get the leading arguments from the `SimplCont`, as /OutExprs/ contOutArgs env cont @@ -883,15 +887,6 @@ strictArgContext (ArgInfo { ai_encl = encl_rules, ai_discs = discs }) -- Why NonRecursive? Becuase it's a bit like -- let a = g x in f a -argSummaries :: SimplEnv -> [ArgSpec] -> [ArgSummary] -argSummaries env args - = go args - where - env' = zapSubstEnv env -- The args are simplified already - go [] = [] - go (TyArg {} : args) = go args - go (ValArg { as_arg = arg } : args) = argSummary env' arg : go args - interestingCallContext :: SimplEnv -> SimplCont -> CallCtxt -- See Note [Interesting call context] interestingCallContext env cont @@ -995,9 +990,9 @@ rule for (*) (df d) can fire. To do this b) we say that a con-like argument (eg (df d)) is interesting -} -argSummary :: SimplEnv -> CoreExpr -> ArgSummary +interestingArg :: SimplEnv -> CoreExpr -> ArgSummary -- See Note [Interesting arguments] -argSummary env e = go env 0 e +interestingArg env e = go env 0 e where -- n is # value args to which the expression is applied go env n (Var v) @@ -1005,8 +1000,6 @@ argSummary env e = go env 0 e DoneId v' -> go_var n v' DoneEx e _ -> go (zapSubstEnv env) n e ContEx tvs cvs ids e -> go (setSubstEnv env tvs cvs ids) n e - -- NB: substId looks up in the InScopeSet: - -- we want to get as much IdInfo as possible go _ _ (Lit l) | isLitRubbish l = TrivArg -- Leads to unproductive inlining in WWRec, #20035 @@ -1469,11 +1462,18 @@ preInlineUnconditionally env top_lvl bndr rhs rhs_env one_occ IAmDead = True -- Happens in ((\x.1) v) one_occ OneOcc{ occ_n_br = 1 - , occ_in_lam = NotInsideLam - , occ_int_cxt = int_cxt } - = isNotTopLevel top_lvl -- Get rid of allocation - || (int_cxt==IsInteresting && idArity bndr > 0) -- Function is applied - -- || (early_phase && not (isConLikeUnfolding unf)) -- See early_phase + , occ_in_lam = NotInsideLam } + = isNotTopLevel top_lvl || sePhase env /= FinalPhase + -- Inline even top level things if not inside lambda + -- Can reduce simplifier iterations, when something is later + -- inlining and becomes dead + -- + -- But not in FinalPhase because that's just after we have + -- carefully floated out constants to top level + + -- = isNotTopLevel top_lvl -- Get rid of allocation + -- || (int_cxt==IsInteresting && idArity bndr > 0) -- Function is applied + -- OLD || (early_phase && not (isConLikeUnfolding unf)) -- See early_phase one_occ OneOcc{ occ_n_br = 1 , occ_in_lam = IsInsideLam , occ_int_cxt = IsInteresting } ===================================== compiler/GHC/Driver/Config/Core/Opt/Simplify.hs ===================================== @@ -60,7 +60,6 @@ initSimplMode :: DynFlags -> CompilerPhase -> String -> SimplMode initSimplMode dflags phase name = SimplMode { sm_names = [name] , sm_phase = phase - , sm_first_iter = True , sm_rules = gopt Opt_EnableRewriteRules dflags , sm_eta_expand = gopt Opt_DoLambdaEtaExpansion dflags , sm_cast_swizzle = True View it on GitLab: https://gitlab.haskell.org/ghc/ghc/-/compare/29117fad96e827f1768ca0ac2ba8119... -- View it on GitLab: https://gitlab.haskell.org/ghc/ghc/-/compare/29117fad96e827f1768ca0ac2ba8119... You're receiving this email because of your account on gitlab.haskell.org.