Simon Peyton Jones pushed to branch wip/26543 at Glasgow Haskell Compiler / GHC Commits: fa93d8c6 by Simon Peyton Jones at 2025-12-04T17:47:15+00:00 Introduce SimplClo and use it [skip ci] ...especially in ApplyToVal - - - - - 4 changed files: - compiler/GHC/Core/Opt/Simplify/Env.hs - compiler/GHC/Core/Opt/Simplify/Iteration.hs - compiler/GHC/Core/Opt/Simplify/Utils.hs - compiler/GHC/Core/TyCo/Rep.hs Changes: ===================================== compiler/GHC/Core/Opt/Simplify/Env.hs ===================================== @@ -11,7 +11,7 @@ module GHC.Core.Opt.Simplify.Env ( SimplMode(..), updMode, smPlatform, -- * Environments - SimplEnv(..), pprSimplEnv, -- Temp not abstract + SimplEnv(..), StaticEnv, pprSimplEnv, -- Temp not abstract SimplPhase(..), isActive, seArityOpts, seCaseCase, seCaseFolding, seCaseMerge, seCastSwizzle, seDoEtaReduction, seEtaExpand, seFloatEnable, seInline, seNames, @@ -28,13 +28,13 @@ module GHC.Core.Opt.Simplify.Env ( SimplEnvIS, checkSimplEnvIS, pprBadSimplEnvIS, -- * Substitution results - SimplSR(..), mkContEx, substId, lookupRecBndr, + SimplClo(..), mkContEx, substId, lookupRecBndr, -- * Simplifying 'Id' binders simplNonRecBndr, simplNonRecJoinBndr, simplRecBndrs, simplRecJoinBndrs, simplBinder, simplBinders, substTy, substTyVar, getFullSubst, getTCvSubst, - substCo, substCoVar, + substCo, substCoVar, simplCloExpr, simplCloCoercion_maybe, -- * Floats SimplFloats(..), emptyFloats, isEmptyFloats, mkRecFloats, @@ -60,8 +60,9 @@ import GHC.Core.Opt.Arity ( ArityOpts(..) ) import GHC.Core.Opt.Simplify.Monad import GHC.Core.Rules.Config ( RuleOpts(..) ) import GHC.Core +import GHC.Core.Ppr 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 ) @@ -209,6 +210,8 @@ type SimplEnvIS = SimplEnv -- Invariant: the substitution is empty -- We want this SimplEnv for its InScopeSet and flags +type StaticEnv = SimplEnv -- Just the static part is relevant + checkSimplEnvIS :: SimplEnvIS -> Bool -- Check the invariant for SimplEnvIS checkSimplEnvIS (SimplEnv { seIdSubst = id_env, seTvSubst = tv_env, seCvSubst = cv_env }) @@ -459,41 +462,46 @@ 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 +-- Roughly: either an (InExpr, StaticEnv) pair for an +-- as-yet-unsimplified expression +-- or an OutExpr, for an already-simplified one + +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 -- and v is a join-point of arity a -- <=> x is a join-point of arity a - | ContEx TvSubstEnv -- A suspended substitution - CvSubstEnv - SimplIdSubst + | ContEx StaticEnv InExpr - -- If x :-> ContEx tv cv id e is in the SimplISubst - -- then replace occurrences of x by (subst (tv,cv,id) e) + MOutCoercion -- An /optimised/ OutCoercion + -- If x :-> ContEx subst e co is in the SimplISubst + -- then replace occurrences of x by ((substExpr subst e) |> co) -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 + ppr (DoneEx e mj) = text "DoneEx" <> pp_mj<> braces (ppr e) where pp_mj = case mj of NotJoinPoint -> empty JoinPoint n -> parens (int n) - ppr (ContEx _tv _cv _id e) = vcat [text "ContEx" <+> ppr e {-, - ppr (filter_env tv), ppr (filter_env id) -}] + ppr (ContEx _se e mco) + = text "ContEx" <> vcat [ pprParendExpr e + , case mco of + MRefl -> empty + MCo co -> text "|>" <+> pprOptCo co ] -- where -- fvs = exprFreeVars e -- filter_env env = filterVarEnv_Directly keep env @@ -627,7 +635,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 } @@ -725,8 +733,8 @@ zapSubstEnv env@(SimplEnv { seInlineDepth = n }) setSubstEnv :: SimplEnv -> TvSubstEnv -> CvSubstEnv -> SimplIdSubst -> SimplEnv setSubstEnv env tvs cvs ids = env { seTvSubst = tvs, seCvSubst = cvs, seIdSubst = ids } -mkContEx :: SimplEnv -> InExpr -> SimplSR -mkContEx (SimplEnv { seTvSubst = tvs, seCvSubst = cvs, seIdSubst = ids }) e = ContEx tvs cvs ids e +mkContEx :: SimplEnv -> InExpr -> SimplClo +mkContEx env e = ContEx env e MRefl {- ************************************************************************ @@ -1011,7 +1019,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] @@ -1343,17 +1351,29 @@ 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 }) - = mk_full_subst in_scope tv_env cv_env id_env - -mk_full_subst :: InScopeSet -> TvSubstEnv -> CvSubstEnv -> SimplIdSubst -> Subst -mk_full_subst in_scope tv_env cv_env id_env - = mkSubst in_scope (mapVarEnv to_expr id_env) tv_env cv_env - where - to_expr :: SimplSR -> CoreExpr - -- A tiresome impedence-matcher - to_expr (DoneEx e _) = e - to_expr (DoneId v) = Var v - to_expr (ContEx tvs cvs ids e) = GHC.Core.Subst.substExprSC (mk_full_subst in_scope tvs cvs ids) e + = mkSubst in_scope (mapVarEnv (simplCloExpr in_scope) id_env) tv_env cv_env + +simplCloExpr :: InScopeSet -> SimplClo -> OutExpr +simplCloExpr _ (DoneEx e _) = e +simplCloExpr _ (DoneId v) = Var v +simplCloExpr in_scope (ContEx se e mco) = mkCastMCo e' mco + where + e' = GHC.Core.Subst.substExpr (getFullSubst in_scope se) e + -- Make sure we apply the static environment `sc_env` 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 + +simplCloCoercion_maybe :: SimplClo -> Maybe OutCoercion +-- If the closure is just a coercion, give it to me +simplCloCoercion_maybe clo + = case clo of + DoneEx (Coercion co) _ -> Just co + ContEx se (Coercion co) MRefl -> Just (substCo se co) + -- Do we ever cast a coercion?? + DoneId {} -> Nothing -- Coercion variables never occur naked + _ -> Nothing substTy :: HasDebugCallStack => SimplEnv -> Type -> Type substTy env ty = Type.substTy (getTCvSubst env) ty ===================================== compiler/GHC/Core/Opt/Simplify/Iteration.hs ===================================== @@ -278,8 +278,8 @@ simplRecOrTopPair :: SimplEnv -> SimplM (SimplFloats, SimplEnv) simplRecOrTopPair env bind_cxt old_bndr new_bndr rhs - | Just env' <- preInlineUnconditionally env (bindContextLevel bind_cxt) - old_bndr rhs env + | 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) @@ -1211,7 +1211,7 @@ 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 = env + ApplyToVal { sc_arg = mkContEx env arg , sc_hole_ty = substTy env (exprType fun) , sc_dup = NoDup, sc_cont = cont } @@ -1249,7 +1249,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 rhs env + | 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) $ @@ -1266,7 +1266,7 @@ simplExprF1 env (Let (NonRec bndr rhs) body) cont | otherwise = {-#SCC "simplNonRecE" #-} - simplNonRecE env FromLet bndr (rhs, env) body cont + simplNonRecE env FromLet bndr (mkContEx env rhs) body cont {- Note [Avoiding space leaks in OutType] ~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~ @@ -1549,10 +1549,9 @@ 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 = se, sc_dup = dup_flag - , sc_cont = cont, sc_hole_ty = fun_ty } + ApplyToVal { sc_arg = arg_clo, sc_cont = cont, sc_hole_ty = fun_ty } -- See Note [Avoid redundant simplification] - -> do { (_, _, arg') <- simplLazyArg env dup_flag fun_ty Nothing se arg + -> do { arg' <- simplClo env fun_ty Nothing arg_clo ; rebuild_go env (App expr arg') cont } completeBindX :: SimplEnv @@ -1709,7 +1708,7 @@ simplCast env body co0 cont0 -- where co :: (s1->s2) ~ (t1->t2) -- co1 :: t1 ~ s1 -- co2 :: s2 ~ t2 - addCoerce co co_is_opt cont@(ApplyToVal { sc_arg = arg, sc_env = arg_se + addCoerce co co_is_opt cont@(ApplyToVal { sc_arg = arg_clo , sc_dup = dup, sc_cont = tail , sc_hole_ty = fun_ty }) | not co_is_opt -- pushCoValArg duplicates the coercion, so optimise first @@ -1724,15 +1723,13 @@ simplCast env body co0 cont0 -- See Note [Avoiding simplifying repeatedly] MCo co1 -> - do { (dup', arg_se', arg') <- simplLazyArg env dup fun_ty Nothing arg_se arg - -- When we build the ApplyTo we can't mix the OutCoercion - -- 'co' with the InExpr 'arg', so we simplify - -- to make it all consistent. It's a bit messy. - -- But it isn't a common case. - -- Example of use: #995 - ; return (ApplyToVal { sc_arg = mkCast arg' co1 - , sc_env = arg_se' - , sc_dup = dup' + do { let arg_clo' = case arg_clo of + DoneId v -> DoneEx (Cast (Var v) co1) NotJoinPoint + DoneEx e _jp -> DoneEx (Cast e co1) NotJoinPoint + ContEx se e mco -> ContEx se e (mkTransMCoL mco co1) + + ; return (ApplyToVal { sc_arg = arg_clo' + , sc_dup = dup , sc_cont = tail' , sc_hole_ty = coercionLKind co }) } } } @@ -1742,28 +1739,25 @@ simplCast env body co0 cont0 -- See Note [Optimising reflexivity] | otherwise = return (CastIt { sc_co = co, sc_opt = co_is_opt, sc_cont = cont }) -simplLazyArg :: SimplEnvIS -- ^ Used only for its InScopeSet - -> DupFlag - -> OutType -- ^ Type of the function applied to this arg - -> Maybe ArgInfo -- ^ Just <=> This arg `ai` occurs in an app - -- `f a1 ... an` where we have ArgInfo on - -- how `f` uses `ai`, affecting the Stop - -- continuation passed to 'simplExprC' - -> StaticEnv -> CoreExpr -- ^ Expression with its static envt - -> SimplM (DupFlag, StaticEnv, OutExpr) -simplLazyArg env dup_flag fun_ty mb_arg_info arg_env arg - | isSimplified dup_flag - = return (dup_flag, arg_env, arg) - | otherwise - = do { let arg_env' = arg_env `setInScopeFromE` env - ; let arg_ty = funArgTy fun_ty - ; let stop = case mb_arg_info of - Nothing -> mkBoringStop arg_ty - Just ai -> mkLazyArgStop arg_ty ai - ; arg' <- simplExprC arg_env' arg stop - ; return (Simplified, zapSubstEnv arg_env', arg') } - -- Return a StaticEnv that includes the in-scope set from 'env', - -- because arg' may well mention those variables (#20639) +simplClo :: SimplEnvIS -- ^ Used only for its InScopeSet + -> OutType -- ^ Type of the function applied to this arg + -> Maybe ArgInfo -- ^ Just <=> This arg `ai` occurs in an app + -- `f a1 ... an` where we have ArgInfo on + -- how `f` uses `ai`, affecting the Stop + -- continuation passed to 'simplExprC' + -> SimplClo + -> SimplM OutExpr +simplClo env fun_ty mb_arg_info (ContEx arg_se arg mco) + = simplExprC arg_env arg stop + where + arg_env = arg_se `setInScopeFromE` env + arg_ty = funArgTy fun_ty + stop = case mb_arg_info of + Nothing -> mkBoringStop arg_ty + Just ai -> mkLazyArgStop arg_ty ai + +simplClo _ _ _ (DoneEx e _) = return e +simplClo _ _ _ (DoneId v) = return (Var v) {- ************************************************************************ @@ -1797,16 +1791,15 @@ simpl_lam env bndr body (ApplyToTy { sc_arg_ty = arg_ty, sc_cont = cont }) ; simplLam (extendTvSubst env bndr arg_ty) body cont } -- Coercion beta-reduction -simpl_lam env bndr body (ApplyToVal { sc_arg = Coercion arg_co, sc_env = arg_se - , sc_cont = cont }) +simpl_lam env bndr body (ApplyToVal { sc_arg = arg_clo, sc_cont = cont }) + | Just out_co <- simplCloCoercion_maybe arg_clo = assertPpr (isCoVar bndr) (ppr bndr) $ do { tick (BetaReduction bndr) - ; let arg_co' = substCo (arg_se `setInScopeFromE` env) arg_co - ; simplLam (extendCvSubst env bndr arg_co') body cont } + ; simplLam (extendCvSubst env bndr out_co) body cont } -- Value beta-reduction -- This works for /coercion/ lambdas too -simpl_lam env bndr body (ApplyToVal { sc_arg = arg, sc_env = arg_se +simpl_lam env bndr body (ApplyToVal { sc_arg = arg_clo , sc_cont = cont, sc_dup = dup , sc_hole_ty = fun_ty}) = do { tick (BetaReduction bndr) @@ -1823,24 +1816,13 @@ simpl_lam env bndr body (ApplyToVal { sc_arg = arg, sc_env = arg_se -- It's wrong to err in either direction -- But fun_ty is an OutType, so is fully substituted - ; if | Just env' <- preInlineUnconditionally env NotTopLevel bndr arg arg_se - , not (needsCaseBindingL arg_levity arg) - -- Ok to test arg::InExpr in needsCaseBinding because - -- exprOkForSpeculation is stable under simplification - , not ( isSimplified dup && -- See (SR2) in Note [Avoiding simplifying repeatedly] - not (exprIsTrivial arg) && - not (isDeadOcc (idOccInfo bndr)) ) + ; if | Just env' <- preInlineBetaUnconditionally env arg_levity bndr arg_clo -> do { simplTrace "SimplBindr:inline-uncond3" (ppr bndr) $ tick (PreInlineUnconditionally bndr) ; simplLam env' body cont } - | isSimplified dup -- Don't re-simplify if we've simplified it once - -- Including don't preInlineUnconditionally - -- See Note [Avoiding simplifying repeatedly] - -> completeBindX env from_what bndr arg body cont - | otherwise - -> simplNonRecE env from_what bndr (arg, arg_se) body cont } + -> simplNonRecE env from_what bndr arg_clo body cont } -- Discard a non-counting tick on a lambda. This may change the -- cost attribution slightly (moving the allocation of the @@ -1876,8 +1858,7 @@ simplNonRecE :: HasDebugCallStack -> FromWhat -> InId -- The binder, always an Id -- Never a join point - -- The static env for its unfolding (if any) is the first parameter - -> (InExpr, SimplEnv) -- Rhs of binding (or arg of lambda) + -> SimplClo -- Rhs of binding (or arg of lambda) -> InExpr -- Body of the let/lambda -> SimplCont -> SimplM (SimplFloats, OutExpr) @@ -1896,7 +1877,14 @@ simplNonRecE :: HasDebugCallStack -- from_what=FromLet => the RHS satisfies the let-can-float invariant -- Otherwise it may or may not satisfy it. -simplNonRecE env from_what bndr (rhs, rhs_se) body cont +simplNonRecE env from_what bndr (DoneEx rhs jp) body cont + = assertPpr (jp == NotJoinPoint) (ppr bndr) $ + completeBindX env from_what bndr rhs body cont + +simplNonRecE env from_what bndr (DoneId v) body cont + = completeBindX env from_what bndr (Var v) body cont + +simplNonRecE env from_what bndr (ContEx rhs_se rhs mco) body cont | assert (isId bndr && not (isJoinId bndr) ) $ is_strict_bind = -- Evaluate RHS strictly @@ -2237,10 +2225,10 @@ simplInVar env var | isCoVar var = return $! Coercion $! (substCoVar env var) | otherwise = case substId env var of - ContEx tvs cvs ids e -> let env' = setSubstEnv env tvs cvs ids - in simplExpr env' e - DoneId var1 -> return (Var var1) - DoneEx e _ -> return e + ContEx se e mco -> do { e' <- simplExpr (se `setInScopeFromE` env) e + ; return (mkCastMCo e' mco) } + DoneId var1 -> return (Var var1) + DoneEx e _ -> return e simplInId :: SimplEnv -> InId -> SimplCont -> SimplM (SimplFloats, OutExpr) simplInId env var cont @@ -2249,19 +2237,16 @@ simplInId env var cont = rebuild zapped_env (Var var) cont | otherwise = case substId env var of - ContEx tvs cvs ids e -> simplExprF env' e cont - -- Don't trimJoinCont; haven't already simplified e, + ContEx se e mco -> do { e' <- simplExprF (se `setInScopeFromE` env) e cont + ; return (mkCastMCo e' mco) } + -- Don't trimJoinCont; we haven't already simplified e, -- so the cont is not embodied in e - where - env' = setSubstEnv env tvs cvs ids - DoneId out_id -> simplOutId zapped_env out_id cont' - where - cont' = trimJoinCont out_id (idJoinPointHood out_id) cont + DoneId out_id -> simplOutId zapped_env out_id $ + trimJoinCont out_id (idJoinPointHood out_id) cont - DoneEx e mb_join -> simplExprF zapped_env e cont' - where - cont' = trimJoinCont var mb_join cont + DoneEx e mb_join -> simplExprF zapped_env e $ + trimJoinCont var mb_join cont where zapped_env = zapSubstEnv env -- See Note [zapSubstEnv] @@ -2277,8 +2262,8 @@ 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_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 arg_env = arg_se `setInScopeFromE` env @@ -2306,8 +2291,8 @@ simplOutId env fun cont _ -> do { s' <- newId (fsLit "s") ManyTy realWorldStatePrimTy ; let (m,_,_) = splitFunTy fun_ty env' = arg_env `addNewInScopeIds` [s'] - cont' = ApplyToVal { sc_dup = Simplified, sc_arg = Var s' - , sc_env = env', sc_cont = inner_cont + cont' = ApplyToVal { sc_dup = Dupable, sc_arg = DoneId s' + , sc_cont = inner_cont , sc_hole_ty = mkVisFunTy m realWorldStatePrimTy new_runrw_res_ty } -- cont' applies to s', then K ; body' <- simplExprC env' arg cont' @@ -2386,32 +2371,36 @@ 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 + (ApplyToVal { sc_arg = arg_clo , sc_dup = dup_flag, sc_hole_ty = fun_ty , sc_cont = cont }) - -- Argument is already simplified - | isSimplified dup_flag -- See Note [Avoid redundant simplification] - = rebuildCall env (addValArgTo fun_info arg fun_ty) cont - - -- Strict arguments - | isStrictArgInfo fun_info - , seCaseCase env -- Only when case-of-case is on. See GHC.Driver.Config.Core.Opt.Simplify - -- Note [Case-of-case and full laziness] - = -- pprTrace "Strict Arg" (ppr arg $$ ppr (seIdSubst env) $$ ppr (seInScope env)) $ - simplExprF (arg_se `setInScopeFromE` env) arg - (StrictArg { sc_fun = fun_info, sc_fun_ty = fun_ty - , sc_dup = Simplified - , sc_cont = cont }) + = case arg_clo of -- See Note [Avoid redundant simplification] + DoneId v -> rebuildCall env (addValArgTo fun_info (Var v) fun_ty) cont + DoneEx arg _ -> rebuildCall env (addValArgTo fun_info arg fun_ty) cont + ContEx arg_se in_arg mco + -- Strict arguments + | isStrictArgInfo fun_info + , seCaseCase env -- Only when case-of-case is on. See GHC.Driver.Config.Core.Opt.Simplify + -- Note [Case-of-case and full laziness] + -> simplExprF (arg_se `setInScopeFromE` env) in_arg + (add_cast mco $ + StrictArg { sc_fun = fun_info, sc_fun_ty = fun_ty + , sc_dup = NoDup, sc_cont = cont }) -- Note [Shadowing in the Simplifier] - -- Lazy arguments - | otherwise + -- Lazy arguments + | otherwise -- DO NOT float anything outside, hence simplExprC -- 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') <- simplLazyArg env dup_flag fun_ty (Just fun_info) arg_se arg - ; rebuildCall env (addValArgTo fun_info arg' fun_ty) cont } + -> do { arg' <- simplClo env fun_ty (Just fun_info) arg_clo + ; rebuildCall env (addValArgTo fun_info arg' fun_ty) cont } + + where + add_cast MRefl cont = cont + add_cast (MCo co) cont = CastIt { sc_co = co, sc_opt = True, sc_cont = cont } + ---------- No further useful info, revert to generic rebuild ------------ rebuildCall env (ArgInfo { ai_fun = fun, ai_args = rev_args, ai_rules = rules }) cont @@ -2436,7 +2425,7 @@ tryInlining env logger var cont = return Nothing where - (lone_variable, arg_infos, call_cont) = contArgs cont + (lone_variable, arg_infos, call_cont) = contArgs env cont interesting_cont = interestingCallContext env call_cont log_inlining doc @@ -2644,7 +2633,7 @@ tryRules env rules fn args --, text "Rule activation:" <+> ppr (ruleActivation rule) , text "Full arity:" <+> ppr (ruleArity rule) , text "Before:" <+> hang (ppr fn) 2 (sep (map ppr args)) - , text "After: " <+> pprCoreExpr rule_rhs ] + , text "After: " <+> mkApps (pprCoreExpr rule_rhs) (drop (ruleArity rule) args) ] | logHasDumpFlag logger Opt_D_dump_rule_firings = log_rule Opt_D_dump_rule_firings "Rule fired:" $ @@ -2713,8 +2702,8 @@ trySeqRules in_env scrut rhs cont , ValArg { as_arg = no_cast_scrut , as_dmd = seqDmd , as_hole_ty = res3_ty } ] - rule_cont = ApplyToVal { sc_dup = NoDup, sc_arg = rhs - , sc_env = in_env, sc_cont = cont + rule_cont = ApplyToVal { sc_dup = NoDup, sc_arg = mkContEx in_env rhs + , sc_cont = cont , sc_hole_ty = res4_ty } -- Lazily evaluated, so we don't do most of this @@ -3941,7 +3930,7 @@ mkDupableContWithDmds env dmds , sc_arg_ty = arg_ty, sc_hole_ty = hole_ty }) } mkDupableContWithDmds env dmds - (ApplyToVal { sc_arg = arg, sc_dup = dup, sc_env = se + (ApplyToVal { sc_arg = arg_clo, sc_dup = dup , sc_cont = cont, sc_hole_ty = hole_ty }) = -- e.g. [...hole...] (...arg...) -- ==> @@ -3951,16 +3940,11 @@ mkDupableContWithDmds env dmds do { let dmd:|cont_dmds = expectNonEmpty dmds ; (floats1, cont') <- mkDupableContWithDmds env cont_dmds cont ; let env' = env `setInScopeFromF` floats1 - ; (_, se', arg') <- simplLazyArg env' dup hole_ty Nothing se arg + ; arg' <- simplClo env' hole_ty Nothing arg_clo ; (let_floats2, arg'') <- makeTrivial env NotTopLevel dmd (fsLit "karg") arg' ; let all_floats = floats1 `addLetFloats` let_floats2 ; return ( all_floats - , ApplyToVal { sc_arg = arg'' - , sc_env = se' `setInScopeFromF` all_floats - -- Ensure that sc_env includes the free vars of - -- arg'' in its in-scope set, even if makeTrivial - -- has turned arg'' into a fresh variable - -- See Note [StaticEnv invariant] in GHC.Core.Opt.Simplify.Utils + , ApplyToVal { sc_arg = DoneEx arg'' NotJoinPoint , sc_dup = OkToDup, sc_cont = cont' , sc_hole_ty = hole_ty }) } ===================================== compiler/GHC/Core/Opt/Simplify/Utils.hs ===================================== @@ -12,7 +12,9 @@ module GHC.Core.Opt.Simplify.Utils ( tryEtaExpandRhs, wantEtaExpansion, -- Inlining, - preInlineUnconditionally, postInlineUnconditionally, + preInlineLetUnconditionally, + preInlineBetaUnconditionally, + postInlineUnconditionally, activeRule, getUnfoldingInRuleMatch, updModeForStableUnfoldings, updModeForRuleLHS, updModeForRuleRHS, @@ -173,8 +175,7 @@ data SimplCont { sc_dup :: DupFlag -- See Note [DupFlag invariants] , sc_hole_ty :: OutType -- Type of the function, presumably (forall a. blah) -- See Note [The hole type in ApplyToTy] - , sc_arg :: InExpr -- The argument, - , sc_env :: StaticEnv -- see Note [StaticEnv invariant] + , sc_arg :: SimplClo -- The argument , sc_cont :: SimplCont } | ApplyToTy -- (ApplyToTy ty K)[e] = K[ e ty ] @@ -216,23 +217,17 @@ data SimplCont CoreTickish -- Tick tickish <hole> SimplCont -type StaticEnv = SimplEnv -- Just the static part is relevant data FromWhat = FromLet | FromBeta Levity -- See Note [DupFlag invariants] data DupFlag = NoDup -- Unsimplified, might be big - | Simplified -- Simplified | OkToDup -- Simplified and small isSimplified :: DupFlag -> Bool isSimplified NoDup = False isSimplified _ = True -- Invariant: the subst-env is empty -perhapsSubstTy :: DupFlag -> StaticEnv -> Type -> Type -perhapsSubstTy dup env ty - | isSimplified dup = ty - | otherwise = substTy env ty {- Note [StaticEnv invariant] ~~~~~~~~~~~~~~~~~~~~~~~~~~~~~ @@ -255,21 +250,16 @@ the expression, and that (rightly) gives ASSERT failures if the InScopeSet isn't big enough. Note [DupFlag invariants] -~~~~~~~~~~~~~~~~~~~~~~~~~ +~~~~~~~~~~~~~~~~~~~~~~~~~~~~ In both ApplyToVal { se_dup = dup, se_env = env, se_cont = k} and Select { se_dup = dup, se_env = env, se_cont = k} -the following invariants hold - - (a) if dup = OkToDup, then continuation k is also ok-to-dup - (b) if dup = OkToDup or Simplified, the subst-env is empty, - or at least is always ignored; the payload is - already an OutThing +the following invariant holds + if dup = OkToDup, then continuation k is also ok-to-dup -} instance Outputable DupFlag where ppr OkToDup = text "ok" ppr NoDup = text "nodup" - ppr Simplified = text "simpl" instance Outputable SimplCont where ppr (Stop ty interesting eval_sd) @@ -284,7 +274,7 @@ instance Outputable SimplCont where = (text "ApplyToTy" <+> pprParendType ty) $$ ppr cont ppr (ApplyToVal { sc_arg = arg, sc_dup = dup, sc_cont = cont, sc_hole_ty = hole_ty }) = (hang (text "ApplyToVal" <+> ppr dup <+> text "hole-ty:" <+> pprParendType hole_ty) - 2 (pprParendExpr arg)) + 2 (ppr arg)) $$ ppr cont ppr (StrictBind { sc_bndr = b, sc_cont = cont }) = (text "StrictBind" <+> ppr b) $$ ppr cont @@ -392,9 +382,8 @@ pushSimplifiedArgs env args cont = foldr (pushSimplifiedArg env) cont args pushSimplifiedArg :: SimplEnv -> ArgSpec -> SimplCont -> SimplCont pushSimplifiedArg _env (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 } -pushSimplifiedArg env (ValArg { as_arg = arg, as_hole_ty = hole_ty }) cont - = ApplyToVal { sc_arg = arg, sc_env = env, sc_dup = Simplified - -- The SubstEnv will be ignored since sc_dup=Simplified +pushSimplifiedArg _env (ValArg { as_arg = arg, as_hole_ty = hole_ty }) cont + = ApplyToVal { sc_arg = DoneEx arg NotJoinPoint, sc_dup = NoDup , sc_hole_ty = hole_ty, sc_cont = cont } argSpecArg :: ArgSpec -> OutExpr @@ -475,14 +464,17 @@ contHoleType :: SimplCont -> OutType contHoleType (Stop ty _ _) = ty contHoleType (TickIt _ k) = contHoleType k contHoleType (CastIt { sc_co = co }) = coercionLKind co -contHoleType (StrictBind { sc_bndr = b, sc_dup = dup, sc_env = se }) - = perhapsSubstTy dup se (idType b) contHoleType (StrictArg { sc_fun_ty = ty }) = funArgTy ty contHoleType (ApplyToTy { sc_hole_ty = ty }) = ty -- See Note [The hole type in ApplyToTy] contHoleType (ApplyToVal { sc_hole_ty = ty }) = ty -- See Note [The hole type in ApplyToTy] -contHoleType (Select { sc_dup = d, sc_bndr = b, sc_env = se }) - = perhapsSubstTy d se (idType b) +contHoleType (StrictBind { sc_bndr = b, sc_dup = d, sc_env = se }) = perhapsSubstIdTy d se b +contHoleType (Select { sc_bndr = b, sc_dup = d, sc_env = se }) = perhapsSubstIdTy d se b +perhapsSubstIdTy :: DupFlag -> StaticEnv -> Id -> Type +perhapsSubstIdTy dup_flag env bndr + = case dup_flag of + OkToDup -> idType bndr -- The Id is an OutId + NoDup -> substTy env (idType bndr) -- The Id is an InId -- Computes the multiplicity scaling factor at the hole. That is, in (case [] of -- x ::(p) _ { … }) (respectively for arguments of functions), the scaling @@ -525,11 +517,11 @@ countValArgs (CastIt { sc_cont = cont }) = countValArgs cont countValArgs _ = 0 ------------------- -contArgs :: SimplCont -> (Bool, [ArgSummary], SimplCont) +contArgs :: SimplEnv -> SimplCont -> (Bool, [ArgSummary], SimplCont) -- Summarises value args, discards type args and coercions -- The returned continuation of the call is only used to -- answer questions like "are you interesting?" -contArgs cont +contArgs env cont | lone cont = (True, [], cont) | otherwise = go [] cont where @@ -538,34 +530,22 @@ contArgs cont lone (CastIt {}) = False -- stops it being "lone" lone _ = True - go args (ApplyToVal { sc_arg = arg, sc_env = se, sc_cont = k }) - = go (is_interesting arg se : args) k + go args (ApplyToVal { sc_arg = arg_clo, sc_cont = k }) + = go (interestingArg env arg_clo : args) k go args (ApplyToTy { sc_cont = k }) = go args k go args (CastIt { sc_cont = k }) = go args k go args k = (False, reverse args, k) - is_interesting arg se = interestingArg se arg - -- Do *not* use short-cutting substitution here - -- because we want to get as much IdInfo as possible - contOutArgs :: SimplEnv -> SimplCont -> [OutExpr] -- Get the leading arguments from the `SimplCont`, as /OutExprs/ contOutArgs env cont = go cont where - in_scope = seInScope env - go (ApplyToTy { sc_arg_ty = ty, sc_cont = cont }) = Type ty : go cont - go (ApplyToVal { sc_dup = dup, sc_arg = arg, sc_env = env, sc_cont = cont }) - | isSimplified dup = arg : go cont - | otherwise = GHC.Core.Subst.substExpr (getFullSubst in_scope env) arg : go cont - -- Make sure we apply the static environment `sc_env` 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 + go (ApplyToVal { sc_arg = arg_clo, sc_cont = cont }) + = simplCloExpr (seInScope env) arg_clo : go cont -- No more arguments go _ = [] @@ -993,16 +973,18 @@ rule for (*) (df d) can fire. To do this b) we say that a con-like argument (eg (df d)) is interesting -} -interestingArg :: SimplEnv -> CoreExpr -> ArgSummary +interestingArg :: SimplEnv -> SimplClo -> ArgSummary -- See Note [Interesting arguments] -interestingArg env e = go env 0 e +-- Do *not* use short-cutting substitution here +-- because we want to get as much IdInfo as possible +interestingArg env e = go_clo env 0 e where + go_clo _env 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 _co) = 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 tvs cvs ids e -> go (setSubstEnv env tvs cvs ids) n e + go env n (Var v) = go_clo env n (substId env v) go _ _ (Lit l) | isLitRubbish l = TrivArg -- Leads to unproductive inlining in WWRec, #20035 @@ -1490,7 +1472,38 @@ is a term (not a coercion) so we can't necessarily inline the latter in the former. -} -preInlineUnconditionally + +preInlineBetaUnconditionally + :: SimplEnv -> Levity -> InId -> SimplClo + -> Maybe SimplEnv -- Returned env has extended substitution +preInlineBetaUnconditionally env levity bndr clo + | not pre_inline_unconditionally = Nothing + | isCoVar bndr = Nothing -- Note [Do not inline CoVars unconditionally] + | not (one_occ (idOccInfo bndr)) = Nothing + | needs_case_binding levity = Nothing + | otherwise = Just $! extendIdSubst env bndr clo + where + pre_inline_unconditionally = sePreInline env + + 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 } + = case clo of + ContEx _ rhs _ -> canInlineInLam rhs + DoneId {} -> True + DoneEx rhs _ -> exprIsTrivial rhs + one_occ IAmDead = True -- Happens in ((\x.1) v) + one_occ _ = False + + -- NB: exprOkForSpeculation is stable under substitution + -- so we can apply it to an InExpr in the ContEx case + needs_case_binding Lifted = False + needs_case_binding Unlifted = case clo of + DoneId {} -> False + DoneEx e _ -> exprOkForSpeculation e + ContEx _ e _ -> exprOkForSpeculation e + +preInlineLetUnconditionally :: SimplEnv -> TopLevelFlag -> InId -> InExpr -> StaticEnv -- These two go together -> Maybe SimplEnv -- Returned env has extended substitution @@ -1498,7 +1511,7 @@ preInlineUnconditionally -- 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 rhs_env +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] @@ -1516,13 +1529,12 @@ preInlineUnconditionally env top_lvl bndr rhs rhs_env unf = idUnfolding bndr extend_subst_with inl_rhs = extendIdSubst env bndr $! (mkContEx rhs_env inl_rhs) + 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 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 _ = False pre_inline_unconditionally = sePreInline env active = isActive (sePhase env) @@ -1530,38 +1542,6 @@ preInlineUnconditionally env top_lvl bndr rhs rhs_env -- 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 @@ -1593,6 +1573,39 @@ preInlineUnconditionally env top_lvl bndr rhs rhs_env -- (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.) +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. + {- ************************************************************************ * * ===================================== compiler/GHC/Core/TyCo/Rep.hs ===================================== @@ -1022,7 +1022,7 @@ instance NFData CoSel where instance Outputable MCoercion where ppr MRefl = text "MRefl" - ppr (MCo co) = text "MCo" <+> ppr co + ppr (MCo co) = text "MCo" <> braces (ppr co) {- Note [Refl invariant] ~~~~~~~~~~~~~~~~~~~~~~~~ View it on GitLab: https://gitlab.haskell.org/ghc/ghc/-/commit/fa93d8c6338267c17ba6498d0b2da95e... -- View it on GitLab: https://gitlab.haskell.org/ghc/ghc/-/commit/fa93d8c6338267c17ba6498d0b2da95e... You're receiving this email because of your account on gitlab.haskell.org.