Simon Peyton Jones pushed to branch wip/case-bndr-unf at Glasgow Haskell Compiler / GHC Commits: 24d1ab3b by Simon Peyton Jones at 2026-10-27T17:27:22+00:00 Use SimplClo for the argument of ApplyToVal This patch renames SimplSR to SimplClo (a "closure"), and uses it not only as the range of the Simplifier's substitution, but also as the argument of an ApplyToVal continuation. ApplyToVal used to have three fields sc_env :: StaticEnv sc_arg :: CoreExpr sc_cast :: MOutCoercion but now has just sc_dup :: DupFlag sc_arg :: SimplClo An un-simplified argument is (ContEx env arg mco), and an already-simplified one is (DoneEx arg _). See Note [The argument of ApplyToVal] in GHC.Core.Opt.Simplify.Utils. The main payoff is that, since the substitution maps an Id to a SimplClo, beta-reduction can substitute the argument for the lambda binder without further ado. Accordingly, preInlineUnconditionally is split into * preInlineLetUnconditionally, for let-bindings * preInlineBetaUnconditionally, for beta-redexes, which takes a SimplClo The latter omits some checks that cannot fire for lambda binders. Other notes * The new (ContEx env arg mco) form makes it easy to push a cast into an argument (mkCloCastMCo), whether or not it has been simplified. See Note [The MOutCoercion field of ContEx]. * `preInlineUnconditionally` gets split into two variants, one for let-bindings and one for beta-reduction (which takes a `SimplClo`). There is a little bit of duplication here, but not much. * Fixes #27962. The simplifier was previously dropping a cast when dealing with runRW#. The new `SimplClo` makes that bug much harder to allow. * Fixes #27963. contOutArgs, which supplies the arguments for Plan (BEFORE) rule matching, ignored the sc_cast field of ApplyToVal. So in (f |> co) n ==> f (n |> co1) -- co1 in sc_cast a rule for `f` saw `f n` rather than `f (n |> co1)`, and failed to match (the rule matcher checks the types of template variables). If f's unfolding is active, f may then be inlined, and the rule is lost for good. Now contOutArgs uses simplCloExpr, which includes the pending cast. Almost no change in behaviour, except for the #27963 bug-fix. Co-Authored-By: Claude Opus 5.5 <noreply@anthropic.com> - - - - - 10 changed files: - + changelog.d/T27962 - + changelog.d/T27963 - compiler/GHC/Core/Opt/Simplify/Env.hs - compiler/GHC/Core/Opt/Simplify/Iteration.hs - compiler/GHC/Core/Opt/Simplify/Utils.hs - testsuite/tests/simplCore/should_compile/T15445.stderr - + testsuite/tests/simplCore/should_compile/T27962.hs - + testsuite/tests/simplCore/should_compile/T27963.hs - + testsuite/tests/simplCore/should_compile/T27963.stderr - testsuite/tests/simplCore/should_compile/all.T Changes: ===================================== changelog.d/T27962 ===================================== @@ -0,0 +1,7 @@ +section: compiler +issues: #27962 +mrs: !16869 +synopsis: + Fix a Lint error when using `runRW#` and `coerce` together +description: + Just an internal compiler bug, of long standing. ===================================== changelog.d/T27963 ===================================== @@ -0,0 +1,7 @@ +section: compiler +issues: #27963 +mrs: !16869 +synopsis: + Fix a rather obscure interaction of `coerce` and RULES +description: + A `coerce` could prevent a RULE firing. ===================================== compiler/GHC/Core/Opt/Simplify/Env.hs ===================================== @@ -28,7 +28,7 @@ module GHC.Core.Opt.Simplify.Env ( SimplEnvIS, checkSimplEnvIS, pprBadSimplEnvIS, -- * Substitution results - SimplSR(..), substId, lookupRecBndr, + SimplClo(..), simplCloExpr, substId, lookupRecBndr, -- * Simplifying 'Id' binders simplNonRecBndr, simplNonRecJoinBndr, simplRecBndrs, simplRecJoinBndrs, @@ -61,7 +61,7 @@ import GHC.Core.Opt.Simplify.Monad import GHC.Core.Rules.Config ( RuleOpts(..) ) import GHC.Core import GHC.Core.Utils -import GHC.Core.Subst( substExprSC ) +import GHC.Core.Subst( substExpr ) import GHC.Core.Unfold import GHC.Core.TyCo.Subst (emptyIdSubstEnv, mkSubst) import GHC.Core.Multiplicity( Scaled(..), mkMultMul ) @@ -470,18 +470,26 @@ pprSimplEnv env ppr_one v | isId v = ppr v <+> ppr (idUnfolding v) | otherwise = ppr v -type SimplIdSubst = IdEnv SimplSR -- IdId |--> OutExpr +type SimplIdSubst = IdEnv SimplClo -- IdId |--> OutExpr -- See Note [Extending the IdSubstEnv] in GHC.Core.Subst --- | A substitution result. -data SimplSR +-- | A "closure" used in the Simplifier. It is used +-- * as the range of the substitution, 'SimplIdSubst' +-- * as the argument in an 'ApplyToVal' continuation +-- Roughly: either an (InExpr, StaticEnv) pair for an +-- as-yet-unsimplified expression +-- or an OutExpr, for an already-simplified one +-- It's a bit like thunk: we may "evaluate" the SimplClo in a ApplyToVal +-- and thereby transform it from `ContEx` to `DoneEx` +-- This happens in the `ApplyToVal` case of `mkDupableContWithDmds` +-- See Note [The argument of ApplyToVal] in GHC.Core.Opt.Simplify.Utils +data SimplClo = DoneEx OutExpr JoinPointHood -- If x :-> DoneEx e ja is in the SimplIdSubst -- then replace occurrences of x by e -- and ja = Just a <=> x is a join-point of arity a -- See Note [Join arity in SimplIdSubst] - | DoneId OutId -- If x :-> DoneId v is in the SimplIdSubst -- then replace occurrences of x by v @@ -490,11 +498,11 @@ data SimplSR | ContEx SimplEnv InExpr - MOutCoercion -- See Note [The sc_cast field of ApplyToVal] + MOutCoercion -- See Note [The MOutCoercion field of ContEx] -- If x :-> ContEx static_env e mco is in the SimplISubst -- then replace occurrences of x by (subst static_env e) |> mco -instance Outputable SimplSR where +instance Outputable SimplClo where ppr (DoneId v) = text "DoneId" <+> ppr v ppr (DoneEx e mj) = text "DoneEx" <> pp_mj <+> ppr e where @@ -637,7 +645,7 @@ reSimplifying :: SimplEnv -> Bool reSimplifying (SimplEnv { seInlineDepth = n }) = n>0 --------------------- -extendIdSubst :: SimplEnv -> Id -> SimplSR -> SimplEnv +extendIdSubst :: SimplEnv -> Id -> SimplClo -> SimplEnv extendIdSubst env@(SimplEnv {seIdSubst = subst}) var res = assertPpr (isId var && not (isCoVar var)) (ppr var) $ env { seIdSubst = extendVarEnv subst var res } @@ -1032,7 +1040,7 @@ So we want to look up the inner X.g_34 in the substitution, where we'll find that it has been substituted by b. (Or conceivably cloned.) -} -substId :: SimplEnv -> InId -> SimplSR +substId :: SimplEnv -> InId -> SimplClo -- Returns DoneEx only on a non-Var expression substId (SimplEnv { seInScope = in_scope, seIdSubst = ids }) v = case lookupVarEnv ids v of -- Note [Global Ids in the substitution] @@ -1364,15 +1372,18 @@ getTCvSubst (SimplEnv { seInScope = in_scope, seTvSubst = tv_env, seCvSubst = cv getFullSubst :: InScopeSet -> SimplEnv -> Subst getFullSubst in_scope (SimplEnv { seIdSubst = id_env, seTvSubst = tv_env, seCvSubst = cv_env }) - = mkSubst in_scope (mapVarEnv to_expr id_env) tv_env cv_env + = mkSubst in_scope (mapVarEnv (simplCloExpr in_scope) id_env) tv_env cv_env + +simplCloExpr :: InScopeSet -> SimplClo -> OutExpr +-- Turn a SimplClo into an OutExpr, by applying the substitution +-- (if any) and the pending cast (if any) +simplCloExpr _ (DoneEx e _) = e +simplCloExpr _ (DoneId v) = Var v +simplCloExpr in_scope (ContEx env e mco) = mkCastMCo e' mco where - to_expr :: SimplSR -> CoreExpr - -- A tiresome impedence-matcher - to_expr (DoneEx e _) = e - to_expr (DoneId v) = Var v - to_expr (ContEx env e mco) = mkCastMCo e' mco - where - e' = GHC.Core.Subst.substExprSC (getFullSubst in_scope env) e + e' = GHC.Core.Subst.substExpr (getFullSubst in_scope env) e + -- NB: we use substExpr, not substExprSC: we want to get the benefit of + -- knowing what is evaluated etc, via the in-scope set substTy :: HasDebugCallStack => SimplEnv -> Type -> Type substTy env ty = Type.substTy (getTCvSubst env) ty ===================================== compiler/GHC/Core/Opt/Simplify/Iteration.hs ===================================== @@ -285,8 +285,8 @@ simplRecOrTopPair :: SimplEnv -> SimplM (SimplFloats, SimplEnv) simplRecOrTopPair env bind_cxt old_bndr new_bndr rhs - | Just env' <- preInlineUnconditionally env (bindContextLevel bind_cxt) - old_bndr (UnSimplified env) rhs MRefl + | Just env' <- preInlineLetUnconditionally env (bindContextLevel bind_cxt) + old_bndr rhs env = {-#SCC "simplRecOrTopPair-pre-inline-uncond" #-} simplTrace "SimplBindr:inline-uncond1" (ppr old_bndr) $ do { tick (PreInlineUnconditionally old_bndr) @@ -1226,17 +1226,8 @@ simplExprF1 env (Tick t expr) cont = {-#SCC "simplTick" #-} simplTick env t exp simplExprF1 env (Coercion co) cont = {-#SCC "simplCoercionF" #-} simplCoercionF env co cont simplExprF1 env (Cast body co) cont - = do { co1 <- {-#SCC "simplCast-simplCoercion" #-} - simplCoercion env co - - ; let cont1 = {-#SCC "simplCast-addCoerce" #-} - if isReflCo co1 - then cont -- See Note [Optimising reflexivity] - else pushCast env co1 cont - -- True <=> co1 is optimised - - ; {-#SCC "simplCast-simplExprF" #-} - simplExprF env body cont1 } + = do { co1 <- simplCoercion env co + ; simplExprF env body (pushCast env co1 cont) } simplExprF1 env (App fun arg) cont = {-#SCC "simplExprF1-App" #-} case arg of @@ -1264,9 +1255,9 @@ simplExprF1 env (App fun arg) cont -- observed the quadratic behavior, so this extra entanglement -- seems not worthwhile. simplExprF env fun $ - ApplyToVal { sc_arg = arg, sc_env = UnSimplified env + ApplyToVal { sc_arg = ContEx env arg MRefl, sc_dup = NoDup , sc_hole_ty = substTy env (exprType fun) - , sc_cast = MRefl, sc_cont = cont } + , sc_cont = cont } simplExprF1 env expr@(Lam {}) cont = {-#SCC "simplExprF1-Lam" #-} @@ -1301,7 +1292,7 @@ simplExprF1 env (Let (NonRec bndr rhs) body) cont do { ty' <- simplType env ty ; simplExprF (extendTvSubst env bndr ty') body cont } - | Just env' <- preInlineUnconditionally env NotTopLevel bndr (UnSimplified env) rhs MRefl + | Just env' <- preInlineLetUnconditionally env NotTopLevel bndr rhs env -- Because of the let-can-float invariant, it's ok to -- inline freely, or to drop the binding if it is dead. = do { simplTrace "SimplBindr:inline-uncond2" (ppr bndr) $ @@ -1637,9 +1628,8 @@ rebuild_go env expr cont ApplyToTy { sc_arg_ty = ty, sc_cont = cont} -> rebuild_go env (App expr (Type ty)) cont - ApplyToVal { sc_arg = arg, sc_env = arg_se, sc_cast = arg_mco - , sc_cont = cont, sc_hole_ty = fun_ty } - -> do { arg' <- simplArg env Nothing fun_ty arg_se arg arg_mco + ApplyToVal { sc_arg = arg, sc_cont = cont, sc_hole_ty = fun_ty } + -> do { arg' <- simplArg env Nothing fun_ty arg ; rebuild_go env (App expr arg') cont } completeBindX :: SimplEnv @@ -1687,69 +1677,12 @@ completeBindX env from_what bndr rhs body cont ; let all_floats = rhs_floats `addFloats` bind_float `addFloats` body_floats ; return ( all_floats, body' ) } -{- -************************************************************************ + +{- ********************************************************************* * * -\subsection{Lambdas} + Arguments * * -************************************************************************ --} - -{- Note [Optimising reflexivity] -~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~ -It's important (for compiler performance) to get rid of reflexivity as soon -as it appears. See #11735, #14737, and #15019. - -In particular, we want to behave well on - - * e |> co1 |> co2 - where the two happen to cancel out entirely. That is quite common; - e.g. a newtype wrapping and unwrapping cancel. - - - * (f |> co) @t1 @t2 ... @tn x1 .. xm - Here we will use pushCoTyArg and pushCoValArg successively, which - build up SelCo stacks. Silly to do that if co is reflexive. - -However, we don't want to call isReflexiveCo too much, because it uses -type equality which is expensive on big types (#14737 comment:7). - -A good compromise (determined experimentally) seems to be to call -isReflexiveCo - * when composing casts, and - * at the end - -In investigating this I saw missed opportunities for on-the-fly -coercion shrinkage. See #15090. - -Note [Avoid re-simplifying coercions] -~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~ -In some benchmarks (with deeply nested cases) we successively push -casts onto the SimplCont. We don't want to call the coercion optimiser -on each successive composition -- that's at least quadratic. So: - -* The CastIt constructor in SimplCont has a `sc_opt :: Bool` flag to - record whether the coercion optimiser has been applied to the coercion. - -* In `simplCast`, when we see (Cast e co), we simplify `co` to get - an OutCoercion, and built a CastIt with sc_opt=True. - - Actually not quite: if we are simplifying the result of inlining an - unfolding (seInlineDepth > 0), then instead of /optimising/ it again, - just /substitute/ which is cheaper. See `simplCoercion`. - -* In `pushCast` if we combine this new coercion with an existing one, - we build a CastIt for (co1 ; co2) with sc_opt=False. - -* When unpacking a CastIt, in `rebuild`, we optimise the (presumably - composed) coercion if sc_opt=False; this is done by `optOutCoercion`. - -* When duplicating a continuation in `mkDupableContWithDmds`, before - duplicating a CastIt, optimise the coercion. Otherwise we'll end up - optimising it separately in the duplicate copies. - -* See also Note [The sc_cast field of ApplyToVal] in GHC.Core.Opt.Simplify.Utils. --} +********************************************************************* -} simplArg :: SimplEnvIS -- ^ Used only for its InScopeSet -> Maybe ArgInfo -- ^ Just <=> This arg `ai` occurs in an app @@ -1757,15 +1690,12 @@ simplArg :: SimplEnvIS -- ^ Used only for its InScopeSet -- how `f` uses `ai`, affecting the Stop -- continuation passed to 'simplExprC' -> OutType -- ^ Type of the function applied to this arg - -> StaticEnv -> CoreExpr -- ^ Expression with its static envt - -> MOutCoercion -- Wrap this around the result + -> SimplClo -- ^ The argument -> SimplM OutExpr -simplArg _ _ _ (Simplified {}) arg mco - = -- See Note [Avoid repeated simplification] - case mco of - MRefl -> return arg -- Vastly common case - MCo co -> return (mkCast arg co) -simplArg env mb_arg_info fun_ty (UnSimplified arg_se) arg mco +-- See Note [The argument of ApplyToVal] in GHC.Core.Opt.Simplify.Utils +simplArg _ _ _ (DoneEx arg _) = return arg -- See Note [Avoid repeated simplification] +simplArg _ _ _ (DoneId v) = return (Var v) +simplArg env mb_arg_info fun_ty (ContEx arg_se arg mco) = do { let arg_env' = arg_se `setInScopeFromE` env arg_ty = funArgTy fun_ty stop = case mb_arg_info of @@ -1774,13 +1704,12 @@ simplArg env mb_arg_info fun_ty (UnSimplified arg_se) arg mco cont = addCastMCo mco stop ; simplExprC arg_env' arg cont } -{- -************************************************************************ + +{- ********************************************************************* * * -\subsection{Lambdas} + Lambdas * * -************************************************************************ --} +********************************************************************* -} simplNonRecBody :: SimplEnv -> FromWhat -> InExpr -> SimplCont @@ -1807,13 +1736,9 @@ simpl_lam env bndr body (ApplyToTy { sc_arg_ty = arg_ty, sc_cont = cont }) -- Value beta-reduction -- This works for /coercion/ lambdas too -simpl_lam env bndr body (ApplyToVal { sc_arg = arg, sc_env = arg_se - , sc_cast = arg_mco, sc_cont = cont +simpl_lam env bndr body (ApplyToVal { sc_arg = arg, sc_cont = cont , sc_hole_ty = fun_ty}) - | Just env' <- preInlineUnconditionally env NotTopLevel bndr arg_se arg arg_mco - , not (needsCaseBindingL arg_levity arg) - -- Ok to test arg::InExpr in needsCaseBinding because - -- exprOkForSpeculation is stable under simplification + | Just env' <- preInlineBetaUnconditionally env arg_levity bndr arg = simplTrace "SimplBindr:inline-uncond3" (ppr bndr <+> text ":=" <+> ppr arg) $ do { tick (BetaReduction bndr) @@ -1824,14 +1749,14 @@ simpl_lam env bndr body (ApplyToVal { sc_arg = arg, sc_env = arg_se = do { tick (BetaReduction bndr) ; let from_what = FromBeta arg_levity - ; case (arg_se, arg_mco) of - (UnSimplified arg_env, MRefl) + ; case arg of + ContEx arg_env arg_expr MRefl -- Optimisation: when there is no wrapping coercion use simplNonRecE -- so that the clever floating out of let-bindings can take place -- in this round of the Simplifier - -> simplNonRecE env from_what bndr (arg, arg_env) body cont + -> simplNonRecE env from_what bndr (arg_expr, arg_env) body cont - _ -> do { arg' <- simplArg env Nothing fun_ty arg_se arg arg_mco + _ -> do { arg' <- simplArg env Nothing fun_ty arg ; completeBindX env from_what bndr arg' body cont } } where @@ -2295,11 +2220,14 @@ simplOutId env fun cont | fun `hasKey` runRWKey , ApplyToTy { sc_cont = cont1 } <- cont , ApplyToTy { sc_cont = cont2, sc_arg_ty = hole_ty } <- cont1 - , ApplyToVal { sc_cont = cont3, sc_arg = arg, sc_cast = arg_mco - , sc_env = arg_se, sc_hole_ty = fun_ty } <- cont2 + , ApplyToVal { sc_cont = cont3, sc_arg = arg_clo, sc_hole_ty = fun_ty } <- cont2 -- Do this even if (contIsStop cont), or if seCaseCase is off. -- See Note [No eta-expansion in runRW#] - = do { let (_saf,arg_env) = mkAltEnv env arg_se + = do { let (arg_env, arg, arg_mco) + = case arg_clo of + ContEx se e mco -> (se `setInScopeFromE` env, e, mco) + DoneEx e _ -> (env, e, MRefl) + DoneId v -> (env, Var v, MRefl) overall_res_ty = contResultType cont3 -- hole_ty is the type of the current runRW# application @@ -2314,23 +2242,32 @@ simplOutId env fun cont -- * If we don't do this we get a beta-redex every time, so the -- simplifier keeps doing more iterations. -- * Even more important: see Note [No eta-expansion in runRW#] + -- + -- But only if there is no pending cast on the argument (#27962); + -- if there is, the general case below deals with it properly ; arg' <- case arg of - Lam s body -> do { (env', s') <- simplBinder arg_env s - ; body' <- simplExprC env' body inner_cont - ; return (Lam s' body') } - -- Important: do not try to eta-expand this lambda - -- See Note [No eta-expansion in runRW#] + Lam s body + | MRefl <- arg_mco + -> do { (env', s') <- simplBinder arg_env s + ; body' <- simplExprC env' body inner_cont + ; return (Lam s' body') } + -- Important: do not try to eta-expand this lambda + -- See Note [No eta-expansion in runRW#] _ -> do { s' <- newId (fsLit "s") ManyTy realWorldStatePrimTy ; let (m,_,_) = splitFunTy fun_ty env' = arg_env `addNewInScopeIds` [s'] hole_ty = mkVisFunTy m realWorldStatePrimTy new_runrw_res_ty cont' = pushCastMCo env' arg_mco $ - ApplyToVal { sc_arg = Var s', sc_cast = MRefl - , sc_env = Simplified OkDup + ApplyToVal { sc_arg = DoneId s' + , sc_dup = dup , sc_cont = inner_cont , sc_hole_ty = hole_ty } -- cont' applies to s', then K + -- The argument (Var s') is small, but inner_cont may not be + -- dupable; see (AV2) in Note [The argument of ApplyToVal] + dup | contIsDupable inner_cont = OkDup + | otherwise = NoDup ; body' <- simplExprC env' arg cont' ; return (Lam s' body') } @@ -2397,13 +2334,12 @@ rebuildCall env info (ApplyToTy { sc_arg_ty = arg_ty, sc_hole_ty = hole_ty, sc_c ---------- Simplify value arguments -------------------- rebuildCall env fun_info - (ApplyToVal { sc_arg = arg, sc_env = arg_se, sc_cast = arg_mco - , sc_hole_ty = fun_ty, sc_cont = cont }) - | UnSimplified arg_env <- arg_se + (ApplyToVal { sc_arg = arg, sc_hole_ty = fun_ty, sc_cont = cont }) + | ContEx arg_env arg_expr arg_mco <- arg , isStrictArgInfo fun_info -- Strict arguments , seCaseCase env -- But only when case-of-case is on. -- See Note [Case-of-case and full laziness] - = simplExprF (arg_env `setInScopeFromE` env) arg $ + = simplExprF (arg_env `setInScopeFromE` env) arg_expr $ addCastMCo arg_mco $ StrictArg { sc_fun = fun_info, sc_fun_ty = fun_ty , sc_dup = NoDup @@ -2415,7 +2351,7 @@ rebuildCall env fun_info -- There is no benefit (unlike in a let-binding), and we'd -- have to be very careful about bogus strictness through -- floating a demanded let. - = do { arg' <- simplArg env (Just fun_info) fun_ty arg_se arg arg_mco + = do { arg' <- simplArg env (Just fun_info) fun_ty arg ; rebuildCall env (addValArgTo fun_info arg' fun_ty) cont } ---------- No further useful info, revert to generic rebuild ------------ @@ -2563,11 +2499,11 @@ Then * We simplify BIG before trying the rule; but the rule does not fire (forcing this simplification is why we have the RULE in this example) * We inline f = \x. g x, in `simpl_lam` - * So if `simpl_lam` did preInlineUnconditionally we get (g BIG) + * So if `simpl_lam` did preInlineBetaUnconditionally we get (g BIG) * Now if g has a RULE we'll simplify BIG again, and this whole thing can iterate. * However, if `f` did not have a RULE, so that BIG has /not/ already been - simplified, we /want/ to do preInlineUnconditionally in simpl_lam. + simplified, we /want/ to do preInlineBetaUnconditionally in simpl_lam. So we go to some effort to avoid repeatedly simplifying the same thing. Suppose we are in the Plan (AFTER) case of rule application, for a rule @@ -2576,8 +2512,9 @@ and a call f (e1,e2) Then: -* The (sc_env :: StaticEnv) field of ApplyToVal records if the argument - has been evaluated. See Note [StaticEnv] in GHC.Core.Opt.Simplify.Utils. +* The (sc_arg :: SimplClo) field of ApplyToVal records if the argument + has been simplified: it is a DoneEx if so, and a ContEx if not. + See Note [The argument of ApplyToVal] in GHC.Core.Opt.Simplify.Utils. * The rule fires returning RuleMatch { rm_rhs = (\x y. ...x..), rm_args = [ e1, e2 ] } @@ -2590,17 +2527,17 @@ Then: is the reason that `RuleMatch` separates the two. * `fireRuleAFTER` uses `pushOutArgs` to push [ e1, e2 ] back onto the - continuation with sc_env=Simplified NoDup. + continuation as (DoneEx e1) and (DoneEx e2). * Beta-reduction fires (in `simpl_lam`) for the \x. * Suppose `x` occurs many times. Then we want to behave like `let x=e1 in ..`, - but we use `simplArg`, which in turn uses that `sc_env` flag to avoid + but we use `simplArg`, which in turn uses the DoneEx to avoid re-simplifying `e1`. * Suppose `x` occurs just once or not at all; then the call to - `preInlineUnconditionally` in `simpl_lam` will fire, and extend the - substitution with + `preInlineBetaUnconditionally` in `simpl_lam` will fire, and extend the + substitution with the very same SimplClo x :-> DoneEx e1 * At the /occurrence/ of `x`, the function `simplInId` calls `simplOutExpr` @@ -2807,8 +2744,7 @@ trySeqRules in_env scrut rhs cont , ValArg { as_arg = no_cast_scrut , as_dmd = seqDmd , as_hole_ty = res3_ty } ] - rule_cont = ApplyToVal { sc_env = UnSimplified in_env, sc_arg = rhs - , sc_cast = MRefl + rule_cont = ApplyToVal { sc_arg = ContEx in_env rhs MRefl, sc_dup = NoDup , sc_cont = cont, sc_hole_ty = res4_ty } out_args = [Type rhs_rep, Type scrut_ty, Type rhs_ty, no_cast_scrut] @@ -3913,8 +3849,8 @@ knownCon env scrut dc dc_args case_bndr alt_bndrs rhs cont return ( emptyFloats env , extendIdSubst env case_bndr (DoneEx scrut NotJoinPoint)) - | Just env' <- preInlineUnconditionally env NotTopLevel case_bndr - (UnSimplified env) con_app MRefl + | Just env' <- preInlineLetUnconditionally env NotTopLevel case_bndr + con_app env = return (emptyFloats env', env') | otherwise @@ -4148,8 +4084,7 @@ mkDupableContWithDmds env dmds , sc_arg_ty = arg_ty, sc_hole_ty = hole_ty }) } mkDupableContWithDmds env dmds - (ApplyToVal { sc_arg = arg, sc_env = se, sc_cast = arg_mco - , sc_cont = cont, sc_hole_ty = hole_ty }) + (ApplyToVal { sc_arg = arg, sc_cont = cont, sc_hole_ty = hole_ty }) = -- e.g. [...hole...] (...arg...) -- ==> -- let a = ...arg... @@ -4161,12 +4096,12 @@ mkDupableContWithDmds env dmds expectNonEmpty dmds ; (floats1, cont') <- mkDupableContWithDmds env cont_dmds cont ; let env' = env `setInScopeFromF` floats1 - ; arg' <- simplArg env' Nothing hole_ty se arg arg_mco + ; arg' <- simplArg env' Nothing hole_ty arg ; (let_floats2, triv_arg) <- makeTrivial env' NotTopLevel dmd (fsLit "karg") arg' ; let all_floats = floats1 `addLetFloats` let_floats2 ; return ( all_floats - , ApplyToVal { sc_arg = triv_arg, sc_env = Simplified OkDup - , sc_cast = MRefl, sc_cont = cont', sc_hole_ty = hole_ty }) } + , ApplyToVal { sc_arg = DoneEx triv_arg NotJoinPoint, sc_dup = OkDup + , sc_cont = cont', sc_hole_ty = hole_ty }) } mkDupableContWithDmds env _ (Select { sc_bndr = case_bndr, sc_alts = alts, sc_env = se, sc_cont = cont }) ===================================== compiler/GHC/Core/Opt/Simplify/Utils.hs ===================================== @@ -12,7 +12,8 @@ module GHC.Core.Opt.Simplify.Utils ( tryEtaExpandRhs, wantEtaExpansion, -- Inlining, - preInlineUnconditionally, postInlineUnconditionally, + preInlineLetUnconditionally, preInlineBetaUnconditionally, + postInlineUnconditionally, activeRule, getUnfoldingInRuleMatch, updModeForStableUnfoldings, updModeForRuleLHS, updModeForRuleRHS, @@ -174,16 +175,14 @@ data SimplCont -- Invariant: never an identity coercion , sc_opt :: Bool -- True <=> sc_co has had optCoercion applied to it -- See Note [Avoid re-simplifying coercions] - -- in GHC.Core.Opt.Simplify.Iteration , sc_cont :: SimplCont } | ApplyToVal -- (ApplyToVal arg K)[e] = K[ e arg ] { sc_hole_ty :: OutType -- Type of the function, presumably (forall a. blah) -- See Note [The hole type in ApplyToTy] - , sc_env :: StaticEnv -- See Note [StaticEnv] - , sc_arg :: CoreExpr -- The argument - , sc_cast :: MOutCoercion -- Wrap this OutCoercion around the (simplified) argument - -- See Note [The sc_cast field of ApplyToVal] + , sc_dup :: DupFlag -- See Note [The argument of ApplyToVal] + , sc_arg :: SimplClo -- The argument + -- Invariant: if sc_arg is a ContEx, then sc_dup = NoDup , sc_cont :: SimplCont } | ApplyToTy -- (ApplyToTy ty K)[e] = K[ e ty ] @@ -253,49 +252,85 @@ perhapsSubstTy (UnSimplified env) ty = substTy env ty {- Note [StaticEnv] ~~~~~~~~~~~~~~~~~~~ -Consider ApplyToVal, which has - sc_env :: StaticEnv - sc_arg :: CoreExpr -Initially, `sc_arg` is an un-simplified InExpr, and `sc_env` is (UnSimplified env), -where `env` gives meaning to the free variables of `sc_arg`; in particular, `env` -may have substitutions that must apply to the argument. - -But sometimes we simplify the argument, and in that case, `sc_arg` is an OutExpr, -the simplified argument, and `sc_env` is (Simplified NoDup) or (Simplified OkDup). -The former is the safe, conservative option, but in `mkDupableCont` we want to make -the continuation duplicable, so we make the argument small and tag it with -(Simplified OkDup). - -We later simplify the argument, e.g. in `simplArg`. Then - * If sc_env is Simplified, it's a no-op - * If sc_env is (UnSimplified arg_env) we simplify `sc_arg` with - - Its captured envt `arg_env` +Consider Select, which has + sc_env :: StaticEnv + sc_bndr :: Id + sc_alts :: [CoreAlt] +Initially, `sc_bndr` and `sc_alts` are un-simplified InThings, and `sc_env` is +(UnSimplified env), where `env` gives meaning to their free variables; in +particular, `env` may have substitutions that must apply to them. + +But sometimes (notably in `mkDupableCont`) we simplify them, and in that case +`sc_bndr` and `sc_alts` are OutThings, and `sc_env` is (Simplified dup). + +When we finally simplify the alternatives (see `mkAltEnv`) + * If sc_env is Simplified, there is nothing to do + * If sc_env is (UnSimplified alt_env) we simplify them with + - Their captured envt `alt_env` - but overriding its InScopeSet with the larger one at the simplification point. Why override the InScopeSet? Example: - (let y = ey in f) ex - By the time we simplify ex, 'y' will be in scope. - All this is done in `simplArg`. + case (let y = ey in f) of alts + By the time we simplify alts, 'y' will be in scope. Note that: * In the Simplified case there is no environment, because the substitution has already been applied. -* We say sc_arg :: CoreExpr, rather than sc_arg :: InExpr or sc_arg :: OutExpr, - because whether it is InExpr or OutExpr depends on `sc_env` +* We say sc_alts :: [CoreAlt], rather than [InAlt] or [OutAlt], + because whether they are InAlts or OutAlts depends on `sc_env` + +* Same deal for StrictBind, where the StaticEnv scopes over sc_bndr and sc_body. -* Same deal for Select, and StrictBind, but the StaticEnv scopes over - * sc_bndr and sc_alts (for Select) - * sc_bndr and sc_body (for StrictBind) +* ApplyToVal is similar, but simpler: it uses a SimplClo instead. + See Note [The argument of ApplyToVal]. -* Even though the InScopeSet of an (UnSimplified se) is overridden in `simplArg`, - that InScopeSet is not irrelevant: it should include all the free vars of - applying the substitution to the InExpr. Reason: contHoleType uses perhapsSubstTy - to apply the substitution to the expression, and that (rightly) gives ASSERT - failures if the InScopeSet isn't big enough. +* Even though the InScopeSet of an (UnSimplified se) is overridden, that + InScopeSet is not irrelevant: it should include all the free vars of + applying the substitution to the InThing. Reason: contHoleType uses + perhapsSubstTy to apply the substitution to the binder, and that + (rightly) gives ASSERT failures if the InScopeSet isn't big enough. (SE1) If dup = OkToDup, then continuation k is also ok-to-dup + +Note [The argument of ApplyToVal] +~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~ +ApplyToVal has + sc_dup :: DupFlag + sc_arg :: SimplClo + +Initially, `sc_arg` is (ContEx env arg MRefl), where `arg` is the un-simplified +InExpr, and `env` gives meaning to the free variables of `arg`; in particular, +`env` may have substitutions that must apply to the argument. + +But sometimes we simplify the argument, and in that case, `sc_arg` is +(DoneEx arg' NotJoinPoint), where `arg'` is the simplified argument. + +The `sc_dup` flag says whether the continuation can be duplicated. NoDup is +the safe, conservative option, but in `mkDupableCont` we want to make the +continuation duplicable, so we make the argument small (and hence a DoneEx) +and set `sc_dup` to OkDup. Invariants: + + (AV1) If `sc_arg` is a ContEx, then `sc_dup` is NoDup. + + (AV2) If `sc_dup` is OkDup then `sc_cont` is also ok-to-dup; see (SE1) + in Note [StaticEnv]. + +We later simplify the argument, in `simplArg`. Then + * If `sc_arg` is a DoneEx (or DoneId), it's a no-op + * If `sc_arg` is (ContEx arg_env arg mco) we simplify `arg` with + - Its captured envt `arg_env` + - but overriding its InScopeSet with the larger one at the + simplification point. + Why override the InScopeSet? Example: + (let y = ey in f) ex + By the time we simplify ex, 'y' will be in scope. + Then we wrap the cast `mco` around the result. + See Note [The MOutCoercion field of ContEx]. + +Using a SimplClo for the argument means that it can be substituted for a lambda +binder, in `preInlineBetaUnconditionally`, without further ado. -} instance Outputable DupFlag where @@ -313,9 +348,9 @@ instance Outputable SimplCont where = (text "TickIt" <+> ppr t) $$ ppr cont ppr (ApplyToTy { sc_arg_ty = ty, sc_cont = cont }) = (text "ApplyToTy" <+> pprParendType ty) $$ ppr cont - ppr (ApplyToVal { sc_arg = arg, sc_env = env, sc_cont = cont, sc_hole_ty = hole_ty }) - = (hang (text "ApplyToVal" <> braces (ppr env) <+> text "hole-ty:" <+> pprParendType hole_ty) - 2 (pprParendExpr arg)) + ppr (ApplyToVal { sc_arg = arg, sc_dup = dup, sc_cont = cont, sc_hole_ty = hole_ty }) + = (hang (text "ApplyToVal" <> braces (ppr dup) <+> text "hole-ty:" <+> pprParendType hole_ty) + 2 (ppr arg)) $$ ppr cont ppr (StrictBind { sc_bndr = b, sc_cont = cont }) = (text "StrictBind" <+> ppr b) $$ ppr cont @@ -434,8 +469,8 @@ pushOutArgs fun_ty (arg:args) cont = ApplyToTy { sc_hole_ty = fun_ty, sc_arg_ty = ty , sc_cont = pushOutArgs (piResultTy fun_ty ty) args cont } | otherwise - = ApplyToVal { sc_hole_ty = fun_ty, sc_cast = MRefl - , sc_arg = arg, sc_env = Simplified NoDup + = ApplyToVal { sc_hole_ty = fun_ty + , sc_arg = DoneEx arg NotJoinPoint, sc_dup = NoDup , sc_cont = pushOutArgs (funResultTy fun_ty) args cont} pushArgSpecs :: [ArgSpec] -- In normal, forward order @@ -446,7 +481,7 @@ pushArgSpec :: ArgSpec -> SimplCont -> SimplCont pushArgSpec (TyArg { as_arg_ty = arg_ty, as_hole_ty = hole_ty }) cont = ApplyToTy { sc_arg_ty = arg_ty, sc_hole_ty = hole_ty, sc_cont = cont } pushArgSpec (ValArg { as_arg = arg, as_hole_ty = hole_ty }) cont - = ApplyToVal { sc_arg = arg, sc_env = Simplified NoDup, sc_cast = MRefl + = ApplyToVal { sc_arg = DoneEx arg NotJoinPoint, sc_dup = NoDup , sc_hole_ty = hole_ty, sc_cont = cont } argSpecArg :: ArgSpec -> OutExpr @@ -497,7 +532,12 @@ contIsStop _ = False contIsDupable :: SimplCont -> Bool contIsDupable (Stop {}) = True contIsDupable (ApplyToTy { sc_cont = k }) = contIsDupable k -contIsDupable (ApplyToVal { sc_env = se }) = okToDupSE se -- See (SE1) in Note [StaticEnv] +contIsDupable (ApplyToVal { sc_dup = dup, sc_arg = arg }) + = assertPpr (not (okToDup dup && is_cont_ex arg)) (ppr arg) $ + okToDup dup -- See (AV1,AV2) in Note [The argument of ApplyToVal] + where + is_cont_ex (ContEx {}) = True + is_cont_ex _ = False contIsDupable (Select { sc_env = se }) = okToDupSE se -- ...ditto... contIsDupable (StrictBind { sc_env = se }) = okToDupSE se -- ...ditto... contIsDupable (StrictArg { sc_dup = dup }) = okToDup dup -- ...ditto... @@ -606,8 +646,8 @@ contArgs env cont lone (CastIt {}) = False -- stops it being "lone" lone _ = True - go args (ApplyToVal { sc_arg = arg, sc_env = se, sc_cont = k }) - = go (interestingArg env se arg : args) k + go args (ApplyToVal { sc_arg = arg, sc_cont = k }) + = go (interestingArg env 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) @@ -622,15 +662,13 @@ contOutArgs env cont go (ApplyToTy { sc_arg_ty = ty, sc_cont = cont }) = Type ty : go cont - go (ApplyToVal { sc_arg = arg, sc_env = se, sc_cont = cont }) - = case se of - Simplified {} -> arg : go cont - UnSimplified env -> GHC.Core.Subst.substExpr (getFullSubst in_scope env) arg : go cont - -- Make sure we apply the static environment `sc_env` as a substitution + go (ApplyToVal { sc_arg = arg, sc_cont = cont }) + = simplCloExpr in_scope arg : go cont + -- Make sure we apply the static environment of a ContEx as a substitution -- to get an OutExpr. See (BF1) in Note [tryRules: plan (BEFORE)] -- in GHC.Core.Opt.Simplify.Iteration - -- NB: we use substExpr, not substExprSC: we want to get the benefit of - -- knowing what is evaluated etc, via the in-scope set + -- simplCloExpr also wraps the pending cast (if any) around the argument; + -- omitting it can make a rule fail to match (#27963) -- No more arguments go _ = [] @@ -827,23 +865,86 @@ make use of the strictness info for the function. * * ********************************************************************* -} -{- Note [The sc_cast field of ApplyToVal] -~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~ +{- Note [The MOutCoercion field of ContEx] +~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~ In the `ApplyToVal` case of `pushCast` we want to push an `OutCoercion` into the -argument. But the argument may or may not have been simplified (see Note [StaticEnv]) -so we definitely can't just wrap the cast around the argument. Instead we store it -in the `sc_cast` field -- this is the whole reason for the `sc_cast` field. +argument. But the argument may or may not have been simplified (see Note [The +argument of ApplyToVal]): + +* If it has been simplified, it is (DoneEx arg' _), and we can simply wrap the + cast around `arg'`. + +* If it has not, it is (ContEx env arg mco), and we definitely can't just wrap + the (Out)cast around the InExpr `arg`. Instead we compose it with `mco` -- + this is the whole reason for the MOutCoercion field of `ContEx`. + +All this is done by `mkCloCastMCo`. We deal with that pending cast mainly in `simplArg`. But we /also/ sometimes want to substitute that argument for a lambda-binder, in -`preInlineUnconditionally`. So we also have to put that pending cast into -`ContEx`; hence the MOutCoercion field of `ContEx`. Then we deal with it -appropriately when /applying/ the substitution in `simplInId`. +`preInlineBetaUnconditionally`; and since the substitution maps an Id to a SimplClo, +the pending cast comes along for free. Then we deal with it appropriately when +/applying/ the substitution in `simplInId`. + +Note [Optimising reflexivity] +~~~~~~~~~~~~~~~~~~~~~~~~~~~~~ +It's important (for compiler performance) to get rid of reflexivity as soon +as it appears. See #11735, #14737, and #15019. + +In particular, we want to behave well on + + * e |> co1 |> co2 + where the two happen to cancel out entirely. That is quite common; + e.g. a newtype wrapping and unwrapping cancel. + + + * (f |> co) @t1 @t2 ... @tn x1 .. xm + Here we will use pushCoTyArg and pushCoValArg successively, which + build up SelCo stacks. Silly to do that if co is reflexive. + +However, we don't want to call isReflexiveCo too much, because it uses +type equality which is expensive on big types (#14737 comment:7). + +A good compromise (determined experimentally) seems to be to call +isReflexiveCo + * when composing casts, and + * at the end + +In investigating this I saw missed opportunities for on-the-fly +coercion shrinkage. See #15090. + +Note [Avoid re-simplifying coercions] +~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~ +In some benchmarks (with deeply nested cases) we successively push +casts onto the SimplCont. We don't want to call the coercion optimiser +on each successive composition -- that's at least quadratic. So: + +* The CastIt constructor in SimplCont has a `sc_opt :: Bool` flag to + record whether the coercion optimiser has been applied to the coercion. + +* In `simplCast`, when we see (Cast e co), we simplify `co` to get + an OutCoercion, and built a CastIt with sc_opt=True. + + Actually not quite: if we are simplifying the result of inlining an + unfolding (seInlineDepth > 0), then instead of /optimising/ it again, + just /substitute/ which is cheaper. See `simplCoercion`. + +* In `pushCast` if we combine this new coercion with an existing one, + we build a CastIt for (co1 ; co2) with sc_opt=False. + +* When unpacking a CastIt, in `rebuild`, we optimise the (presumably + composed) coercion if sc_opt=False; this is done by `optOutCoercion`. + +* When duplicating a continuation in `mkDupableContWithDmds`, before + duplicating a CastIt, optimise the coercion. Otherwise we'll end up + optimising it separately in the duplicate copies. + +* See also Note [The MOutCoercion field of ContEx] -} optOutCoercion :: SimplEnvIS -> OutCoercion -> Bool -> OutCoercion --- See Note [Avoid re-simplifying coercions] in GHC.Core.Opt.Simplify.Iteration +-- See Note [Avoid re-simplifying coercions] optOutCoercion env co already_optimised | already_optimised = co -- Ditto | otherwise = optCoercion opts empty_subst co @@ -863,7 +964,8 @@ pushCastMCo env (MCo co) cont = pushCast env co cont pushCast :: SimplEnv -> OutCoercion -> SimplCont -> SimplCont pushCast env co cont - = go co True cont + | isReflCo co = cont -- See Note [Optimising reflexivity] + | otherwise = go co True cont where -- ToDo: pushCast Refl (ApplylToVal arg1 (ApplyToVal arg2 ...)) @@ -872,7 +974,7 @@ pushCast env co cont go co1 _ (CastIt { sc_co = co2, sc_cont = cont }) -- See Note [Optimising reflexivity] in GHC.Core.Opt.Simplify.Iteration = go (mkTransCo co1 co2) False cont -- False: (mkTransCo co1 co2) is not fully optimised - -- See Note [Avoid re-simplifying coercions] in GHC.Core.Opt.Simplify.Iteration + -- See Note [Avoid re-simplifying coercions] go co co_is_opt (ApplyToTy { sc_arg_ty = arg_ty, sc_cont = tail }) | Just (tyL, arg_ty', m_co') <- pushCoTyArg co arg_ty @@ -887,21 +989,17 @@ pushCast env co cont -- where co :: (s1->s2) ~ (t1->t2) -- co1 :: t1 ~ s1 -- co2 :: s2 ~ t2 - go co co_is_opt cont@(ApplyToVal { sc_arg = arg, sc_env = arg_se - , sc_cast = arg_mco, sc_cont = tail }) + go co co_is_opt cont@(ApplyToVal { sc_arg = arg, sc_cont = tail }) | not co_is_opt = -- pushCoValArg duplicates the coercion, so optimise first go (optOutCoercion (zapSubstEnv env) co co_is_opt) True cont | Just (tyL, m_co1, m_co2) <- pushCoValArg co = {-#SCC "addCoerce-pushCoValArg" #-} - -- Dealing with m_co1 is the entire reason for the sc_cast field - -- of ApplyToVal; see Note [The sc_cast field of ApplyToVal] - ApplyToVal { sc_arg = arg - , sc_env = arg_se - , sc_cast = arg_mco `mkTransMCo` m_co1 - , sc_cont = go_mco m_co2 True tail - , sc_hole_ty = tyL } + -- See Note [The MOutCoercion field of ContEx] + cont { sc_arg = mkCloCastMCo arg m_co1 + , sc_cont = go_mco m_co2 True tail + , sc_hole_ty = tyL } go co co_is_opt cont | isReflCo co = cont -- Having this at the end makes a huge @@ -915,6 +1013,13 @@ pushCast env co cont go_mco MRefl _ cont = cont go_mco (MCo co) opt cont = go co opt cont +mkCloCastMCo :: SimplClo -> MOutCoercion -> SimplClo +-- See Note [The MOutCoercion field of ContEx] +mkCloCastMCo clo MRefl = clo +mkCloCastMCo (DoneId v) (MCo co) = DoneEx (mkCast (Var v) co) NotJoinPoint +mkCloCastMCo (DoneEx e _) (MCo co) = DoneEx (mkCast e co) NotJoinPoint +mkCloCastMCo (ContEx se e mco) (MCo co) = ContEx se e (mco `mkTransMCo` MCo co) + {- ************************************************************************ @@ -1228,19 +1333,17 @@ Wrinkles: -} -interestingArg :: SimplEnv -> StaticEnv -> CoreExpr -> ArgSummary +interestingArg :: SimplEnv -> SimplClo -> ArgSummary -- See Note [Interesting arguments] -interestingArg env se e - = case se of - Simplified {} -> go env 0 e - UnSimplified static_env -> go (static_env `setInScopeFromE` env) 0 e +interestingArg env clo + = go_clo env 0 clo where + go_clo _ n (DoneId v) = go_var n v + go_clo env n (DoneEx e _) = go (zapSubstEnv env) n e + go_clo env n (ContEx se e _) = go (se `setInScopeFromE` env) n e + -- n is # value args to which the expression is applied - go env n (Var v) - = case substId env v of - DoneId v' -> go_var n v' - DoneEx e _ -> go (zapSubstEnv env) n e - ContEx se e _mco -> go (se `setInScopeFromE` env) n e + go env n (Var v) = go_clo env n (substId env v) go _ _ (Lit l) | isLitRubbish l = NonTrivArg -- See (IA3) in Note [Interesting arguments] @@ -1739,15 +1842,15 @@ is a term (not a coercion) so we can't necessarily inline the latter in the former. -} -preInlineUnconditionally +preInlineLetUnconditionally :: SimplEnv -> TopLevelFlag -> InId - -> StaticEnv -> CoreExpr -> MOutCoercion -- The argument + -> InExpr -> SimplEnv -- These two go together -> Maybe SimplEnv -- Returned env has extended substitution -- Precondition: rhs satisfies the let-can-float invariant -- See Note [Core let-can-float invariant] in GHC.Core -- 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_se rhs rhs_mco +preInlineLetUnconditionally env top_lvl bndr rhs rhs_env | not pre_inline_unconditionally = Nothing | not active = Nothing | isTopLevel top_lvl && isDeadEndId bndr = Nothing -- Note [Top-level bottoming Ids] @@ -1759,26 +1862,15 @@ preInlineUnconditionally env top_lvl bndr rhs_se rhs rhs_mco -- See Note [Stable unfoldings and preInlineUnconditionally] | not (isInlinePragma inline_prag) - , Just inl <- maybeUnfoldingTemplate unf = assertPpr (isReflMCo rhs_mco) (ppr bndr) $ - Just $! (extend_subst_with inl) + , Just inl <- maybeUnfoldingTemplate unf = Just $! (extend_subst_with inl) | otherwise = Nothing where unf = idUnfolding bndr - -- If the rhs is /not/ already simplified, extend the envt with ContEx, which captures - -- the the lexical environment for us to restore in `simplInId`. - -- If the rhs /is/ already simplified, then extend the envt with DoneEx; - -- That makes `simplInId` call `simplOutExpr` which avoids re-simplifying - -- the RHS. - -- See Note [Avoid repeated simplification] in GHC.Core.Opt.Simplify.Iteration - extend_subst_with inl_rhs - = extendIdSubst env bndr $! - case rhs_se of - Simplified _ -> case rhs_mco of - MRefl -> DoneEx inl_rhs NotJoinPoint -- Common case - MCo co -> DoneEx (mkCast inl_rhs co) NotJoinPoint - UnSimplified rhs_env -> ContEx rhs_env inl_rhs rhs_mco + -- The rhs is not yet simplified, so extend the envt with ContEx, which + -- captures the lexical environment for us to restore in `simplInId`. + extend_subst_with inl_rhs = extendIdSubst env bndr $! ContEx rhs_env inl_rhs MRefl one_occ IAmDead = True -- Happens in ((\x.1) v) one_occ OneOcc{ occ_n_br = 1 @@ -1794,39 +1886,6 @@ preInlineUnconditionally env top_lvl bndr rhs_se rhs rhs_mco -- See Note [pre/postInlineUnconditionally in gentle mode] inline_prag = idInlinePragma bndr --- Be very careful before inlining inside a lambda, because (a) we must not --- invalidate occurrence information, and (b) we want to avoid pushing a --- single allocation (here) into multiple allocations (inside lambda). --- Inlining a *function* with a single *saturated* call would be ok, mind you. --- || (if is_cheap && not (canInlineInLam rhs) then pprTrace "preinline" (ppr bndr <+> ppr rhs) ok else ok) --- where --- is_cheap = exprIsCheap rhs --- ok = is_cheap && int_cxt - - -- int_cxt The context isn't totally boring - -- E.g. let f = \ab.BIG in \y. map f xs - -- Don't want to substitute for f, because then we allocate - -- its closure every time the \y is called - -- But: let f = \ab.BIG in \y. map (f y) xs - -- Now we do want to substitute for f, even though it's not - -- saturated, because we're going to allocate a closure for - -- (f y) every time round the loop anyhow. - - -- canInlineInLam => free vars of rhs are (Once in_lam) or Many, - -- so substituting rhs inside a lambda doesn't change the occ info. - -- Sadly, not quite the same as exprIsHNF. - canInlineInLam (Lit _) = True - canInlineInLam (Cast e _) = canInlineInLam e - canInlineInLam (Lam b e) = isRuntimeVar b || canInlineInLam e - canInlineInLam (Tick t e) = not (tickishIsCode t) && canInlineInLam e - canInlineInLam (Var v) = case idOccInfo v of - OneOcc { occ_in_lam = IsInsideLam } -> True - ManyOccs {} -> True - _ -> False - canInlineInLam _ = False - -- not ticks. Counting ticks cannot be duplicated, and non-counting - -- ticks around a Lam will disappear anyway. - early_phase = case sePhase env of SimplPhase p -> p /= FinalPhase @@ -1857,6 +1916,97 @@ preInlineUnconditionally env top_lvl bndr rhs_se rhs rhs_mco -- (Nor can we check for `exprIsExpandable rhs`, because that needs to look -- at the non-existent unfolding for the `I# 2#` which is also floated out.) +preInlineBetaUnconditionally + :: SimplEnv -> Levity -> InId + -> SimplClo -- The argument + -> Maybe SimplEnv -- Returned env has extended substitution +-- Like preInlineLetUnconditionally, but for a beta-redex (\bndr. body) arg +-- The argument may or may not be already simplified (DoneEx or ContEx) +-- +-- The binder is a lambda binder and so lacks most IdInfo; +-- see Note [Core binder IdInfo invariants] +-- +-- Compared to preInlineLetUnconditionally we omit some checks: +-- * The binder is never top-level, so no need for the +-- Note [Top-level bottoming Ids] check, nor for `early_phase` +-- * A lambda binder is never a join point, so no need for the +-- Note [Do not inline exit join points] check +-- * A lambda binder never has an inline pragma, a stable unfolding, or RULES +-- (see `lamBndrInfoOK`), so no need to check activation, nor for +-- Note [Stable unfoldings and preInlineUnconditionally] +-- +-- And we add one extra one +-- * Check the let-can-float invariant, and don't inline if not + +preInlineBetaUnconditionally env levity bndr arg + | assertPpr (lamBndrInfoOK bndr) (ppr bndr) $ + not pre_inline_unconditionally = Nothing + | isCoVar bndr = Nothing -- Note [Do not inline CoVars unconditionally] + | not (one_occ (idOccInfo bndr)) = Nothing + | needs_case_binding = Nothing -- Enforce the let-can-float invariant + | otherwise = Just $! extendIdSubst env bndr arg + -- If the arg is not yet simplified, it is a ContEx, which captures the + -- lexical environment for us to restore in `simplInId`. + -- If the arg is already simplified, then it is a DoneEx; + -- That makes `simplInId` call `simplOutExpr` which avoids re-simplifying + -- the arg. + -- See Note [Avoid repeated simplification] in GHC.Core.Opt.Simplify.Iteration + where + pre_inline_unconditionally = sePreInline env + + needs_case_binding = needsCaseBindingL levity rhs + -- Ok to test an InExpr or OutExpr in needsCaseBindingL because + -- exprOkForSpeculation is stable under simplification + + rhs :: CoreExpr -- Can be InExpr or OutExpr, but here it does not matter + rhs = case arg of + ContEx _ e _ -> e -- InExpr + DoneEx e _ -> e -- OutExpr + DoneId v -> Var v -- OutExpr + + one_occ IAmDead = True -- Happens in ((\x.1) v) + one_occ OneOcc{ occ_n_br = 1 + , occ_in_lam = NotInsideLam } = True + one_occ OneOcc{ occ_n_br = 1 + , occ_in_lam = IsInsideLam + , occ_int_cxt = IsInteresting } = canInlineInLam rhs + one_occ _ = False + + +canInlineInLam :: CoreExpr -> Bool +-- Be very careful before inlining inside a lambda, because (a) we must not +-- invalidate occurrence information, and (b) we want to avoid pushing a +-- single allocation (here) into multiple allocations (inside lambda). +-- Inlining a *function* with a single *saturated* call would be ok, mind you. +-- || (if is_cheap && not (canInlineInLam rhs) then pprTrace "preinline" (ppr bndr <+> ppr rhs) ok else ok) +-- where +-- is_cheap = exprIsCheap rhs +-- ok = is_cheap && int_cxt + + -- int_cxt The context isn't totally boring + -- E.g. let f = \ab.BIG in \y. map f xs + -- Don't want to substitute for f, because then we allocate + -- its closure every time the \y is called + -- But: let f = \ab.BIG in \y. map (f y) xs + -- Now we do want to substitute for f, even though it's not + -- saturated, because we're going to allocate a closure for + -- (f y) every time round the loop anyhow. + + -- canInlineInLam => free vars of rhs are (Once in_lam) or Many, + -- so substituting rhs inside a lambda doesn't change the occ info. + -- Sadly, not quite the same as exprIsHNF. +canInlineInLam (Lit _) = True +canInlineInLam (Cast e _) = canInlineInLam e +canInlineInLam (Lam b e) = isRuntimeVar b || canInlineInLam e +canInlineInLam (Tick t e) = not (tickishIsCode t) && canInlineInLam e +canInlineInLam (Var v) = case idOccInfo v of + OneOcc { occ_in_lam = IsInsideLam } -> True + ManyOccs {} -> True + _ -> False +canInlineInLam _ = False + -- not ticks. Counting ticks cannot be duplicated, and non-counting + -- ticks around a Lam will disappear anyway. + {- ************************************************************************ * * ===================================== testsuite/tests/simplCore/should_compile/T15445.stderr ===================================== @@ -4,6 +4,7 @@ Rule fired: Int# -> Integer -> Int# (GHC.Internal.Bignum.Integer) Rule fired: USPEC plusTwoRec @Int (T15445a) Rule fired: USPEC $fShowList @Int (GHC.Internal.Show) Rule fired: Class op >> (BUILTIN) +Rule fired: Class op show (BUILTIN) Rule fired: USPEC plusTwoRec @Int (T15445a) Rule fired: Class op enumFromTo (BUILTIN) Rule fired: eftInt (GHC.Internal.Enum) @@ -11,7 +12,6 @@ Rule fired: Class op show (BUILTIN) Rule fired: USPEC plusTwoRec @Int (T15445a) Rule fired: Class op enumFromTo (BUILTIN) Rule fired: eftInt (GHC.Internal.Enum) -Rule fired: Class op show (BUILTIN) Rule fired: eftIntList (GHC.Internal.Enum) Rule fired: ># (BUILTIN) Rule fired: ==# (BUILTIN) ===================================== testsuite/tests/simplCore/should_compile/T27962.hs ===================================== @@ -0,0 +1,16 @@ +{-# LANGUAGE MagicHash #-} + +module T27962 where + +import GHC.Exts + +newtype N = MkN Int + +-- After inlining myRun, we get (runRW# @LiftedRep @Int |> co) (\_ -> ...) +-- and the simplifier pushes co into the argument of runRW#. +-- #27962: the simplifier dropped that cast, yielding ill-typed Core +myRun :: (State# RealWorld -> N) -> N +myRun = coerce (runRW# :: (State# RealWorld -> Int) -> Int) +{-# INLINE myRun #-} + +foo x = myRun (\_ -> MkN (x+1)) ===================================== testsuite/tests/simplCore/should_compile/T27963.hs ===================================== @@ -0,0 +1,23 @@ +{-# OPTIONS_GHC -Wno-inline-rule-shadowing #-} + +module T27963 where + +-- This test is pretty delicate because it relies on a function +-- that has BOTH a rule AND an INLINE pragma +-- +-- See #27963 for some discussion +-- +-- Still, it should (just) work + +import GHC.Exts + +newtype N = MkN Int + +f x = x +{-# INLINE f #-} +{-# RULES "f/42" forall x. f x = 42::Int #-} + +-- The rule "f/42" should fire in both h1 and h2 +h1,h2 :: N -> Int +h1 n = f (coerce n) + 0 +h2 n = (coerce f) n + 0 -- #27963: the rule did not fire here ===================================== testsuite/tests/simplCore/should_compile/T27963.stderr ===================================== @@ -0,0 +1,2 @@ +Rule fired: f/42 (T27963) +Rule fired: f/42 (T27963) ===================================== testsuite/tests/simplCore/should_compile/all.T ===================================== @@ -633,4 +633,3 @@ test('T27962', normal, compile, ['']) test('T27962a', [extra_files(['T27962.hs'])], multimod_compile, ['T27962', '-v0 -O']) test('T27963', [grep_errmsg(r'f/42')], compile, ['-O -ddump-rule-firings']) test('T27965', normal, compile, ['']) - View it on GitLab: https://gitlab.haskell.org/ghc/ghc/-/commit/24d1ab3bb660abb34da658f760983237... -- View it on GitLab: https://gitlab.haskell.org/ghc/ghc/-/commit/24d1ab3bb660abb34da658f760983237... You're receiving this email because of your account on gitlab.haskell.org. Manage all notifications: https://gitlab.haskell.org/-/profile/notifications | Help: https://gitlab.haskell.org/help