[Git][ghc/ghc][wip/revert-dont-kee-exit-joins] Revert "Don't keep exit join points so much"
Matthew Pickering (@mpickering)
gitlab at gitlab.haskell.org
Tue Feb 7 13:50:23 UTC 2023
Matthew Pickering pushed to branch wip/revert-dont-kee-exit-joins at Glasgow Haskell Compiler / GHC
Commits:
9fda5397 by Matthew Pickering at 2023-02-07T13:49:47+00:00
Revert "Don't keep exit join points so much"
This reverts commit caced75765472a1a94453f2e5a439dba0d04a265.
It seems the patch "Don't keep exit join points so much" is causing
wide-spread regressions in the bytestring library benchmarks. If I
revert it then the 9.6 numbers are better on average than 9.4.
See https://gitlab.haskell.org/ghc/ghc/-/issues/22893#note_479525
- - - - -
11 changed files:
- compiler/GHC/Core/Opt/Exitify.hs
- compiler/GHC/Core/Opt/Pipeline.hs
- compiler/GHC/Core/Opt/Simplify/Env.hs
- compiler/GHC/Core/Opt/Simplify/Utils.hs
- compiler/GHC/Core/Opt/SpecConstr.hs
- compiler/GHC/Driver/Config/Core/Opt/Simplify.hs
- − testsuite/tests/simplCore/should_compile/T21148.hs
- − testsuite/tests/simplCore/should_compile/T21148.stderr
- testsuite/tests/simplCore/should_compile/all.T
- testsuite/tests/stranal/should_compile/T21128.hs
- testsuite/tests/stranal/should_compile/T21128.stderr
Changes:
=====================================
compiler/GHC/Core/Opt/Exitify.hs
=====================================
@@ -433,7 +433,6 @@ inlining.
Exit join points, recognizable using `isExitJoinId` are join points with an
occurrence in a recursive group, and can be recognized (after the occurrence
analyzer ran!) using `isExitJoinId`.
-
This function detects joinpoints with `occ_in_lam (idOccinfo id) == True`,
because the lambdas of a non-recursive join point are not considered for
`occ_in_lam`. For example, in the following code, `j1` is /not/ marked
@@ -447,29 +446,6 @@ To prevent inlining, we check for isExitJoinId
* In `simplLetUnfolding` we simply give exit join points no unfolding, which
prevents inlining in `postInlineUnconditionally` and call sites.
-But see Note [Be selective about not-inlining exit join points]
-
-Note [Be selective about not-inlining exit join points]
-~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~
-If we follow "do not inline exit join points" mantra throughout,
-some bad things happen.
-
-* We can lose CPR information: see #21148
-
-* We get useless clutter (#22084) that
- - makes the program bigger (including duplicated code #20739), and
- - adds extra jumps (and maybe stack saves) at runtime
-
-So instead we follow "do not inline exit join points" for a /single run/
-of the simplifier, right after Exitification. That should give a
-sufficient chance for used-once things to inline, but subsequent runs
-will inline them back in. (Annoyingly, as things stand, only with -O2
-is there a subsequent run, but that might change, and it's not a huge
-deal anyway.)
-
-This is controlled by the Simplifier's sm_keep_exits flag; see
-GHC.Core.Opt.Pipeline.
-
Note [Placement of the exitification pass]
~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~
I (Joachim) experimented with multiple positions for the Exitification pass in
=====================================
compiler/GHC/Core/Opt/Pipeline.hs
=====================================
@@ -15,7 +15,7 @@ import GHC.Driver.Plugins ( withPlugins, installCoreToDos )
import GHC.Driver.Env
import GHC.Driver.Config.Core.Lint ( endPass )
import GHC.Driver.Config.Core.Opt.LiberateCase ( initLiberateCaseOpts )
-import GHC.Driver.Config.Core.Opt.Simplify ( initSimplifyOpts, initSimplMode )
+import GHC.Driver.Config.Core.Opt.Simplify ( initSimplifyOpts, initSimplMode, initGentleSimplMode )
import GHC.Driver.Config.Core.Opt.WorkWrap ( initWorkWrapOpts )
import GHC.Driver.Config.Core.Rules ( initRuleOpts )
import GHC.Platform.Ways ( hasWay, Way(WayProf) )
@@ -28,7 +28,6 @@ import GHC.Core.Utils ( dumpIdInfoOfProgram )
import GHC.Core.Lint ( lintAnnots )
import GHC.Core.Lint.Interactive ( interactiveInScope )
import GHC.Core.Opt.Simplify ( simplifyExpr, simplifyPgm )
-import GHC.Core.Opt.Simplify.Env( SimplMode(..) )
import GHC.Core.Opt.Simplify.Monad
import GHC.Core.Opt.Monad
import GHC.Core.Opt.Pipeline.Types
@@ -153,45 +152,32 @@ getCoreToDo dflags hpt_rule_base extra_vars
maybe_strictness_before _
= CoreDoNothing
- ----------------------------
- base_simpl_mode :: SimplMode
- base_simpl_mode = initSimplMode dflags
-
- -- gentle_mode: make specialiser happy: minimum effort please
- -- See Note [Inline in InitialPhase]
- -- See Note [RULEs enabled in InitialPhase]
- gentle_mode = base_simpl_mode { sm_names = ["Gentle"]
- , sm_phase = InitialPhase
- , sm_case_case = False }
-
- simpl_mode phase name
- = base_simpl_mode { sm_names = [name], sm_phase = phase }
-
- keep_exits :: SimplMode -> SimplMode
- -- See Note [Be selective about not-inlining exit join points]
- -- in GHC.Core.Opt.Exitify
- keep_exits mode = mode { sm_keep_exits = True }
-
- ----------------------------
- run_simplifier mode iter
- = CoreDoSimplify $ initSimplifyOpts dflags extra_vars iter mode hpt_rule_base
-
- simpl_phase phase name iter = CoreDoPasses $
- [ maybe_strictness_before phase
- , run_simplifier (simpl_mode phase name) iter
- , maybe_rule_check phase ]
+ simpl_phase phase name iter
+ = CoreDoPasses
+ $ [ maybe_strictness_before phase
+ , CoreDoSimplify $ initSimplifyOpts dflags extra_vars iter
+ (initSimplMode dflags phase name) hpt_rule_base
+ , maybe_rule_check phase ]
-- Run GHC's internal simplification phase, after all rules have run.
-- See Note [Compiler phases] in GHC.Types.Basic
- simpl_gently = run_simplifier gentle_mode max_iter
- simplify_final name = run_simplifier ( simpl_mode FinalPhase name) max_iter
- simpl_keep_exits name = run_simplifier (keep_exits $ simpl_mode FinalPhase name) max_iter
+ simplify name = simpl_phase FinalPhase name max_iter
+
+ -- initial simplify: mk specialiser happy: minimum effort please
+ -- See Note [Inline in InitialPhase]
+ -- See Note [RULEs enabled in InitialPhase]
+ simpl_gently = CoreDoSimplify $ initSimplifyOpts dflags extra_vars max_iter
+ (initGentleSimplMode dflags) hpt_rule_base
- ----------------------------
dmd_cpr_ww = if ww_on then [CoreDoDemand True,CoreDoCpr,CoreDoWorkerWrapper]
else [CoreDoDemand False] -- NB: No CPR! See Note [Don't change boxity without worker/wrapper]
+ demand_analyser = (CoreDoPasses (
+ dmd_cpr_ww ++
+ [simplify "post-worker-wrapper"]
+ ))
+
-- Static forms are moved to the top level with the FloatOut pass.
-- See Note [Grand plan for static forms] in GHC.Iface.Tidy.StaticPtrTable.
static_ptrs_float_outwards =
@@ -281,16 +267,14 @@ getCoreToDo dflags hpt_rule_base extra_vars
runWhen call_arity $ CoreDoPasses
[ CoreDoCallArity
- , simplify_final "post-call-arity"
+ , simplify "post-call-arity"
],
-- Strictness analysis
- runWhen strictness $ CoreDoPasses
- (dmd_cpr_ww ++ [simplify_final "post-worker-wrapper"]),
+ runWhen strictness demand_analyser,
runWhen exitification CoreDoExitify,
-- See Note [Placement of the exitification pass]
- -- in GHC.Core.Opt.Exitify
runWhen full_laziness $
CoreDoFloatOutwards FloatOutSwitches {
@@ -312,17 +296,7 @@ getCoreToDo dflags hpt_rule_base extra_vars
runWhen do_float_in CoreDoFloatInwards,
- -- Final tidy-up run of the simplifier
- simpl_keep_exits "final tidy up",
- -- Keep exit join point because this is the first
- -- Simplifier run after Exitify. Subsequent runs will
- -- re-inline those exit join points; their work is done.
- -- See Note [Be selective about not-inlining exit join points]
- -- in GHC.Core.Opt.Exitify
- --
- -- Annoyingly, we only /have/ a subsequent run with -O2. With
- -- plain -O we'll still have those exit join points hanging around.
- -- Oh well.
+ simplify "final", -- Final tidy-up
maybe_rule_check FinalPhase,
@@ -332,31 +306,31 @@ getCoreToDo dflags hpt_rule_base extra_vars
-- Case-liberation for -O2. This should be after
-- strictness analysis and the simplification which follows it.
runWhen liberate_case $ CoreDoPasses
- [ CoreLiberateCase, simplify_final "post-liberate-case" ],
+ [ CoreLiberateCase, simplify "post-liberate-case" ],
-- Run the simplifier after LiberateCase to vastly
-- reduce the possibility of shadowing
-- Reason: see Note [Shadowing] in GHC.Core.Opt.SpecConstr
runWhen spec_constr $ CoreDoPasses
- [ CoreDoSpecConstr, simplify_final "post-spec-constr"],
+ [ CoreDoSpecConstr, simplify "post-spec-constr"],
-- See Note [Simplify after SpecConstr]
maybe_rule_check FinalPhase,
runWhen late_specialise $ CoreDoPasses
- [ CoreDoSpecialising, simplify_final "post-late-spec"],
+ [ CoreDoSpecialising, simplify "post-late-spec"],
-- LiberateCase can yield new CSE opportunities because it peels
-- off one layer of a recursive function (concretely, I saw this
-- 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_final "post-final-cse" ],
+ [ CoreCSE, simplify "post-final-cse" ],
--------- End of -O2 passes --------------
runWhen late_dmd_anal $ CoreDoPasses (
- dmd_cpr_ww ++ [simplify_final "post-late-ww"]
+ dmd_cpr_ww ++ [simplify "post-late-ww"]
),
-- Final run of the demand_analyser, ensures that one-shot thunks are
=====================================
compiler/GHC/Core/Opt/Simplify/Env.hs
=====================================
@@ -248,16 +248,13 @@ data SimplMode = SimplMode -- See comments in GHC.Core.Opt.Simplify.Monad
, 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_keep_exits :: !Bool -- ^ True <=> keep ExitJoinIds
- -- See Note [Do not inline exit join points]
- -- in GHC.Core.Opt.Exitify
- , sm_float_enable :: !FloatEnable -- ^ Whether to enable floating out
+ , 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
=====================================
compiler/GHC/Core/Opt/Simplify/Utils.hs
=====================================
@@ -1395,11 +1395,11 @@ preInlineUnconditionally
-- Reason: we don't want to inline single uses, or discard dead bindings,
-- for unlifted, side-effect-ful bindings
preInlineUnconditionally env top_lvl bndr rhs rhs_env
- | not pre_inline = Nothing
+ | not pre_inline_unconditionally = Nothing
| not active = Nothing
| isTopLevel top_lvl && isDeadEndId bndr = Nothing -- Note [Top-level bottoming Ids]
| isCoVar bndr = Nothing -- Note [Do not inline CoVars unconditionally]
- | keep_exits, isExitJoinId bndr = Nothing -- Note [Do not inline exit join points]
+ | isExitJoinId bndr = Nothing -- Note [Do not inline exit join points]
-- in module Exitify
| not (one_occ (idOccInfo bndr)) = Nothing
| not (isStableUnfolding unf) = Just $! (extend_subst_with rhs)
@@ -1409,36 +1409,19 @@ preInlineUnconditionally env top_lvl bndr rhs rhs_env
, Just inl <- maybeUnfoldingTemplate unf = Just $! (extend_subst_with inl)
| otherwise = Nothing
where
- mode = seMode env
- phase = sm_phase mode
- keep_exits = sm_keep_exits mode
- pre_inline = sm_pre_inline mode
-
unf = idUnfolding bndr
extend_subst_with inl_rhs = extendIdSubst env bndr $! (mkContEx rhs_env inl_rhs)
one_occ IAmDead = True -- Happens in ((\x.1) v)
-
one_occ OneOcc{ occ_n_br = 1
, occ_in_lam = NotInsideLam } = isNotTopLevel top_lvl || early_phase
-
one_occ OneOcc{ occ_n_br = 1
, occ_in_lam = IsInsideLam
, occ_int_cxt = IsInteresting } = canInlineInLam rhs
+ one_occ _ = False
- one_occ OneOcc{ occ_n_br = 1 } -- Inline join point that are used once, even inside
- | isJoinId bndr = True -- lambdas (which are presumably other join points)
- -- E.g. join j x = rhs in
- -- joinrec k y = ....j x....
- -- Here j must be an exit for k, and we can safely inline it under the lambda
- -- This includes the case where j is nullary: a nullary join point is just the
- -- same as an arity-1 one. So we don't look at occ_int_cxt.
- -- All of this only applies if keep_exits is False, otherwise the
- -- earlier guard on preInlineUnconditionally would have fired
-
- one_occ _ = False
-
- active = isActive phase (inlinePragmaActivation inline_prag)
+ pre_inline_unconditionally = sePreInline env
+ active = isActive (sePhase env) (inlinePragmaActivation inline_prag)
-- See Note [pre/postInlineUnconditionally in gentle mode]
inline_prag = idInlinePragma bndr
@@ -1470,7 +1453,7 @@ preInlineUnconditionally env top_lvl bndr rhs rhs_env
-- not ticks. Counting ticks cannot be duplicated, and non-counting
-- ticks around a Lam will disappear anyway.
- early_phase = phase /= FinalPhase
+ early_phase = sePhase env /= FinalPhase
-- If we don't have this early_phase test, consider
-- x = length [1,2,3]
-- The full laziness pass carefully floats all the cons cells to
=====================================
compiler/GHC/Core/Opt/SpecConstr.hs
=====================================
@@ -1532,10 +1532,8 @@ scExpr' env (Case scrut b ty alts)
scrut_occ = case con of
DataAlt dc -- See Note [Do not specialise evals]
| not (single_alt && all deadArgOcc arg_occs)
- -> -- pprTrace "sc_alt1" (ppr b' $$ ppr con $$ ppr bs $$ ppr arg_occs) $
- ScrutOcc (unitUFM dc arg_occs)
- _ -> -- pprTrace "sc_alt1" (ppr b' $$ ppr con $$ ppr bs $$ ppr arg_occs) $
- UnkOcc
+ -> ScrutOcc (unitUFM dc arg_occs)
+ _ -> UnkOcc
; return (usg', b_occ `combineOcc` scrut_occ, Alt con bs2 rhs') }
=====================================
compiler/GHC/Driver/Config/Core/Opt/Simplify.hs
=====================================
@@ -2,6 +2,7 @@ module GHC.Driver.Config.Core.Opt.Simplify
( initSimplifyExprOpts
, initSimplifyOpts
, initSimplMode
+ , initGentleSimplMode
) where
import GHC.Prelude
@@ -26,13 +27,12 @@ import GHC.Types.Var ( Var )
initSimplifyExprOpts :: DynFlags -> InteractiveContext -> SimplifyExprOpts
initSimplifyExprOpts dflags ic = SimplifyExprOpts
{ se_fam_inst = snd $ ic_instances ic
-
- , se_mode = (initSimplMode dflags) { sm_names = ["GHCi"]
- , sm_inline = False }
- -- sm_inline: do not do any inlining, in case we expose
- -- some unboxed tuple stuff that confuses the bytecode
+ , se_mode = (initSimplMode dflags InitialPhase "GHCi")
+ { sm_inline = False
+ -- Do not do any inlining, in case we expose some
+ -- unboxed tuple stuff that confuses the bytecode
-- interpreter
-
+ }
, se_top_env_cfg = TopEnvConfig
{ te_history_size = historySize dflags
, te_tick_factor = simplTickFactor dflags
@@ -56,25 +56,31 @@ initSimplifyOpts dflags extra_vars iterations mode hpt_rule_base = let
}
in opts
-initSimplMode :: DynFlags -> SimplMode
-initSimplMode dflags = SimplMode
- { sm_names = ["Unknown simplifier run"] -- Always overriden
- , sm_phase = InitialPhase
- , sm_rules = gopt Opt_EnableRewriteRules dflags
- , sm_eta_expand = gopt Opt_DoLambdaEtaExpansion dflags
- , sm_pre_inline = gopt Opt_SimplPreInlining dflags
- , sm_do_eta_reduction = gopt Opt_DoEtaReduction dflags
- , sm_uf_opts = unfoldingOpts dflags
- , sm_float_enable = floatEnable dflags
- , sm_arity_opts = initArityOpts dflags
- , sm_rule_opts = initRuleOpts dflags
- , sm_case_folding = gopt Opt_CaseFolding dflags
- , sm_case_merge = gopt Opt_CaseMerge dflags
- , sm_co_opt_opts = initOptCoercionOpts dflags
+initSimplMode :: DynFlags -> CompilerPhase -> String -> SimplMode
+initSimplMode dflags phase name = SimplMode
+ { sm_names = [name]
+ , sm_phase = phase
+ , sm_rules = gopt Opt_EnableRewriteRules dflags
+ , sm_eta_expand = gopt Opt_DoLambdaEtaExpansion dflags
, sm_cast_swizzle = True
- , sm_inline = True
- , sm_case_case = True
- , sm_keep_exits = False
+ , sm_inline = True
+ , sm_uf_opts = unfoldingOpts dflags
+ , sm_case_case = True
+ , sm_pre_inline = gopt Opt_SimplPreInlining dflags
+ , sm_float_enable = floatEnable dflags
+ , sm_do_eta_reduction = gopt Opt_DoEtaReduction dflags
+ , sm_arity_opts = initArityOpts dflags
+ , sm_rule_opts = initRuleOpts dflags
+ , sm_case_folding = gopt Opt_CaseFolding dflags
+ , sm_case_merge = gopt Opt_CaseMerge dflags
+ , sm_co_opt_opts = initOptCoercionOpts dflags
+ }
+
+initGentleSimplMode :: DynFlags -> SimplMode
+initGentleSimplMode dflags = (initSimplMode dflags InitialPhase "Gentle")
+ { -- Don't do case-of-case transformations.
+ -- This makes full laziness work better
+ sm_case_case = False
}
floatEnable :: DynFlags -> FloatEnable
=====================================
testsuite/tests/simplCore/should_compile/T21148.hs deleted
=====================================
@@ -1,12 +0,0 @@
-module T211148 where
-
--- The point of this test is that f should get a (nested)
--- CPR property, with a worker of type
--- $wf :: Int# -> State# RealWorld -> (# State# RealWorld, Int# #)
-
-{-# NOINLINE f #-}
--- The NOINLINE makes GHC do a worker/wrapper split
--- even though f is small
-f :: Int -> IO Int
-f x = return $! sum [0..x]
-
=====================================
testsuite/tests/simplCore/should_compile/T21148.stderr deleted
=====================================
@@ -1,126 +0,0 @@
-
-==================== Tidy Core ====================
-Result size of Tidy Core
- = {terms: 73, types: 80, coercions: 6, joins: 2/2}
-
--- RHS size: {terms: 1, types: 0, coercions: 0, joins: 0/0}
-T211148.$trModule4 :: GHC.Prim.Addr#
-[GblId,
- Unf=Unf{Src=<vanilla>, TopLvl=True, Value=True, ConLike=True,
- WorkFree=True, Expandable=True, Guidance=IF_ARGS [] 20 0}]
-T211148.$trModule4 = "main"#
-
--- RHS size: {terms: 2, types: 0, coercions: 0, joins: 0/0}
-T211148.$trModule3 :: GHC.Types.TrName
-[GblId,
- Unf=Unf{Src=<vanilla>, TopLvl=True, Value=True, ConLike=True,
- WorkFree=True, Expandable=True, Guidance=IF_ARGS [] 10 10}]
-T211148.$trModule3 = GHC.Types.TrNameS T211148.$trModule4
-
--- RHS size: {terms: 1, types: 0, coercions: 0, joins: 0/0}
-T211148.$trModule2 :: GHC.Prim.Addr#
-[GblId,
- Unf=Unf{Src=<vanilla>, TopLvl=True, Value=True, ConLike=True,
- WorkFree=True, Expandable=True, Guidance=IF_ARGS [] 30 0}]
-T211148.$trModule2 = "T211148"#
-
--- RHS size: {terms: 2, types: 0, coercions: 0, joins: 0/0}
-T211148.$trModule1 :: GHC.Types.TrName
-[GblId,
- Unf=Unf{Src=<vanilla>, TopLvl=True, Value=True, ConLike=True,
- WorkFree=True, Expandable=True, Guidance=IF_ARGS [] 10 10}]
-T211148.$trModule1 = GHC.Types.TrNameS T211148.$trModule2
-
--- RHS size: {terms: 3, types: 0, coercions: 0, joins: 0/0}
-T211148.$trModule :: GHC.Types.Module
-[GblId,
- Unf=Unf{Src=<vanilla>, TopLvl=True, Value=True, ConLike=True,
- WorkFree=True, Expandable=True, Guidance=IF_ARGS [] 10 10}]
-T211148.$trModule
- = GHC.Types.Module T211148.$trModule3 T211148.$trModule1
-
--- RHS size: {terms: 41, types: 35, coercions: 0, joins: 2/2}
-T211148.$wf [InlPrag=NOINLINE]
- :: GHC.Prim.Int#
- -> GHC.Prim.State# GHC.Prim.RealWorld
- -> (# GHC.Prim.State# GHC.Prim.RealWorld, GHC.Prim.Int# #)
-[GblId, Arity=2, Str=<L><L>, Unf=OtherCon []]
-T211148.$wf
- = \ (ww_s179 :: GHC.Prim.Int#)
- (eta_s17b [OS=OneShot] :: GHC.Prim.State# GHC.Prim.RealWorld) ->
- case GHC.Prim.># 0# ww_s179 of {
- __DEFAULT ->
- join {
- exit_X0 [Dmd=SC(S,C(1,!P(L,L)))]
- :: GHC.Prim.Int#
- -> GHC.Prim.Int#
- -> (# GHC.Prim.State# GHC.Prim.RealWorld, GHC.Prim.Int# #)
- [LclId[JoinId(2)(Nothing)], Arity=2, Str=<L><L>]
- exit_X0 (x_s16Z [OS=OneShot] :: GHC.Prim.Int#)
- (ww1_s172 [OS=OneShot] :: GHC.Prim.Int#)
- = (# eta_s17b, GHC.Prim.+# ww1_s172 x_s16Z #) } in
- joinrec {
- $wgo3_s175 [InlPrag=[2], Occ=LoopBreaker, Dmd=SC(S,C(1,!P(L,L)))]
- :: GHC.Prim.Int#
- -> GHC.Prim.Int#
- -> (# GHC.Prim.State# GHC.Prim.RealWorld, GHC.Prim.Int# #)
- [LclId[JoinId(2)(Nothing)], Arity=2, Str=<L><L>, Unf=OtherCon []]
- $wgo3_s175 (x_s16Z :: GHC.Prim.Int#) (ww1_s172 :: GHC.Prim.Int#)
- = case GHC.Prim.==# x_s16Z ww_s179 of {
- __DEFAULT ->
- jump $wgo3_s175
- (GHC.Prim.+# x_s16Z 1#) (GHC.Prim.+# ww1_s172 x_s16Z);
- 1# -> jump exit_X0 x_s16Z ww1_s172
- }; } in
- jump $wgo3_s175 0# 0#;
- 1# -> (# eta_s17b, 0# #)
- }
-
--- RHS size: {terms: 14, types: 19, coercions: 0, joins: 0/0}
-T211148.f1 [InlPrag=NOINLINE[final]]
- :: Int
- -> GHC.Prim.State# GHC.Prim.RealWorld
- -> (# GHC.Prim.State# GHC.Prim.RealWorld, Int #)
-[GblId,
- Arity=2,
- Str=<1!P(L)><L>,
- Cpr=1(, 1),
- Unf=Unf{Src=StableSystem, TopLvl=True, Value=True, ConLike=True,
- WorkFree=True, Expandable=True,
- Guidance=ALWAYS_IF(arity=2,unsat_ok=True,boring_ok=False)
- Tmpl= \ (x_s177 [Occ=Once1!] :: Int)
- (eta_s17b [Occ=Once1, OS=OneShot]
- :: GHC.Prim.State# GHC.Prim.RealWorld) ->
- case x_s177 of { GHC.Types.I# ww_s179 [Occ=Once1] ->
- case T211148.$wf ww_s179 eta_s17b of
- { (# ww1_s17e [Occ=Once1], ww2_s17j [Occ=Once1] #) ->
- (# ww1_s17e, GHC.Types.I# ww2_s17j #)
- }
- }}]
-T211148.f1
- = \ (x_s177 :: Int)
- (eta_s17b [OS=OneShot] :: GHC.Prim.State# GHC.Prim.RealWorld) ->
- case x_s177 of { GHC.Types.I# ww_s179 ->
- case T211148.$wf ww_s179 eta_s17b of { (# ww1_s17e, ww2_s17j #) ->
- (# ww1_s17e, GHC.Types.I# ww2_s17j #)
- }
- }
-
--- RHS size: {terms: 1, types: 0, coercions: 6, joins: 0/0}
-f [InlPrag=NOINLINE[final]] :: Int -> IO Int
-[GblId,
- Arity=2,
- Str=<1!P(L)><L>,
- Cpr=1(, 1),
- Unf=Unf{Src=<vanilla>, TopLvl=True, Value=True, ConLike=True,
- WorkFree=True, Expandable=True,
- Guidance=ALWAYS_IF(arity=0,unsat_ok=True,boring_ok=True)}]
-f = T211148.f1
- `cast` (<Int>_R %<'Many>_N ->_R Sym (GHC.Types.N:IO[0] <Int>_R)
- :: (Int
- -> GHC.Prim.State# GHC.Prim.RealWorld
- -> (# GHC.Prim.State# GHC.Prim.RealWorld, Int #))
- ~R# (Int -> IO Int))
-
-
-
=====================================
testsuite/tests/simplCore/should_compile/all.T
=====================================
@@ -429,7 +429,6 @@ test('T21763a', only_ways(['optasm']), compile, ['-O2 -ddump-rules'])
test('T22028', normal, compile, ['-O -ddump-rule-firings'])
test('T22114', normal, compile, ['-O'])
test('T21286', normal, multimod_compile, ['T21286', '-O -ddump-rule-firings'])
-test('T21148', [grep_errmsg(r'Cpr=') ], compile, ['-O -ddump-simpl'])
# One module, T21851.hs, has OPTIONS_GHC -ddump-simpl
test('T21851', [grep_errmsg(r'case.*w\$sf') ], multimod_compile, ['T21851', '-O -dno-typeable-binds -dsuppress-uniques'])
=====================================
testsuite/tests/stranal/should_compile/T21128.hs
=====================================
@@ -2,10 +2,6 @@ module T21128 where
import T21128a
-{- This test originally had some unnecessary reboxing of y
-in the hot path of $wtheresCrud. That reboxing should
-not happen. -}
-
theresCrud :: Int -> Int -> Int
theresCrud x y = go x
where
@@ -13,4 +9,3 @@ theresCrud x y = go x
go 1 = index x y 1
go n = go (n-1)
{-# NOINLINE theresCrud #-}
-
=====================================
testsuite/tests/stranal/should_compile/T21128.stderr
=====================================
@@ -1,7 +1,7 @@
==================== Tidy Core ====================
Result size of Tidy Core
- = {terms: 125, types: 68, coercions: 4, joins: 0/0}
+ = {terms: 137, types: 92, coercions: 4, joins: 0/0}
lvl = "error"#
@@ -29,11 +29,17 @@ lvl9 = SrcLoc lvl2 lvl3 lvl5 lvl6 lvl7 lvl6 lvl8
lvl10 = PushCallStack lvl1 lvl9 EmptyCallStack
+$windexError
+ = \ @a @b ww eta eta1 eta2 ->
+ error
+ (lvl10 `cast` <Co:4> :: CallStack ~R# (?callStack::CallStack))
+ (++ (ww eta) (++ (ww eta1) (ww eta2)))
+
indexError
= \ @a @b $dShow eta eta1 eta2 ->
- error
- (lvl10 `cast` <Co:4> :: ...)
- (++ (show $dShow eta) (++ (show $dShow eta1) (show $dShow eta2)))
+ case $dShow of { C:Show ww ww1 ww2 ->
+ $windexError ww1 eta eta1 eta2
+ }
$trModule3 = TrNameS $trModule4
@@ -42,7 +48,8 @@ $trModule1 = TrNameS $trModule2
$trModule = Module $trModule3 $trModule1
$wlvl
- = \ ww ww1 ww2 -> indexError $fShowInt (I# ww2) (I# ww1) (I# ww)
+ = \ ww ww1 ww2 ->
+ $windexError $fShowInt_$cshow (I# ww2) (I# ww1) (I# ww)
index
= \ l u i ->
@@ -66,7 +73,7 @@ index
==================== Tidy Core ====================
Result size of Tidy Core
- = {terms: 108, types: 46, coercions: 0, joins: 3/3}
+ = {terms: 108, types: 47, coercions: 0, joins: 3/4}
$trModule4 = "main"#
@@ -82,34 +89,35 @@ i = I# 1#
l = I# 0#
-lvl = \ x ww -> indexError $fShowInt x (I# ww) i
+lvl = \ y -> $windexError $fShowInt_$cshow l y l
-lvl1 = \ ww -> indexError $fShowInt l (I# ww) l
+lvl1 = \ ww y -> $windexError $fShowInt_$cshow (I# ww) y i
$wtheresCrud
= \ ww ww1 ->
+ let { y = I# ww1 } in
join {
- exit
- = case <# 0# ww1 of {
- __DEFAULT -> case lvl1 ww1 of wild { };
- 1# -> 0#
- } } in
- join {
- exit1
+ lvl2
= case <=# ww 1# of {
- __DEFAULT -> case lvl (I# ww) ww1 of wild { };
+ __DEFAULT -> case lvl1 ww y of wild { };
1# ->
case <# 1# ww1 of {
- __DEFAULT -> case lvl (I# ww) ww1 of wild { };
+ __DEFAULT -> case lvl1 ww y of wild { };
1# -> -# 1# ww
}
} } in
+ join {
+ lvl3
+ = case <# 0# ww1 of {
+ __DEFAULT -> case lvl y of wild { };
+ 1# -> 0#
+ } } in
joinrec {
$wgo ww2
= case ww2 of wild {
__DEFAULT -> jump $wgo (-# wild 1#);
- 0# -> jump exit;
- 1# -> jump exit1
+ 0# -> jump lvl3;
+ 1# -> jump lvl2
}; } in
jump $wgo ww
View it on GitLab: https://gitlab.haskell.org/ghc/ghc/-/commit/9fda5397e144fafa37bdfc130cd340a75de0fe3a
--
View it on GitLab: https://gitlab.haskell.org/ghc/ghc/-/commit/9fda5397e144fafa37bdfc130cd340a75de0fe3a
You're receiving this email because of your account on gitlab.haskell.org.
-------------- next part --------------
An HTML attachment was scrubbed...
URL: <http://mail.haskell.org/pipermail/ghc-commits/attachments/20230207/1c0c8ec6/attachment-0001.html>
More information about the ghc-commits
mailing list