Simon Peyton Jones pushed to branch wip/T23109a at Glasgow Haskell Compiler / GHC Commits: fb2d5dee by Simon Peyton Jones at 2025-05-15T23:17:57-04:00 Try inlining after simplifying the arguments - - - - - 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 + (vcat [text termination_msg <+> text "after" <+> ppr (it_count-1) <+> text "iterations", blankLine, pprSimplCount counts_out]) @@ -240,7 +240,8 @@ 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) - ; simpl_env = mkSimplEnv mode fam_envs } ; + ; iter_mode = mode { sm_first_iter = iteration_no ==1 } + ; simpl_env = mkSimplEnv iter_mode fam_envs } ; -- Simplify the program ((binds1, rules1), counts1) <- ===================================== compiler/GHC/Core/Opt/Simplify/Env.hs ===================================== @@ -272,32 +272,35 @@ 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_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_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_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_rules = r, sm_inline = i + , sm_first_iter = fi, 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,11 +2342,19 @@ simplOutId env fun cont -- Normal case for (f e1 .. en) simplOutId env fun cont - = -- Try rewrite rules: Plan (BEFORE) in Note [When to apply rewrite rules] - do { rule_base <- getSimplRules + = 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] - ; mb_match <- if not (null rules_for_me) && + + -- 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 + + -- Try rewrite rules: Plan (BEFORE) in Note [When to apply rewrite rules] + do { mb_match <- if not (null rules_for_me) && (isClassOpId fun || activeUnfolding (seMode env) fun) then tryRules env rules_for_me fun out_args else return Nothing @@ -2357,15 +2365,13 @@ simplOutId env fun cont -- Try inlining do { logger <- getLogger - ; mb_inline <- tryInlining env logger fun cont + ; mb_inline <- tryInlining env logger fun (contArgs cont) ; case mb_inline of{ - Just expr -> do { checkedTick (UnfoldingDone fun) - ; simplExprF env expr cont } ; + Just expr -> simplExprF env expr cont ; Nothing -> -- Neither worked, so just rebuild - do { let arg_info = mkArgInfo env fun rules_for_me cont - ; rebuildCall env arg_info cont + rebuildCall env arg_info cont } } } } } --------------------------------------------------------- @@ -2438,28 +2444,39 @@ 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 - ; mb_match <- tryRules env rules fun (map argSpecArg args) - ; case mb_match of + + -- 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 { Just (rule_arity, rhs) -> simplExprF env rhs $ - pushSimplifiedArgs env (drop rule_arity args) cont - Nothing -> rebuild env (argInfoExpr fun rev_args) cont } + 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 + } } } ----------------------------------- -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 +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) ; return (Just expr) } | otherwise = return Nothing where - (lone_variable, arg_infos, call_cont) = contArgs cont interesting_cont = interestingCallContext env call_cont log_inlining doc @@ -2470,12 +2487,12 @@ tryInlining env logger var cont dump_inline unfolding cont | not (logHasDumpFlag logger Opt_D_dump_inlinings) = return () | not (logHasDumpFlag logger Opt_D_verbose_core2core) - = when (isExternalName (idName var)) $ + = when (isExternalName (idName fun)) $ log_inlining $ - sep [text "Inlining done:", nest 4 (ppr var)] + sep [text "Inlining done:", nest 4 (ppr fun)] | otherwise = log_inlining $ - sep [text "Inlining done: " <> ppr var, + sep [text "Inlining done: " <> ppr fun, 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, + contIsTrivial, contArgs, contIsRhs, argSummaries, countArgs, contOutArgs, dropContArgs, mkBoringStop, mkRhsStop, mkLazyArgStop, interestingCallContext, @@ -537,15 +537,11 @@ contArgs cont lone _ = True go args (ApplyToVal { sc_arg = arg, sc_env = se, sc_cont = k }) - = go (is_interesting arg se : args) k + = go (argSummary se arg : 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 @@ -887,6 +883,15 @@ 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 @@ -990,9 +995,9 @@ rule for (*) (df d) can fire. To do this b) we say that a con-like argument (eg (df d)) is interesting -} -interestingArg :: SimplEnv -> CoreExpr -> ArgSummary +argSummary :: SimplEnv -> CoreExpr -> ArgSummary -- See Note [Interesting arguments] -interestingArg env e = go env 0 e +argSummary env e = go env 0 e where -- n is # value args to which the expression is applied go env n (Var v) @@ -1000,6 +1005,8 @@ interestingArg 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 ===================================== compiler/GHC/Driver/Config/Core/Opt/Simplify.hs ===================================== @@ -60,6 +60,7 @@ 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/-/commit/fb2d5dee8f50052bb3cc0bcaec37de78... -- View it on GitLab: https://gitlab.haskell.org/ghc/ghc/-/commit/fb2d5dee8f50052bb3cc0bcaec37de78... You're receiving this email because of your account on gitlab.haskell.org.