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
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:
| ... | ... | @@ -156,7 +156,7 @@ simplifyPgm logger unit_env name_ppr_ctx opts |
| 156 | 156 | && logHasDumpFlag logger Opt_D_dump_simpl_stats) $
|
| 157 | 157 | logDumpMsg logger
|
| 158 | 158 | "Simplifier statistics for following pass"
|
| 159 | - (vcat [text termination_msg <+> text "after" <+> ppr it_count
|
|
| 159 | + (vcat [text termination_msg <+> text "after" <+> ppr (it_count-1)
|
|
| 160 | 160 | <+> text "iterations",
|
| 161 | 161 | blankLine,
|
| 162 | 162 | pprSimplCount counts_out])
|
| ... | ... | @@ -240,7 +240,8 @@ simplifyPgm logger unit_env name_ppr_ctx opts |
| 240 | 240 | ; read_rule_env = updExternalPackageRules base_rule_env <$> read_eps_rules
|
| 241 | 241 | |
| 242 | 242 | ; fam_envs = (eps_fam_inst_env eps, fam_inst_env)
|
| 243 | - ; simpl_env = mkSimplEnv mode fam_envs } ;
|
|
| 243 | + ; iter_mode = mode { sm_first_iter = iteration_no ==1 }
|
|
| 244 | + ; simpl_env = mkSimplEnv iter_mode fam_envs } ;
|
|
| 244 | 245 | |
| 245 | 246 | -- Simplify the program
|
| 246 | 247 | ((binds1, rules1), counts1) <-
|
| ... | ... | @@ -272,32 +272,35 @@ seUnfoldingOpts env = sm_uf_opts (seMode env) |
| 272 | 272 | |
| 273 | 273 | -- See Note [The environments of the Simplify pass]
|
| 274 | 274 | data SimplMode = SimplMode -- See comments in GHC.Core.Opt.Simplify.Monad
|
| 275 | - { sm_phase :: !CompilerPhase
|
|
| 276 | - , sm_names :: ![String] -- ^ Name(s) of the phase
|
|
| 277 | - , sm_rules :: !Bool -- ^ Whether RULES are enabled
|
|
| 278 | - , sm_inline :: !Bool -- ^ Whether inlining is enabled
|
|
| 279 | - , sm_eta_expand :: !Bool -- ^ Whether eta-expansion is enabled
|
|
| 280 | - , sm_cast_swizzle :: !Bool -- ^ Do we swizzle casts past lambdas?
|
|
| 281 | - , sm_uf_opts :: !UnfoldingOpts -- ^ Unfolding options
|
|
| 282 | - , sm_case_case :: !Bool -- ^ Whether case-of-case is enabled
|
|
| 283 | - , sm_pre_inline :: !Bool -- ^ Whether pre-inlining is enabled
|
|
| 284 | - , sm_float_enable :: !FloatEnable -- ^ Whether to enable floating out
|
|
| 275 | + { sm_phase :: !CompilerPhase
|
|
| 276 | + , sm_names :: ![String] -- ^ Name(s) of the phase
|
|
| 277 | + , sm_first_iter :: !Bool -- ^ True <=> first iteration
|
|
| 278 | + -- False <=> second or subsequent iteration
|
|
| 279 | + , sm_rules :: !Bool -- ^ Whether RULES are enabled
|
|
| 280 | + , sm_inline :: !Bool -- ^ Whether inlining is enabled
|
|
| 281 | + , sm_eta_expand :: !Bool -- ^ Whether eta-expansion is enabled
|
|
| 282 | + , sm_cast_swizzle :: !Bool -- ^ Do we swizzle casts past lambdas?
|
|
| 283 | + , sm_uf_opts :: !UnfoldingOpts -- ^ Unfolding options
|
|
| 284 | + , sm_case_case :: !Bool -- ^ Whether case-of-case is enabled
|
|
| 285 | + , sm_pre_inline :: !Bool -- ^ Whether pre-inlining is enabled
|
|
| 286 | + , sm_float_enable :: !FloatEnable -- ^ Whether to enable floating out
|
|
| 285 | 287 | , sm_do_eta_reduction :: !Bool
|
| 286 | - , sm_arity_opts :: !ArityOpts
|
|
| 287 | - , sm_rule_opts :: !RuleOpts
|
|
| 288 | - , sm_case_folding :: !Bool
|
|
| 289 | - , sm_case_merge :: !Bool
|
|
| 290 | - , sm_co_opt_opts :: !OptCoercionOpts -- ^ Coercion optimiser options
|
|
| 288 | + , sm_arity_opts :: !ArityOpts
|
|
| 289 | + , sm_rule_opts :: !RuleOpts
|
|
| 290 | + , sm_case_folding :: !Bool
|
|
| 291 | + , sm_case_merge :: !Bool
|
|
| 292 | + , sm_co_opt_opts :: !OptCoercionOpts -- ^ Coercion optimiser options
|
|
| 291 | 293 | }
|
| 292 | 294 | |
| 293 | 295 | instance Outputable SimplMode where
|
| 294 | 296 | ppr (SimplMode { sm_phase = p , sm_names = ss
|
| 295 | - , sm_rules = r, sm_inline = i
|
|
| 297 | + , sm_first_iter = fi, sm_rules = r, sm_inline = i
|
|
| 296 | 298 | , sm_cast_swizzle = cs
|
| 297 | 299 | , sm_eta_expand = eta, sm_case_case = cc })
|
| 298 | 300 | = text "SimplMode" <+> braces (
|
| 299 | 301 | sep [ text "Phase =" <+> ppr p <+>
|
| 300 | 302 | brackets (text (concat $ intersperse "," ss)) <> comma
|
| 303 | + , pp_flag fi (text "first-iter") <> comma
|
|
| 301 | 304 | , pp_flag i (text "inline") <> comma
|
| 302 | 305 | , pp_flag r (text "rules") <> comma
|
| 303 | 306 | , pp_flag eta (text "eta-expand") <> comma
|
| ... | ... | @@ -2342,11 +2342,19 @@ simplOutId env fun cont |
| 2342 | 2342 | |
| 2343 | 2343 | -- Normal case for (f e1 .. en)
|
| 2344 | 2344 | simplOutId env fun cont
|
| 2345 | - = -- Try rewrite rules: Plan (BEFORE) in Note [When to apply rewrite rules]
|
|
| 2346 | - do { rule_base <- getSimplRules
|
|
| 2345 | + = do { rule_base <- getSimplRules
|
|
| 2347 | 2346 | ; let rules_for_me = getRules rule_base fun
|
| 2347 | + arg_info = mkArgInfo env fun rules_for_me cont
|
|
| 2348 | 2348 | out_args = contOutArgs env cont :: [OutExpr]
|
| 2349 | - ; mb_match <- if not (null rules_for_me) &&
|
|
| 2349 | + |
|
| 2350 | + -- If we are not in the first iteration, we have already tried rules and inlining
|
|
| 2351 | + -- at the end of the previous iteration; no need to repeat that
|
|
| 2352 | + ; if not (sm_first_iter (seMode env))
|
|
| 2353 | + then rebuildCall env arg_info cont
|
|
| 2354 | + else
|
|
| 2355 | + |
|
| 2356 | + -- Try rewrite rules: Plan (BEFORE) in Note [When to apply rewrite rules]
|
|
| 2357 | + do { mb_match <- if not (null rules_for_me) &&
|
|
| 2350 | 2358 | (isClassOpId fun || activeUnfolding (seMode env) fun)
|
| 2351 | 2359 | then tryRules env rules_for_me fun out_args
|
| 2352 | 2360 | else return Nothing
|
| ... | ... | @@ -2357,15 +2365,13 @@ simplOutId env fun cont |
| 2357 | 2365 | |
| 2358 | 2366 | -- Try inlining
|
| 2359 | 2367 | do { logger <- getLogger
|
| 2360 | - ; mb_inline <- tryInlining env logger fun cont
|
|
| 2368 | + ; mb_inline <- tryInlining env logger fun (contArgs cont)
|
|
| 2361 | 2369 | ; case mb_inline of{
|
| 2362 | - Just expr -> do { checkedTick (UnfoldingDone fun)
|
|
| 2363 | - ; simplExprF env expr cont } ;
|
|
| 2370 | + Just expr -> simplExprF env expr cont ;
|
|
| 2364 | 2371 | Nothing ->
|
| 2365 | 2372 | |
| 2366 | 2373 | -- Neither worked, so just rebuild
|
| 2367 | - do { let arg_info = mkArgInfo env fun rules_for_me cont
|
|
| 2368 | - ; rebuildCall env arg_info cont
|
|
| 2374 | + rebuildCall env arg_info cont
|
|
| 2369 | 2375 | } } } } }
|
| 2370 | 2376 | |
| 2371 | 2377 | ---------------------------------------------------------
|
| ... | ... | @@ -2438,28 +2444,39 @@ rebuildCall env fun_info |
| 2438 | 2444 | |
| 2439 | 2445 | ---------- No further useful info, revert to generic rebuild ------------
|
| 2440 | 2446 | rebuildCall env (ArgInfo { ai_fun = fun, ai_args = rev_args, ai_rules = rules }) cont
|
| 2441 | - | null rules
|
|
| 2442 | - = rebuild env (argInfoExpr fun rev_args) cont
|
|
| 2443 | - | otherwise -- Try rules again: Plan (AFTER) in Note [When to apply rewrite rules]
|
|
| 2444 | 2447 | = do { let args = reverse rev_args
|
| 2445 | - ; mb_match <- tryRules env rules fun (map argSpecArg args)
|
|
| 2446 | - ; case mb_match of
|
|
| 2448 | + |
|
| 2449 | + -- Try rules again: Plan (AFTER) in Note [When to apply rewrite rules]
|
|
| 2450 | + ; mb_match <- if null rules
|
|
| 2451 | + then return Nothing
|
|
| 2452 | + else tryRules env rules fun (map argSpecArg args)
|
|
| 2453 | + ; case mb_match of {
|
|
| 2447 | 2454 | Just (rule_arity, rhs) -> simplExprF env rhs $
|
| 2448 | - pushSimplifiedArgs env (drop rule_arity args) cont
|
|
| 2449 | - Nothing -> rebuild env (argInfoExpr fun rev_args) cont }
|
|
| 2455 | + pushSimplifiedArgs env (drop rule_arity args) cont ;
|
|
| 2456 | + Nothing ->
|
|
| 2457 | + |
|
| 2458 | + do { logger <- getLogger
|
|
| 2459 | + ; mb_inline <- tryInlining env logger fun (null args, argSummaries env args, cont)
|
|
| 2460 | + ; case mb_inline of
|
|
| 2461 | + Just body -> simplExprF env body $
|
|
| 2462 | + pushSimplifiedArgs env args cont
|
|
| 2463 | + Nothing -> rebuild env (argInfoExpr fun rev_args) cont
|
|
| 2464 | + } } }
|
|
| 2450 | 2465 | |
| 2451 | 2466 | -----------------------------------
|
| 2452 | -tryInlining :: SimplEnv -> Logger -> OutId -> SimplCont -> SimplM (Maybe OutExpr)
|
|
| 2453 | -tryInlining env logger var cont
|
|
| 2454 | - | Just expr <- callSiteInline env logger var lone_variable arg_infos interesting_cont
|
|
| 2455 | - = do { dump_inline expr cont
|
|
| 2467 | +tryInlining :: SimplEnv -> Logger -> OutId
|
|
| 2468 | + -> (Bool, [ArgSummary], SimplCont)
|
|
| 2469 | + -> SimplM (Maybe OutExpr)
|
|
| 2470 | +tryInlining env logger fun (lone_variable, arg_infos, call_cont)
|
|
| 2471 | + | Just expr <- callSiteInline env logger fun lone_variable arg_infos interesting_cont
|
|
| 2472 | + = do { dump_inline expr call_cont
|
|
| 2473 | + ; checkedTick (UnfoldingDone fun)
|
|
| 2456 | 2474 | ; return (Just expr) }
|
| 2457 | 2475 | |
| 2458 | 2476 | | otherwise
|
| 2459 | 2477 | = return Nothing
|
| 2460 | 2478 | |
| 2461 | 2479 | where
|
| 2462 | - (lone_variable, arg_infos, call_cont) = contArgs cont
|
|
| 2463 | 2480 | interesting_cont = interestingCallContext env call_cont
|
| 2464 | 2481 | |
| 2465 | 2482 | log_inlining doc
|
| ... | ... | @@ -2470,12 +2487,12 @@ tryInlining env logger var cont |
| 2470 | 2487 | dump_inline unfolding cont
|
| 2471 | 2488 | | not (logHasDumpFlag logger Opt_D_dump_inlinings) = return ()
|
| 2472 | 2489 | | not (logHasDumpFlag logger Opt_D_verbose_core2core)
|
| 2473 | - = when (isExternalName (idName var)) $
|
|
| 2490 | + = when (isExternalName (idName fun)) $
|
|
| 2474 | 2491 | log_inlining $
|
| 2475 | - sep [text "Inlining done:", nest 4 (ppr var)]
|
|
| 2492 | + sep [text "Inlining done:", nest 4 (ppr fun)]
|
|
| 2476 | 2493 | | otherwise
|
| 2477 | 2494 | = log_inlining $
|
| 2478 | - sep [text "Inlining done: " <> ppr var,
|
|
| 2495 | + sep [text "Inlining done: " <> ppr fun,
|
|
| 2479 | 2496 | nest 4 (vcat [text "Inlined fn: " <+> nest 2 (ppr unfolding),
|
| 2480 | 2497 | text "Cont: " <+> ppr cont])]
|
| 2481 | 2498 |
| ... | ... | @@ -24,7 +24,7 @@ module GHC.Core.Opt.Simplify.Utils ( |
| 24 | 24 | SimplCont(..), DupFlag(..), FromWhat(..), StaticEnv,
|
| 25 | 25 | isSimplified, contIsStop,
|
| 26 | 26 | contIsDupable, contResultType, contHoleType, contHoleScaling,
|
| 27 | - contIsTrivial, contArgs, contIsRhs,
|
|
| 27 | + contIsTrivial, contArgs, contIsRhs, argSummaries,
|
|
| 28 | 28 | countArgs, contOutArgs, dropContArgs,
|
| 29 | 29 | mkBoringStop, mkRhsStop, mkLazyArgStop,
|
| 30 | 30 | interestingCallContext,
|
| ... | ... | @@ -537,15 +537,11 @@ contArgs cont |
| 537 | 537 | lone _ = True
|
| 538 | 538 | |
| 539 | 539 | go args (ApplyToVal { sc_arg = arg, sc_env = se, sc_cont = k })
|
| 540 | - = go (is_interesting arg se : args) k
|
|
| 540 | + = go (argSummary se arg : args) k
|
|
| 541 | 541 | go args (ApplyToTy { sc_cont = k }) = go args k
|
| 542 | 542 | go args (CastIt { sc_cont = k }) = go args k
|
| 543 | 543 | go args k = (False, reverse args, k)
|
| 544 | 544 | |
| 545 | - is_interesting arg se = interestingArg se arg
|
|
| 546 | - -- Do *not* use short-cutting substitution here
|
|
| 547 | - -- because we want to get as much IdInfo as possible
|
|
| 548 | - |
|
| 549 | 545 | contOutArgs :: SimplEnv -> SimplCont -> [OutExpr]
|
| 550 | 546 | -- Get the leading arguments from the `SimplCont`, as /OutExprs/
|
| 551 | 547 | contOutArgs env cont
|
| ... | ... | @@ -887,6 +883,15 @@ strictArgContext (ArgInfo { ai_encl = encl_rules, ai_discs = discs }) |
| 887 | 883 | -- Why NonRecursive? Becuase it's a bit like
|
| 888 | 884 | -- let a = g x in f a
|
| 889 | 885 | |
| 886 | +argSummaries :: SimplEnv -> [ArgSpec] -> [ArgSummary]
|
|
| 887 | +argSummaries env args
|
|
| 888 | + = go args
|
|
| 889 | + where
|
|
| 890 | + env' = zapSubstEnv env -- The args are simplified already
|
|
| 891 | + go [] = []
|
|
| 892 | + go (TyArg {} : args) = go args
|
|
| 893 | + go (ValArg { as_arg = arg } : args) = argSummary env' arg : go args
|
|
| 894 | + |
|
| 890 | 895 | interestingCallContext :: SimplEnv -> SimplCont -> CallCtxt
|
| 891 | 896 | -- See Note [Interesting call context]
|
| 892 | 897 | interestingCallContext env cont
|
| ... | ... | @@ -990,9 +995,9 @@ rule for (*) (df d) can fire. To do this |
| 990 | 995 | b) we say that a con-like argument (eg (df d)) is interesting
|
| 991 | 996 | -}
|
| 992 | 997 | |
| 993 | -interestingArg :: SimplEnv -> CoreExpr -> ArgSummary
|
|
| 998 | +argSummary :: SimplEnv -> CoreExpr -> ArgSummary
|
|
| 994 | 999 | -- See Note [Interesting arguments]
|
| 995 | -interestingArg env e = go env 0 e
|
|
| 1000 | +argSummary env e = go env 0 e
|
|
| 996 | 1001 | where
|
| 997 | 1002 | -- n is # value args to which the expression is applied
|
| 998 | 1003 | go env n (Var v)
|
| ... | ... | @@ -1000,6 +1005,8 @@ interestingArg env e = go env 0 e |
| 1000 | 1005 | DoneId v' -> go_var n v'
|
| 1001 | 1006 | DoneEx e _ -> go (zapSubstEnv env) n e
|
| 1002 | 1007 | ContEx tvs cvs ids e -> go (setSubstEnv env tvs cvs ids) n e
|
| 1008 | + -- NB: substId looks up in the InScopeSet:
|
|
| 1009 | + -- we want to get as much IdInfo as possible
|
|
| 1003 | 1010 | |
| 1004 | 1011 | go _ _ (Lit l)
|
| 1005 | 1012 | | isLitRubbish l = TrivArg -- Leads to unproductive inlining in WWRec, #20035
|
| ... | ... | @@ -60,6 +60,7 @@ initSimplMode :: DynFlags -> CompilerPhase -> String -> SimplMode |
| 60 | 60 | initSimplMode dflags phase name = SimplMode
|
| 61 | 61 | { sm_names = [name]
|
| 62 | 62 | , sm_phase = phase
|
| 63 | + , sm_first_iter = True
|
|
| 63 | 64 | , sm_rules = gopt Opt_EnableRewriteRules dflags
|
| 64 | 65 | , sm_eta_expand = gopt Opt_DoLambdaEtaExpansion dflags
|
| 65 | 66 | , sm_cast_swizzle = True
|