Simon Peyton Jones pushed to branch wip/T26989 at Glasgow Haskell Compiler / GHC Commits: e8ac16f2 by Simon Peyton Jones at 2026-04-26T01:17:47+01:00 Refactor the Simplifier's handling of DupFlag ...and how it deals with re-simplification of argumnets - - - - - 3 changed files: - compiler/GHC/Core/Opt/Simplify/Env.hs - compiler/GHC/Core/Opt/Simplify/Iteration.hs - compiler/GHC/Core/Opt/Simplify/Utils.hs Changes: ===================================== compiler/GHC/Core/Opt/Simplify/Env.hs ===================================== @@ -442,7 +442,7 @@ instance Outputable SimplFloats where , text "joins:" <+> ppr jf , text "in_scope:" <+> ppr is ]) -emptyFloats :: SimplEnv -> SimplFloats +emptyFloats :: SimplEnvIS -> SimplFloats emptyFloats env = SimplFloats { sfLetFloats = emptyLetFloats , sfJoinFloats = emptyJoinFloats ===================================== compiler/GHC/Core/Opt/Simplify/Iteration.hs ===================================== @@ -283,7 +283,7 @@ simplRecOrTopPair :: SimplEnv simplRecOrTopPair env bind_cxt old_bndr new_bndr rhs | Just env' <- preInlineUnconditionally env (bindContextLevel bind_cxt) - old_bndr NoDup rhs env + old_bndr rhs (UnSimplified env) = {-#SCC "simplRecOrTopPair-pre-inline-uncond" #-} simplTrace "SimplBindr:inline-uncond1" (ppr old_bndr) $ do { tick (PreInlineUnconditionally old_bndr) @@ -386,10 +386,9 @@ simplJoinBind is_rec cont (old_bndr, unf_se) (new_bndr, env) (rhs, rhs_se) ; completeBind (BC_Join is_rec cont) (old_bndr, unf_se) (new_bndr, rhs', env) } -------------------------- -simplAuxBind :: String - -> SimplEnv - -> InId -- Old binder; not a JoinId - -> OutExpr -- Simplified RHS +simplAuxBind :: (SimplAltFlag, SimplEnv) + -> Id -- Binder; not a JoinId + -> OutExpr -- Simplified RHS -> SimplM (SimplFloats, SimplEnv) -- A specialised variant of completeBindX used to construct non-recursive -- auxiliary bindings, notably in knownCon. @@ -399,7 +398,7 @@ simplAuxBind :: String -- -- Precondition: rhs satisfies the let-can-float invariant -simplAuxBind _str env bndr new_rhs +simplAuxBind (saf,env) bndr new_rhs | assertPpr (isId bndr && not (isJoinId bndr)) (ppr bndr) $ isDeadBinder bndr -- Not uncommon; e.g. case (a,b) of c { (p,q) -> p } = return (emptyFloats env, env) -- Here c is dead, and we avoid @@ -428,13 +427,14 @@ simplAuxBind _str env bndr new_rhs ; let rhs_floats = emptyFloats env `addLetFloats` anf_floats -- Simplify the binder and complete the binding - ; (env1, new_bndr) <- simplBinder (env `setInScopeFromF` rhs_floats) bndr + ; (env1, new_bndr) <- simplAltIdBinder (saf, env `setInScopeFromF` rhs_floats) bndr ; (bind_float, env2) <- completeBind (BC_Let NotTopLevel NonRecursive) - (bndr,env) (new_bndr, rhs1, env1) + (bndr, env) (new_bndr, rhs1, env1) ; return (rhs_floats `addFloats` bind_float, env2) } + {- ********************************************************************* * * Cast worker/wrapper @@ -772,7 +772,7 @@ That's what the 'go' loop in prepareRhs does -} prepareRhs :: HasDebugCallStack - => SimplEnv -> TopLevelFlag + => SimplEnvIS -> TopLevelFlag -> FastString -- Base for any new variables -> OutExpr -> SimplM (LetFloats, OutExpr) @@ -832,7 +832,8 @@ prepareRhs env top_lvl occ rhs0 anfise other = return (emptyLetFloats, other) -makeTrivialArg :: HasDebugCallStack => SimplEnv -> ArgSpec -> SimplM (LetFloats, ArgSpec) +makeTrivialArg :: HasDebugCallStack => SimplEnvIS -> ArgSpec + -> SimplM (LetFloats, ArgSpec) makeTrivialArg env arg@(ValArg { as_arg = e, as_dmd = dmd }) = do { (floats, e') <- makeTrivial env NotTopLevel dmd (fsLit "arg") e ; return (floats, arg { as_arg = e' }) } @@ -840,7 +841,7 @@ makeTrivialArg _ arg@(TyArg {}) = return (emptyLetFloats, arg) makeTrivial :: HasDebugCallStack - => SimplEnv -> TopLevelFlag -> Demand + => SimplEnvIS -> TopLevelFlag -> Demand -> FastString -- ^ A "friendly name" to build the new binder from -> OutExpr -> SimplM (LetFloats, OutExpr) @@ -1260,9 +1261,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 = env + ApplyToVal { sc_arg = arg, sc_env = UnSimplified env , sc_hole_ty = substTy env (exprType fun) - , sc_dup = NoDup, sc_cont = cont } + , sc_cont = cont } simplExprF1 env expr@(Lam {}) cont = {-#SCC "simplExprF1-Lam" #-} @@ -1280,9 +1281,8 @@ simplExprF1 env expr@(Lam {}) cont simplExprF1 env (Case scrut bndr _ alts) cont = {-#SCC "simplExprF1-Case" #-} - simplExprF env scrut (Select { sc_dup = NoDup, sc_bndr = bndr - , sc_alts = alts - , sc_env = env, sc_cont = cont }) + simplExprF env scrut (Select { sc_bndr = bndr, sc_alts = alts + , sc_env = UnSimplified env, sc_cont = cont }) simplExprF1 env (Let (Rec pairs) body) cont | Just pairs' <- joinPointBindings_maybe pairs @@ -1298,7 +1298,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 NoDup rhs env + | Just env' <- preInlineUnconditionally env NotTopLevel bndr rhs (UnSimplified 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) $ @@ -1570,7 +1570,8 @@ simplTick env tickish expr cont rebuild :: SimplEnv -> OutExpr -> SimplCont -> SimplM (SimplFloats, OutExpr) rebuild env expr cont = rebuild_go (zapSubstEnv env) expr cont -rebuild_go :: SimplEnvIS -> OutExpr -> SimplCont -> SimplM (SimplFloats, OutExpr) +rebuild_go :: HasDebugCallStack + => SimplEnvIS -> OutExpr -> SimplCont -> SimplM (SimplFloats, OutExpr) -- SimplEnvIS: at this point the substitution in the SimplEnv is irrelevant; -- only the in-scope set matters, plus the flags. rebuild_go env expr cont @@ -1589,22 +1590,26 @@ rebuild_go env expr cont co' = optOutCoercion env co opt Select { sc_bndr = bndr, sc_alts = alts, sc_env = se, sc_cont = cont } - -> rebuildCase (se `setInScopeFromE` env) expr bndr alts cont + -> rebuildCase (mkAltEnv env se) expr bndr alts cont StrictArg { sc_fun = fun, sc_cont = cont, sc_fun_ty = fun_ty } -> rebuildCall env (addValArgTo fun expr fun_ty) cont StrictBind { sc_bndr = b, sc_body = body, sc_env = se , sc_cont = cont, sc_from = from_what } - -> completeBindX (se `setInScopeFromE` env) from_what b expr body cont + -> completeBindX body_env from_what b expr body cont + where + (_saf, body_env) = mkAltEnv env se + -- In the Simplified case, it's always a OkDup, so we accept that + -- `completeBindX` may re-simplify `body` 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 + ApplyToVal { sc_arg = arg, sc_env = se , 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') <- simplArg env fun_ty Nothing se arg ; rebuild_go env (App expr arg') cont } completeBindX :: SimplEnv @@ -1748,7 +1753,7 @@ pushCast env co cont -- co1 :: t1 ~ s1 -- co2 :: s2 ~ t2 go co co_is_opt cont@(ApplyToVal { sc_arg = arg, sc_env = arg_se - , sc_dup = dup, sc_cont = tail + , sc_cont = tail , sc_hole_ty = fun_ty }) | not co_is_opt = -- pushCoValArg duplicates the coercion, so optimise first @@ -1763,7 +1768,7 @@ pushCast env co cont -- See Note [Avoiding simplifying repeatedly] MCo co1 -> - do { (dup', arg_se', arg') <- simplLazyArg env dup fun_ty Nothing arg_se arg + do { (arg_se', arg') <- simplArg env 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. @@ -1771,7 +1776,6 @@ pushCast env co cont -- Example of use: #995 ; return (ApplyToVal { sc_arg = mkCast arg' co1 , sc_env = arg_se' - , sc_dup = dup' , sc_cont = tail' , sc_hole_ty = coercionLKind co }) } } } @@ -1788,26 +1792,24 @@ pushCast env co cont go_mco MRefl _ cont = return cont go_mco (MCo co) opt cont = go co opt 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 +simplArg :: 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' + -> StaticEnv -> CoreExpr -- ^ Expression with its static envt + -> SimplM (StaticEnv, OutExpr) +simplArg _ _ _ se@(Simplified {}) arg + = return (se, arg) +simplArg env fun_ty mb_arg_info (UnSimplified arg_se) arg + = do { let 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 ; arg' <- simplExprC arg_env' arg stop - ; return (Simplified, zapSubstEnv arg_env', arg') } + ; return (Simplified NoDup, arg') } -- Return a StaticEnv that includes the in-scope set from 'env', -- because arg' may well mention those variables (#20639) @@ -1847,13 +1849,15 @@ simpl_lam env bndr body (ApplyToVal { sc_arg = Coercion arg_co, sc_env = arg_se , sc_cont = cont }) = assertPpr (isCoVar bndr) (ppr bndr) $ do { tick (BetaReduction bndr) - ; let arg_co' = substCo (arg_se `setInScopeFromE` env) arg_co + ; let arg_co' = case arg_se of + Simplified {} -> arg_co + UnSimplified arg_se -> substCo (arg_se `setInScopeFromE` env) arg_co ; simplLam (extendCvSubst env bndr arg_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 - , sc_cont = cont, sc_dup = dup + , sc_cont = cont , sc_hole_ty = fun_ty}) = do { tick (BetaReduction bndr) ; let from_what = FromBeta arg_levity @@ -1869,7 +1873,7 @@ 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 dup arg arg_se + ; 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 @@ -1877,13 +1881,17 @@ simpl_lam env bndr body (ApplyToVal { sc_arg = arg, sc_env = arg_se 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 } + -> case arg_se of + Simplified {} + -- 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 + + UnSimplified arg_env + -> simplNonRecE env from_what bndr (arg, arg_env) body cont + } -- Discard a non-counting tick on a lambda. This may change the -- cost attribution slightly (moving the allocation of the @@ -1945,7 +1953,7 @@ simplNonRecE env from_what bndr (rhs, rhs_se) body cont = -- Evaluate RHS strictly simplExprF (rhs_se `setInScopeFromE` env) rhs (StrictBind { sc_bndr = bndr, sc_body = body, sc_from = from_what - , sc_env = env, sc_cont = cont, sc_dup = NoDup }) + , sc_env = UnSimplified env, sc_cont = cont }) | otherwise -- Evaluate RHS lazily = do { (env1, bndr1) <- simplNonRecBndr env bndr @@ -2278,7 +2286,7 @@ simplInId :: SimplEnv -> InId -> SimplCont -> SimplM (SimplFloats, OutExpr) simplInId env var cont | Just dc <- isDataConWorkId_maybe var , isLazyDataConRep dc -- See Note [Fast path for lazy data constructors] - = rebuild_go zapped_env (Var var) cont + = rebuild env (Var var) cont | otherwise = case substId env var of ContEx tvs cvs ids e -> simplExprF env' e cont @@ -2299,13 +2307,18 @@ simplInId env var cont --------------------------------------------------------- -simplOutExpr :: SimplEnvIS -> OutExpr -> SimplCont -> SimplM (SimplFloats, OutExpr) +simplOutExpr :: HasDebugCallStack + => SimplEnvIS -> OutExpr -> SimplCont -> SimplM (SimplFloats, OutExpr) -- A teeny-tiny simplifier for an OutExpr, which parsimonously avoids re-simplifying -- the entire things all over again -- -- What if expr = (K x y) and cont is `Select`? That is handled by rebuild. -- (Why? That's a bit inconsistent with beta.) simplOutExpr env expr cont + | assertPpr (checkSimplEnvIS env) (pprBadSimplEnvIS env) $ + False -- Just checks the assertion! + = panic "simplOutExpr" + | Lam {} <- expr , cont_has_args = simplLam env (occurAnalyseExpr expr) cont @@ -2326,7 +2339,7 @@ simplOutExpr env expr cont -- pprTrace "simplOutExpr" (vcat [ ppr v <+> dcolon <+> ppr (idType v) -- , text "args:" <+> ppr args -- , text "cont:" <+> ppr cont ]) $ - simplOutId env v (pushArgs env (idType v) args cont) + simplOutId env v (pushArgs (idType v) args cont) | otherwise = rebuild_go env expr cont @@ -2349,7 +2362,7 @@ simplOutId env fun cont , sc_env = arg_se, 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 + = do { let (_saf,arg_env) = mkAltEnv env arg_se overall_res_ty = contResultType cont3 -- hole_ty is the type of the current runRW# application @@ -2374,8 +2387,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_arg = Var s' + , sc_env = Simplified OkDup, 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' @@ -2460,30 +2473,23 @@ 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_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 + , sc_hole_ty = fun_ty, sc_cont = cont }) + | UnSimplified arg_env <- arg_se + , 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 (StrictArg { sc_fun = fun_info, sc_fun_ty = fun_ty - , sc_dup = Simplified + , sc_dup = NoDup , sc_cont = cont }) -- Note [Shadowing in the Simplifier] - -- 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 + | otherwise -- Lazy, or already simplified arguments + -- 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') <- simplArg env fun_ty (Just fun_info) arg_se arg ; rebuildCall env (addValArgTo fun_info arg' fun_ty) cont } ---------- No further useful info, revert to generic rebuild ------------ @@ -2508,7 +2514,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 @@ -2685,8 +2691,8 @@ fireRuleAFTER env rule_match arg_specs cont , rm_binds = wrap, rm_bndrs = bndrs } <- rule_match = do { let env' = env `addNewInScopeIds` bndrs ; (floats, e') <- simplExprF env' rhs $ - pushArgs env' (exprType rhs) rhs_args $ - pushArgSpecs env' (drop (ruleArity rule) arg_specs) cont + pushArgs (exprType rhs) rhs_args $ + pushArgSpecs (drop (ruleArity rule) arg_specs) cont ; return $ if isEmptyBindWrapper wrap -- Not very pretty then (floats, e') @@ -2797,9 +2803,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 - , sc_hole_ty = res4_ty } + rule_cont = ApplyToVal { sc_env = UnSimplified in_env, sc_arg = rhs + , sc_cont = cont, sc_hole_ty = res4_ty } out_args = [Type rhs_rep, Type scrut_ty, Type rhs_ty, no_cast_scrut] -- Cheaper than (map argSpecArg out_arg_specs) @@ -3143,7 +3148,7 @@ We want to bind x' to x, and not to a duplicated (a,b)). -- Eliminate the case if possible rebuildCase, reallyRebuildCase - :: SimplEnv + :: (SimplAltFlag, SimplEnv) -> OutExpr -- Scrutinee -> InId -- Case binder -> [InAlt] -- Alternatives (increasing order) @@ -3154,14 +3159,14 @@ rebuildCase, reallyRebuildCase -- 1. Eliminate the case if there's a known constructor -------------------------------------------------- -rebuildCase env scrut case_bndr alts cont +rebuildCase (saf,env) scrut case_bndr alts cont | Lit lit <- scrut -- No need for same treatment as constructors -- because literals are inlined more vigorously , not (litIsLifted lit) = do { tick (KnownBranch case_bndr) ; case findAlt (LitAlt lit) alts of Nothing -> missingAlt env case_bndr alts cont - Just (Alt _ bs rhs) -> simple_rhs env scrut bs rhs } + Just (Alt _ bs rhs) -> simpl_rhs env scrut bs rhs } | Just (in_scope', wfloats, con, ty_args, other_args) <- exprIsConApp_maybe (getUnfoldingInRuleMatch env) scrut @@ -3177,24 +3182,24 @@ rebuildCase env scrut case_bndr alts cont ; wrapDataConFloats env wfloats case_bndr cont $ case findAlt (DataAlt con) alts of Nothing -> missingAlt env0 case_bndr alts cont - Just (Alt DEFAULT bs rhs) -> simple_rhs env0 case_bndr_rhs bs rhs - Just (Alt _ bs rhs) -> knownCon env0 scrut con - other_args case_bndr bs rhs cont + Just (Alt DEFAULT bs rhs) -> simpl_rhs env0 case_bndr_rhs bs rhs + Just (Alt _ bs rhs) -> knownCon env0 scrut con other_args + case_bndr bs rhs cont } where - simple_rhs env case_bndr_rhs bs rhs = - assert (null bs) $ - do { (floats1, env') <- simplAuxBind "rebuildCase" env case_bndr case_bndr_rhs - -- scrut is a constructor application, - -- hence satisfies let-can-float invariant - ; (floats2, expr') <- simplExprF env' rhs cont - ; return (floats1 `addFloats` floats2, expr') } + simpl_rhs env case_bndr_rhs bs rhs + = assert (null bs) $ + do { (floats1, env') <- simplAuxBind (saf,env) case_bndr case_bndr_rhs + -- scrut is a constructor application, + -- hence satisfies let-can-float invariant + ; (floats2, expr') <- simplExprF env' rhs cont + ; return (floats1 `addFloats` floats2, expr') } -------------------------------------------------- -- 2. Eliminate the case if scrutinee is evaluated -------------------------------------------------- -rebuildCase env scrut case_bndr alts@[Alt _ bndrs rhs] cont +rebuildCase (saf,env) scrut case_bndr alts@[Alt _ bndrs rhs] cont -- See if we can get rid of the case altogether -- See Note [Case elimination] -- mkCase made sure that if all the alternatives are equal, @@ -3218,7 +3223,9 @@ rebuildCase env scrut case_bndr alts@[Alt _ bndrs rhs] cont | all_dead_bndrs , doCaseToLet scrut case_bndr = do { tick (CaseElim case_bndr) - ; (floats1, env') <- simplAuxBind "rebuildCaseAlt1" env case_bndr scrut + ; (floats1, env') <- simplAuxBind (saf,env) case_bndr scrut + -- simplAuxBind can create a substitution for case_bndr, + -- so we must re-simpify `rhs` regardless of `saf` ; (floats2, expr') <- simplExprF env' rhs cont ; return (floats1 `addFloats` floats2, expr') } @@ -3230,22 +3237,22 @@ rebuildCase env scrut case_bndr alts@[Alt _ bndrs rhs] cont = do { mb_rule <- trySeqRules env scrut rhs cont ; case mb_rule of Just (rm, ass, rcont) -> fireRuleAFTER env rm ass rcont - Nothing -> reallyRebuildCase env scrut case_bndr alts cont } + Nothing -> reallyRebuildCase (saf,env) scrut case_bndr alts cont } where all_dead_bndrs = all isDeadBinder bndrs -- bndrs are [InId] is_plain_seq = all_dead_bndrs && isDeadBinder case_bndr -- Evaluation *only* for effect -rebuildCase env scrut case_bndr alts cont +rebuildCase (saf,env) scrut case_bndr alts cont -------------------------------------------------- -- 3. Primop-related case-rules -------------------------------------------------- | Just (scrut', case_bndr', alts') <- caseRules2 (sePlatform env) scrut case_bndr alts - = reallyRebuildCase env scrut' case_bndr' alts' cont + = reallyRebuildCase (saf,env) scrut' case_bndr' alts' cont | otherwise - = reallyRebuildCase env scrut case_bndr alts cont + = reallyRebuildCase (saf,env) scrut case_bndr alts cont doCaseToLet :: OutExpr -- Scrutinee -> InId -- Case binder @@ -3276,17 +3283,17 @@ doCaseToLet scrut case_bndr -- 3. Catch-all case -------------------------------------------------- -reallyRebuildCase env scrut case_bndr alts cont +reallyRebuildCase (saf,env) scrut case_bndr alts cont | not (seCaseCase env) -- Only when case-of-case is on. -- See GHC.Driver.Config.Core.Opt.Simplify -- Note [Case-of-case and full laziness] - = do { case_expr <- simplAlts env scrut case_bndr alts + = do { case_expr <- simplAlts (saf,env) scrut case_bndr alts (mkBoringStop (contHoleType cont)) ; rebuild env case_expr cont } | otherwise = do { (floats, env', cont') <- mkDupableCaseCont env alts cont - ; case_expr <- simplAlts env' scrut + ; case_expr <- simplAlts (saf,env') scrut (scaleIdBy holeScaling case_bndr) (scaleAltsBy holeScaling alts) cont' @@ -3427,24 +3434,23 @@ scale the entire case we are simplifying, by a scaling factor which can be computed in the continuation (with function `contHoleScaling`). -} -simplAlts :: SimplEnv - -> OutExpr -- Scrutinee - -> InId -- Case binder - -> [InAlt] -- Non-empty +simplAlts :: (SimplAltFlag, SimplEnv) + -> OutExpr -- Scrutinee + -> InId -> [InAlt] -- Alts (non-empty) -> SimplCont -> SimplM OutExpr -- Returns the complete simplified case expression -simplAlts env0 scrut case_bndr alts cont' +simplAlts (saf,env0) scrut case_bndr alts cont' = do { traceSmpl "simplAlts" (vcat [ ppr case_bndr , text "cont':" <+> ppr cont' , text "in_scope" <+> ppr (seInScope env0) ]) - ; (env1, case_bndr1) <- simplBinder env0 case_bndr + ; (env1, case_bndr1) <- simplAltIdBinder (saf,env0) case_bndr ; let case_bndr2 = case_bndr1 `setIdUnfolding` evaldUnfolding env2 = modifyInScope env1 case_bndr2 -- See Note [Case binder evaluated-ness] fam_envs = seFamEnvs env0 - ; (alt_env', scrut', case_bndr') <- improveSeq fam_envs env2 scrut + ; (alt_env', scrut', case_bndr') <- improveSeq fam_envs (saf,env2) scrut case_bndr case_bndr2 alts ; (imposs_deflt_cons, in_alts) <- prepareAlts scrut' case_bndr alts @@ -3454,7 +3460,7 @@ simplAlts env0 scrut case_bndr alts cont' -- See Note [Shadowing in prepareAlts] in GHC.Core.Opt.Simplify.Utils ; alts' <- forM in_alts $ - simplAlt alt_env' (Just scrut') imposs_deflt_cons + simplAlt (saf,alt_env') (Just scrut') imposs_deflt_cons case_bndr' (scrutOkForBinderSwap scrut) cont' ; let alts_ty' = contResultType cont' @@ -3464,23 +3470,25 @@ simplAlts env0 scrut case_bndr alts cont' ------------------------------------ -improveSeq :: (FamInstEnv, FamInstEnv) -> SimplEnv +improveSeq :: (FamInstEnv, FamInstEnv) + -> (SimplAltFlag, SimplEnv) -> OutExpr -> InId -> OutId -> [InAlt] -> SimplM (SimplEnv, OutExpr, OutId) -- Note [Improving seq] -improveSeq fam_envs env scrut case_bndr case_bndr1 [Alt DEFAULT _ _] - | Just (Reduction co ty2) <- topNormaliseType_maybe fam_envs (idType case_bndr1) +improveSeq fam_envs (saf,env) scrut case_bndr case_bndr1 [Alt DEFAULT _ _] + | SAF_In <- saf -- improveSeq extends the substitution; not allowed for SAF_Out + , Just (Reduction co ty2) <- topNormaliseType_maybe fam_envs (idType case_bndr1) = do { case_bndr2 <- newId (fsLit "nt") ManyTy ty2 ; let rhs = DoneEx (Var case_bndr2 `Cast` mkSymCo co) NotJoinPoint env2 = extendIdSubst env case_bndr rhs ; return (env2, scrut `Cast` co, case_bndr2) } -improveSeq _ env scrut _ case_bndr1 _ +improveSeq _ (_,env) scrut _ case_bndr1 _ = return (env, scrut, case_bndr1) ------------------------------------ -simplAlt :: SimplEnv +simplAlt :: (SimplAltFlag, SimplEnv) -> Maybe OutExpr -- The scrutinee -> [AltCon] -- These constructors can't be present when -- matching the DEFAULT alternative @@ -3491,26 +3499,27 @@ simplAlt :: SimplEnv -> InAlt -> SimplM OutAlt -simplAlt env _scrut' imposs_deflt_cons case_bndr' bndr_swap' cont' (Alt DEFAULT bndrs rhs) +simplAlt (saf,env) _scrut' imposs_deflt_cons case_bndr' bndr_swap' cont' (Alt DEFAULT bndrs rhs) = assert (null bndrs) $ do { let env' = addDefaultUnfoldings env case_bndr' bndr_swap' imposs_deflt_cons - ; rhs' <- simplExprC env' rhs cont' + ; rhs' <- simplAltExprC (saf,env') rhs cont' ; return (Alt DEFAULT [] rhs') } -simplAlt env _scrut' _ case_bndr' bndr_swap' cont' (Alt (LitAlt lit) bndrs rhs) +simplAlt (saf,env) _scrut' _ case_bndr' bndr_swap' cont' (Alt (LitAlt lit) bndrs rhs) = assert (null bndrs) $ do { let env' = addAltUnfoldings env case_bndr' bndr_swap' (Lit lit) - ; rhs' <- simplExprC env' rhs cont' + ; rhs' <- simplAltExprC (saf,env') rhs cont' ; return (Alt (LitAlt lit) [] rhs') } -simplAlt env scrut' _ case_bndr' bndr_swap' cont' (Alt (DataAlt con) vs rhs) +simplAlt (saf,env) scrut' _ case_bndr' bndr_swap' cont' (Alt (DataAlt con) vs rhs) = do { -- See Note [Adding evaluatedness info to pattern-bound variables] -- and Note [DataAlt occ info] ; let vs_with_info = adjustFieldsIdInfo scrut' case_bndr' bndr_swap' con vs -- Adjust evaluated-ness and occ-info flags before `simplBinders` -- because the latter extends the in-scope set, which propagates this -- adjusted info to use sites. - ; (env', vs') <- simplBinders env vs_with_info + + ; (env', vs') <- simplAltBinders (saf,env) vs_with_info -- Bind the case-binder to (con args) ; let inst_tys' = tyConAppArgs (idType case_bndr') @@ -3518,7 +3527,7 @@ simplAlt env scrut' _ case_bndr' bndr_swap' cont' (Alt (DataAlt con) vs rhs) con_app = mkConApp2 con inst_tys' vs' env'' = addAltUnfoldings env' case_bndr' bndr_swap' con_app - ; rhs' <- simplExprC env'' rhs cont' + ; rhs' <- simplAltExprC (saf,env'') rhs cont' ; return (Alt (DataAlt con) vs' rhs') } {- Note [Adding evaluatedness info to pattern-bound variables] @@ -3665,6 +3674,40 @@ zapBndrOccInfo keep_occ_info pat_id | keep_occ_info = pat_id | otherwise = zapIdOccInfo pat_id + +data SimplAltFlag = SAF_In -- Must run the simplifier, or at least substitution + | SAF_Out -- No need to run the simplifier; substitution is empty + +mkAltEnv :: SimplEnvIS -> StaticEnv -> (SimplAltFlag, SimplEnv) +mkAltEnv env (Simplified {}) = (SAF_Out, env) +mkAltEnv env (UnSimplified se) = (SAF_In, se`setInScopeFromE` env) + +simplAltBinders :: (SimplAltFlag, SimplEnv) -> [Var] -> SimplM (SimplEnv, [OutVar]) +simplAltBinders (saf,env) bs + = case saf of + SAF_Out -> return (env, bs) + SAF_In -> simplBinders env bs + +simplAltIdBinder :: (SimplAltFlag, SimplEnv) -> Id -> SimplM (SimplEnv, OutId) +simplAltIdBinder (saf,env) bndr + = case saf of + SAF_Out -> return (env, bndr) + SAF_In -> simplNonRecBndr env bndr + +simplAltExprF :: HasDebugCallStack + => (SimplAltFlag, SimplEnv) -> CoreExpr -> SimplCont + -> SimplM (SimplFloats, OutExpr) +simplAltExprF (saf,env) expr cont + = case saf of + SAF_Out -> simplOutExpr env expr cont + SAF_In -> simplExprF env expr cont + +simplAltExprC :: (SimplAltFlag, SimplEnv) -> CoreExpr -> SimplCont -> SimplM OutExpr +simplAltExprC env expr cont + = do { (floats, expr') <- simplAltExprF env expr cont + ; return (wrapFloats floats expr') } + + {- Note [Case binder evaluated-ness] ~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~ We pin on a (OtherCon []) unfolding to the case-binder of a Case, @@ -3799,12 +3842,13 @@ wrapDataConFloats env wfloats case_bndr cont thing_inside knownCon :: SimplEnv - -> OutExpr -- The scrutinee - -> DataCon -> [OutExpr] -- The scrutinee (in pieces) - -> InId -> [InBndr] -> InExpr -- The alternative + -> OutExpr -- The scrutinee + -> DataCon -> [OutExpr] -- The scrutinee (in pieces) + -> InId -> [InBndr] -> InExpr -- The alternative -> SimplCont -> SimplM (SimplFloats, OutExpr) - +-- We do not pass SimplAltFlag to knownCon because we really do want +-- to simplify the RHS, with the new knowledge about the case-simplification knownCon env scrut dc dc_args case_bndr alt_bndrs rhs cont = do { (floats1, env1) <- bind_args env alt_bndrs dc_args ; (floats2, env2) <- bind_case_bndr env1 @@ -3831,7 +3875,8 @@ knownCon env scrut dc dc_args case_bndr alt_bndrs rhs cont -- occur in the RHS; and simplAuxBind may therefore discard it. -- Nevertheless we must keep it if the case-binder is alive, -- because it may be used in the con_app. See Note [knownCon occ info] - ; (floats1, env2) <- simplAuxBind "knownCon" env' b' arg -- arg satisfies let-can-float invariant + ; (floats1, env2) <- simplAuxBind (SAF_In,env') b' arg + -- arg satisfies let-can-float invariant ; (floats2, env3) <- bind_args env2 bs' args ; return (floats1 `addFloats` floats2, env3) } @@ -3855,11 +3900,11 @@ 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 NoDup con_app env + | Just env' <- preInlineUnconditionally env NotTopLevel case_bndr con_app (UnSimplified env) = return (emptyFloats env', env') | otherwise - = do { (env1, case_bndr1) <- simplNonRecBndr env case_bndr + = do { (env1, case_bndr1) <- simplAltIdBinder (SAF_In,env) case_bndr ; simplLazyBind NotTopLevel NonRecursive (case_bndr,env) (case_bndr1,env1) (con_app,env) } @@ -3918,9 +3963,9 @@ join points and inlining them away. See #4930. -} -------------------- -mkDupableCaseCont :: SimplEnv -> [InAlt] -> SimplCont +mkDupableCaseCont :: SimplEnvIS -> [InAlt] -> SimplCont -> SimplM ( SimplFloats -- Join points (if any) - , SimplEnv -- Use this for the alts + , SimplEnvIS -- Use this for the alts , SimplCont) mkDupableCaseCont env alts cont | altsWouldDup alts = do { (floats, cont) <- mkDupableCont env cont @@ -3940,7 +3985,7 @@ altsWouldDup (alt:alts) is_bot_alt (Alt _ _ rhs) = exprIsDeadEnd rhs ------------------------- -mkDupableCont :: SimplEnv +mkDupableCont :: SimplEnvIS -> SimplCont -> SimplM ( SimplFloats -- Incoming SimplEnv augmented with -- extra let/join-floats and in-scope variables @@ -3974,12 +4019,17 @@ mkDupableContWithDmds env dmds (TickIt t cont) ; return (floats, TickIt t cont') } mkDupableContWithDmds env _ - (StrictBind { sc_bndr = bndr, sc_body = body, sc_from = from_what - , sc_env = se, sc_cont = cont}) + cont1@(StrictBind { sc_bndr = bndr, sc_body = body, sc_from = from_what + , sc_env = se, sc_cont = cont}) -- See Note [Duplicating StrictBind] -- K[ let x = <> in b ] --> join j x = K[ b ] -- j <> - = do { let sb_env = se `setInScopeFromE` env + = do { let sb_env = case se of + UnSimplified static_env -> static_env `setInScopeFromE` env + Simplified {} -> pprPanic "mkDupableContWithDmds" (ppr se $$ ppr cont1) + -- The contIsDupable caught the OkDup case, and + -- we never build a StrictBind with a NoDup in it. + ; (sb_env1, bndr') <- simplBinder sb_env bndr ; (floats1, join_inner) <- simplNonRecBody sb_env1 from_what body cont -- No need to use mkDupableCont before simplNonRecBody; we @@ -4009,7 +4059,7 @@ mkDupableContWithDmds env _ , StrictArg { sc_fun = fun { ai_args = args' } , sc_cont = cont' , sc_fun_ty = fun_ty - , sc_dup = OkToDup} ) } + , sc_dup = OkDup} ) } | otherwise = -- Use Plan B of Note [Duplicating StrictArg] @@ -4038,7 +4088,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, sc_env = se , sc_cont = cont, sc_hole_ty = hole_ty }) = -- e.g. [...hole...] (...arg...) -- ==> @@ -4048,18 +4098,12 @@ 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 - ; (let_floats2, arg'') <- makeTrivial env NotTopLevel dmd (fsLit "karg") arg' + ; (_, arg') <- simplArg env' hole_ty Nothing se 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 = 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 - , sc_dup = OkToDup, sc_cont = cont' - , sc_hole_ty = hole_ty }) } + , ApplyToVal { sc_arg = triv_arg, sc_env = Simplified 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 }) @@ -4069,16 +4113,20 @@ mkDupableContWithDmds env _ -- in case [...hole...] of { pi -> ji xij } -- NB: sc_dup /= OkToDup; that is caught earlier by contIsDupable do { tick (CaseOfCase case_bndr) - ; (floats, alt_env, alt_cont) <- mkDupableCaseCont (se `setInScopeFromE` env) alts cont + ; (floats, env1, alt_cont) <- mkDupableCaseCont env alts cont -- NB: We call mkDupableCaseCont here to make cont duplicable -- (if necessary, depending on the number of alts) -- And this is important: see Note [Fusing case continuations] ; let cont_scaling = contHoleScaling cont + (saf, alt_env) = mkAltEnv env1 se + -- See Note [Scaling in case-of-case] - ; (alt_env', case_bndr') <- simplBinder alt_env (scaleIdBy cont_scaling case_bndr) + ; (alt_env1, case_bndr') <- simplAltIdBinder (saf,alt_env) $ + scaleIdBy cont_scaling case_bndr + ; alts' <- forM (scaleAltsBy cont_scaling alts) $ - simplAlt alt_env' Nothing [] case_bndr' NoBinderSwap alt_cont + simplAlt (saf,alt_env1) Nothing [] case_bndr' NoBinderSwap alt_cont -- Safe to say that there are no handled-cons for the DEFAULT case -- NB: simplBinder does not zap deadness occ-info, so -- a dead case_bndr' will still advertise its deadness @@ -4097,11 +4145,8 @@ mkDupableContWithDmds env _ ; let all_floats = floats `addJoinFloats` join_floats -- Note [Duplicated env] ; return (all_floats - , Select { sc_dup = OkToDup - , sc_bndr = case_bndr' - , sc_alts = alts'' - , sc_env = zapSubstEnv se `setInScopeFromF` all_floats - -- See Note [StaticEnv invariant] in GHC.Core.Opt.Simplify.Utils + , Select { sc_bndr = case_bndr', sc_alts = alts'' + , sc_env = Simplified OkDup , sc_cont = mkBoringStop (contResultType cont) } ) } mkDupableStrictBind :: SimplEnv -> OutId -> OutExpr -> OutType @@ -4112,10 +4157,9 @@ mkDupableStrictBind env arg_bndr join_rhs res_ty = return (emptyFloats env , StrictBind { sc_bndr = arg_bndr , sc_body = join_rhs - , sc_env = zapSubstEnv env + , sc_env = Simplified OkDup + -- See Note [StaticEnv] in GHC.Core.Opt.Simplify.Utils , sc_from = FromLet - -- See Note [StaticEnv invariant] in GHC.Core.Opt.Simplify.Utils - , sc_dup = OkToDup , sc_cont = mkBoringStop res_ty } ) | otherwise = do { join_bndr <- newJoinId [arg_bndr] res_ty @@ -4127,7 +4171,7 @@ mkDupableStrictBind env arg_bndr join_rhs res_ty unitJoinFloat $ NonRec join_bndr $ Lam (setOneShotLambda arg_bndr) join_rhs - , StrictArg { sc_dup = OkToDup + , StrictArg { sc_dup = OkDup , sc_fun = arg_info , sc_fun_ty = idType join_bndr , sc_cont = mkBoringStop res_ty ===================================== compiler/GHC/Core/Opt/Simplify/Utils.hs ===================================== @@ -21,7 +21,8 @@ module GHC.Core.Opt.Simplify.Utils ( BindContext(..), bindContextLevel, -- The continuation type - SimplCont(..), DupFlag(..), FromWhat(..), StaticEnv, + SimplCont(..), DupFlag(..), FromWhat(..), + StaticEnv(..), isSimplified, contIsStop, contIsDupable, contResultType, contHoleType, contHoleScaling, contIsTrivial, contArgs, contIsRhs, @@ -171,11 +172,10 @@ data SimplCont , sc_cont :: SimplCont } | ApplyToVal -- (ApplyToVal arg K)[e] = K[ e arg ] - { sc_dup :: DupFlag -- See Note [DupFlag invariants] - , sc_hole_ty :: OutType -- Type of the function, presumably (forall a. blah) + { 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_env :: StaticEnv -- See Note [StaticEnv] + , sc_arg :: CoreExpr -- The argument, , sc_cont :: SimplCont } | ApplyToTy -- (ApplyToTy ty K)[e] = K[ e ty ] @@ -185,25 +185,24 @@ data SimplCont , sc_cont :: SimplCont } | Select -- (Select alts K)[e] = K[ case e of alts ] - { sc_dup :: DupFlag -- See Note [DupFlag invariants] - , sc_bndr :: InId -- case binder - , sc_alts :: [InAlt] -- Alternatives - , sc_env :: StaticEnv -- See Note [StaticEnv invariant] + { sc_env :: StaticEnv -- See Note [StaticEnv] + , sc_bndr :: Id -- Case binder + , sc_alts :: [CoreAlt] -- Alternatives , sc_cont :: SimplCont } -- The two strict forms have no DupFlag, because we never duplicate them | StrictBind -- (StrictBind x b K)[e] = let x = e in K[b] -- or, equivalently, = K[ (\x.b) e ] - { sc_dup :: DupFlag -- See Note [DupFlag invariants] - , sc_from :: FromWhat - , sc_bndr :: InId - , sc_body :: InExpr - , sc_env :: StaticEnv -- Static env for both sc_bndr (stable unfolding thereof) - -- and sc_body. Also see Note [StaticEnv invariant] + { sc_from :: FromWhat + , sc_env :: StaticEnv -- See Note [StaticEnv] + -- The sc_env in StrictBind is never (Simplified NoDup) + , sc_bndr :: Id + , sc_body :: CoreExpr + , sc_cont :: SimplCont } | StrictArg -- (StrictArg (f e1 ..en) K)[e] = K[ f e1 .. en e ] - { sc_dup :: DupFlag -- Always Simplified or OkToDup + { sc_dup :: DupFlag , sc_fun :: ArgInfo -- Specifies f, e1..en, Whether f has rules, etc -- plus demands and discount flags for *this* arg -- and further args @@ -217,60 +216,82 @@ data SimplCont CoreTickish -- Tick tickish <hole> SimplCont -type StaticEnv = SimplEnv -- Just the static part is relevant +data StaticEnv -- See Note [StaticEnv] + = Simplified DupFlag -- No static env needed + | UnSimplified 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] -~~~~~~~~~~~~~~~~~~~~~~~~~~~~~ -We pair up an InExpr or InAlts with a StaticEnv, which establishes the -lexical scope for that InExpr. - -When we simplify that InExpr/InAlts, we use - - Its captured StaticEnv - - 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. - -However the InScopeSet in the StaticEnv 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. - -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 +data DupFlag = NoDup -- Too big (or unknown) to dup + | OkDup -- Small enough to dup + +okToDup :: DupFlag -> Bool +okToDup NoDup = False +okToDup OkDup = True + +okToDupSE :: StaticEnv -> Bool +okToDupSE (Simplified dup) = okToDup dup +okToDupSE (UnSimplified {}) = False + +isSimplified :: StaticEnv -> Bool +isSimplified (Simplified {}) = True +isSimplified (UnSimplified {}) = False + +perhapsSubstTy :: StaticEnv -> Type -> Type +perhapsSubstTy (Simplified {}) ty = ty +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` + - 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`. + +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` + +* 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) + +* 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. + +(SE1) 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" + ppr OkDup = text "okdup" + ppr NoDup = text "nodup" instance Outputable SimplCont where ppr (Stop ty interesting eval_sd) @@ -283,18 +304,21 @@ 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_dup = dup, sc_cont = cont, sc_hole_ty = hole_ty }) - = (hang (text "ApplyToVal" <+> ppr dup <+> text "hole-ty:" <+> pprParendType hole_ty) + 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 cont ppr (StrictBind { sc_bndr = b, sc_cont = cont }) = (text "StrictBind" <+> ppr b) $$ ppr cont ppr (StrictArg { sc_fun = ai, sc_cont = cont }) = (text "StrictArg" <+> ppr (ai_fun ai)) $$ ppr cont - ppr (Select { sc_dup = dup, sc_bndr = bndr, sc_alts = alts, sc_cont = cont }) - = (text "Select" <+> ppr dup <+> ppr bndr) $$ + ppr (Select { sc_env = env, sc_bndr = bndr, sc_alts = alts, sc_cont = cont }) + = (text "Select" <> braces (ppr env) <+> ppr bndr) $$ whenPprDebug (nest 2 $ ppr alts) $$ ppr cont +instance Outputable StaticEnv where + ppr (Simplified dup) = ppr dup + ppr (UnSimplified _env) = text "in" -- For InExpr etc {- Note [The hole type in ApplyToTy] ~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~ @@ -384,30 +408,27 @@ isStrictArgInfo (ArgInfo { ai_dmds = dmds }) | dmd:_ <- dmds = isStrUsedDmd dmd | otherwise = False -pushArgs :: SimplEnvIS -> Type -> [OutExpr] -> SimplCont -> SimplCont -pushArgs _env _fun_ty [] cont +pushArgs :: Type -> [OutExpr] -> SimplCont -> SimplCont +pushArgs _fun_ty [] cont = cont -pushArgs env fun_ty (arg:args) cont +pushArgs fun_ty (arg:args) cont | Type ty <- arg = ApplyToTy { sc_hole_ty = fun_ty, sc_arg_ty = ty - , sc_cont = pushArgs env (piResultTy fun_ty ty) args cont } + , sc_cont = pushArgs (piResultTy fun_ty ty) args cont } | otherwise - = ApplyToVal { sc_dup = Simplified, sc_hole_ty = fun_ty - , sc_arg = arg, sc_env = env - , sc_cont = pushArgs env (funResultTy fun_ty) args cont} + = ApplyToVal { sc_hole_ty = fun_ty + , sc_arg = arg, sc_env = Simplified NoDup + , sc_cont = pushArgs (funResultTy fun_ty) args cont} -pushArgSpecs :: SimplEnvIS -- Barely needed, since sc_dup = Simplified - -> [ArgSpec] -- In normal, forward order +pushArgSpecs :: [ArgSpec] -- In normal, forward order -> SimplCont -> SimplCont -pushArgSpecs env args cont = foldr (pushArgSpec env) cont args --- pushSimplifiedRevArgs env args cont = foldl' (\k a -> pushSimplifiedArg env a k) cont args +pushArgSpecs args cont = foldr pushArgSpec cont args -pushArgSpec :: SimplEnvIS -> ArgSpec -> SimplCont -> SimplCont -pushArgSpec _env (TyArg { as_arg_ty = arg_ty, as_hole_ty = hole_ty }) cont +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 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 +pushArgSpec (ValArg { as_arg = arg, as_hole_ty = hole_ty }) cont + = ApplyToVal { sc_arg = arg, sc_env = Simplified NoDup , sc_hole_ty = hole_ty, sc_cont = cont } argSpecArg :: ArgSpec -> OutExpr @@ -456,13 +477,14 @@ contIsStop (Stop {}) = True contIsStop _ = False contIsDupable :: SimplCont -> Bool -contIsDupable (Stop {}) = True -contIsDupable (ApplyToTy { sc_cont = k }) = contIsDupable k -contIsDupable (ApplyToVal { sc_dup = OkToDup }) = True -- See Note [DupFlag invariants] -contIsDupable (Select { sc_dup = OkToDup }) = True -- ...ditto... -contIsDupable (StrictArg { sc_dup = OkToDup }) = True -- ...ditto... -contIsDupable (CastIt { sc_cont = k }) = contIsDupable k -contIsDupable _ = False +contIsDupable (Stop {}) = True +contIsDupable (ApplyToTy { sc_cont = k }) = contIsDupable k +contIsDupable (ApplyToVal { sc_env = se }) = okToDupSE se -- See (SE1) in Note [StaticEnv] +contIsDupable (Select { sc_env = se }) = okToDupSE se -- ...ditto... +contIsDupable (StrictBind { sc_env = se }) = okToDupSE se -- ...ditto... +contIsDupable (StrictArg { sc_dup = dup }) = okToDup dup -- ...ditto... +contIsDupable (CastIt { sc_cont = k }) = contIsDupable k +contIsDupable (TickIt _ k) = contIsDupable k ------------------- contIsTrivial :: SimplCont -> Bool @@ -488,13 +510,11 @@ 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 (StrictBind { sc_bndr = b, sc_env = se }) = perhapsSubstTy 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 (Select { sc_bndr = b, sc_env = se }) = perhapsSubstTy se (idType b) -- Computes the multiplicity scaling factor at the hole. That is, in (case [] of @@ -544,11 +564,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 @@ -558,15 +578,11 @@ contArgs cont lone _ = True go args (ApplyToVal { sc_arg = arg, sc_env = se, sc_cont = k }) - = go (is_interesting arg se : args) k + = go (interestingArg env se arg : args) k go args (ApplyToTy { sc_cont = k }) = go args k go args (CastIt { sc_cont = k }) = go args k go args k = (False, reverse args, k) - is_interesting arg se = interestingArg se arg - -- Do *not* use short-cutting substitution here - -- because we want to get as much IdInfo as possible - contOutArgs :: SimplEnv -> SimplCont -> [OutExpr] -- Get the leading arguments from the `SimplCont`, as /OutExprs/ contOutArgs env cont @@ -577,9 +593,10 @@ contOutArgs env cont 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 + 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 -- to get an OutExpr. See (BF1) in Note [tryRules: plan (BEFORE)] -- in GHC.Core.Opt.Simplify.Iteration @@ -1055,9 +1072,12 @@ Wrinkles: -} -interestingArg :: SimplEnv -> CoreExpr -> ArgSummary +interestingArg :: SimplEnv -> StaticEnv -> CoreExpr -> ArgSummary -- See Note [Interesting arguments] -interestingArg env e = go env 0 e +interestingArg env se e + = case se of + Simplified {} -> go env 0 e + UnSimplified static_env -> go (static_env `setInScopeFromE` env) 0 e where -- n is # value args to which the expression is applied go env n (Var v) @@ -1565,13 +1585,13 @@ the former. preInlineUnconditionally :: SimplEnv -> TopLevelFlag -> InId - -> DupFlag -> InExpr -> StaticEnv -- These three go together + -> InExpr -> StaticEnv -- 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 dup rhs rhs_env +preInlineUnconditionally env top_lvl bndr rhs rhs_se | not pre_inline_unconditionally = Nothing | not active = Nothing | isTopLevel top_lvl && isDeadEndId bndr = Nothing -- Note [Top-level bottoming Ids] @@ -1593,8 +1613,9 @@ preInlineUnconditionally env top_lvl bndr dup rhs rhs_env -- If not then ContEx -- ToDo: flesh this note out extend_subst_with inl_rhs - | isSimplified dup = extendIdSubst env bndr $! DoneEx inl_rhs NotJoinPoint - | otherwise = extendIdSubst env bndr $! mkContEx rhs_env inl_rhs + = case rhs_se of + Simplified _ -> extendIdSubst env bndr $! DoneEx inl_rhs NotJoinPoint + UnSimplified rhs_env -> extendIdSubst env bndr $! mkContEx rhs_env inl_rhs one_occ IAmDead = True -- Happens in ((\x.1) v) one_occ OneOcc{ occ_n_br = 1 View it on GitLab: https://gitlab.haskell.org/ghc/ghc/-/commit/e8ac16f20c85840402906bbe683aab4d... -- View it on GitLab: https://gitlab.haskell.org/ghc/ghc/-/commit/e8ac16f20c85840402906bbe683aab4d... You're receiving this email because of your account on gitlab.haskell.org.