Simon Peyton Jones pushed to branch wip/T26989 at Glasgow Haskell Compiler / GHC Commits: 27d8694f by Simon Peyton Jones at 2026-04-11T22:05:02+01:00 Wibbles Better management of casts - - - - - 6 changed files: - compiler/GHC/Core.hs - compiler/GHC/Core/Opt/OccurAnal.hs - compiler/GHC/Core/Opt/Simplify/Iteration.hs - compiler/GHC/Core/Opt/Simplify/Utils.hs - compiler/GHC/Core/Rules.hs - compiler/GHC/IfaceToCore.hs Changes: ===================================== compiler/GHC/Core.hs ===================================== @@ -1968,6 +1968,11 @@ Given this decision it's vital that we do *always* do it. occurrence in f out of scope. This happened in #8892, where the unfolding in question was a DFun unfolding. +Wrinkles + +(OUR1) For a RULE, say, + forall x y. f (x,y) = x+y +ToDO ************************************************************************ * * ===================================== compiler/GHC/Core/Opt/OccurAnal.hs ===================================== @@ -27,7 +27,8 @@ core expression with (hopefully) improved usage information. module GHC.Core.Opt.OccurAnal ( occurAnalysePgm, - occurAnalyseExpr, occurAnalyseExpr_Prep, + occurAnalyseExpr, occurAnalyseBndrsAndExpr, + occurAnalyseExpr_Prep, zapLambdaBndrs ) where @@ -85,6 +86,14 @@ occurAnalyseExpr expr = expr' where WUD _ expr' = occAnal initOccEnv expr +occurAnalyseBndrsAndExpr :: [Var] -> CoreExpr -> ([Var], CoreExpr) +-- Occur-anal (\bs.e), but taking and returning `bs` and `e` separately +occurAnalyseBndrsAndExpr bndrs expr + = (bndrs', expr') + where + WUD usage expr' = occAnal initOccEnv expr + bndrs' = tagLamBinders usage bndrs + -- | A version of 'occurAnalyseExpr' suitable for CorePrep. -- -- Different from 'occurAnalyseExpr' due to (JCT3) ===================================== compiler/GHC/Core/Opt/Simplify/Iteration.hs ===================================== @@ -1219,9 +1219,21 @@ simplExprF1 _ (Type ty) cont simplExprF1 env (Var v) cont = {-#SCC "simplInId" #-} simplInId env v cont simplExprF1 env (Lit lit) cont = {-#SCC "rebuild" #-} rebuild env (Lit lit) cont simplExprF1 env (Tick t expr) cont = {-#SCC "simplTick" #-} simplTick env t expr cont -simplExprF1 env (Cast body co) cont = {-#SCC "simplCast" #-} simplCast env body co cont 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 + + ; cont1 <- {-#SCC "simplCast-addCoerce" #-} + if isReflCo co1 + then return cont -- See Note [Optimising reflexivity] + else pushCast env co1 cont + -- True <=> co1 is optimised + + ; {-#SCC "simplCast-simplExprF" #-} + simplExprF env body cont1 } + simplExprF1 env (App fun arg) cont = {-#SCC "simplExprF1-App" #-} case arg of Type ty -> do { -- The argument type will (almost) certainly be used @@ -1567,6 +1579,10 @@ rebuild_go env expr cont Stop {} -> return (emptyFloats env, expr) TickIt t cont -> rebuild_go env (mkTick t expr) cont CastIt { sc_co = co, sc_opt = opt, sc_cont = cont } + | isReflexiveCo co' -- Worth trying this because casts can + -- get stacked up by simplCast + -> rebuild_go env expr cont + | otherwise -> rebuild_go env (mkCast expr co') cont -- NB: mkCast implements the (Coercion co |> g) optimisation where @@ -1689,9 +1705,8 @@ on each successive composition -- that's at least quadratic. So: * In `addCoerce` (in `simplCast`) if we combine this new coercion with an existing once, we build a CastIt for (co1 ; co2) with sc_opt=False. -* When unpacking a CastIt, in `rebuildCall` and `rebuild`, we optimise - the (presumably composed) coercion if sc_opt=False; this is done - by `optOutCoercion`. +* 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 @@ -1708,76 +1723,70 @@ optOutCoercion env co already_optimised empty_subst = mkEmptySubst (seInScope env) opts = seOptCoercionOpts env -simplCast :: SimplEnv -> InExpr -> InCoercion -> SimplCont - -> SimplM (SimplFloats, OutExpr) -simplCast env body co0 cont0 - = do { co1 <- {-#SCC "simplCast-simplCoercion" #-} simplCoercion env co0 - ; cont1 <- {-#SCC "simplCast-addCoerce" #-} - if isReflCo co1 - then return cont0 -- See Note [Optimising reflexivity] - else addCoerce co1 True cont0 - -- True <=> co1 is optimised - ; {-#SCC "simplCast-simplExprF" #-} simplExprF env body cont1 } +pushCast :: SimplEnv -> OutCoercion -> SimplCont -> SimplM SimplCont +pushCast env co cont + = go co True cont where + go :: OutCoercion -> Bool -> SimplCont -> SimplM SimplCont + go co1 _ (CastIt { sc_co = co2, sc_cont = cont }) -- See Note [Optimising reflexivity] + = go (mkTransCo co1 co2) False cont + -- False: (mkTransCo co1 co2) is not fully optimised + -- See Note [Avoid re-simplifying coercions] + + go co co_is_opt (ApplyToTy { sc_arg_ty = arg_ty, sc_cont = tail }) + | Just (arg_ty', m_co') <- pushCoTyArg co arg_ty + = {-#SCC "addCoerce-pushCoTyArg" #-} + do { tail' <- go_mco m_co' co_is_opt tail + ; return (ApplyToTy { sc_arg_ty = arg_ty' + , sc_cont = tail' + , sc_hole_ty = coercionLKind co }) } + -- NB! As the cast goes past, the + -- type of the hole changes (#16312) + + -- (f |> co) e ===> (f (e |> co1)) |> co2 + -- 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_dup = dup, sc_cont = tail + , sc_hole_ty = fun_ty }) + | not co_is_opt + = -- pushCoValArg duplicates the coercion, so optimise first + go (optOutCoercion (zapSubstEnv env) co co_is_opt) True cont + + | Just (m_co1, m_co2) <- pushCoValArg co + = {-#SCC "addCoerce-pushCoValArg" #-} + do { tail' <- go_mco m_co2 co_is_opt tail + ; case m_co1 of { + MRefl -> return (cont { sc_cont = tail' + , sc_hole_ty = coercionLKind co }) ; + -- 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' + , sc_cont = tail' + , sc_hole_ty = coercionLKind co }) } } } + + go co co_is_opt cont + | isReflCo co = return cont -- Having this at the end makes a huge + -- difference in T12227, for some reason + -- See Note [Optimising reflexivity] + | otherwise = return (CastIt { sc_co = co, sc_opt = co_is_opt, sc_cont = cont }) + -- If the first parameter is MRefl, then simplifying revealed a -- reflexive coercion. Omit. - addCoerceM :: MOutCoercion -> Bool -> SimplCont -> SimplM SimplCont - addCoerceM MRefl _ cont = return cont - addCoerceM (MCo co) opt cont = addCoerce co opt cont - - addCoerce :: OutCoercion -> Bool -> SimplCont -> SimplM SimplCont - addCoerce co1 _ (CastIt { sc_co = co2, sc_cont = cont }) -- See Note [Optimising reflexivity] - = addCoerce (mkTransCo co1 co2) False cont - -- False: (mkTransCo co1 co2) is not fully optimised - -- See Note [Avoid re-simplifying coercions] - - addCoerce co co_is_opt (ApplyToTy { sc_arg_ty = arg_ty, sc_cont = tail }) - | Just (arg_ty', m_co') <- pushCoTyArg co arg_ty - = {-#SCC "addCoerce-pushCoTyArg" #-} - do { tail' <- addCoerceM m_co' co_is_opt tail - ; return (ApplyToTy { sc_arg_ty = arg_ty' - , sc_cont = tail' - , sc_hole_ty = coercionLKind co }) } - -- NB! As the cast goes past, the - -- type of the hole changes (#16312) - - -- (f |> co) e ===> (f (e |> co1)) |> co2 - -- 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 - , sc_dup = dup, sc_cont = tail - , sc_hole_ty = fun_ty }) - | not co_is_opt -- pushCoValArg duplicates the coercion, so optimise first - = addCoerce (optOutCoercion (zapSubstEnv env) co co_is_opt) True cont - - | Just (m_co1, m_co2) <- pushCoValArg co - = {-#SCC "addCoerce-pushCoValArg" #-} - do { tail' <- addCoerceM m_co2 co_is_opt tail - ; case m_co1 of { - MRefl -> return (cont { sc_cont = tail' - , sc_hole_ty = coercionLKind co }) ; - -- 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' - , sc_cont = tail' - , sc_hole_ty = coercionLKind co }) } } } - - addCoerce co co_is_opt cont - | isReflCo co = return cont -- Having this at the end makes a huge - -- difference in T12227, for some reason - -- See Note [Optimising reflexivity] - | otherwise = return (CastIt { sc_co = co, sc_opt = co_is_opt, sc_cont = cont }) + go_mco :: MOutCoercion -> Bool -> SimplCont -> SimplM SimplCont + go_mco MRefl _ cont = return cont + go_mco (MCo co) opt cont = go co opt cont simplLazyArg :: SimplEnvIS -- ^ Used only for its InScopeSet -> DupFlag @@ -2293,14 +2302,21 @@ simplInId env var cont --------------------------------------------------------- simplOutExpr :: SimplEnvIS -> OutExpr -> SimplCont -> SimplM (SimplFloats, OutExpr) simplOutExpr env expr cont - = case fun of - Var v -> simplOutId env v cont' - Lam {} | not (null args) -> simplLam env occ_fun cont' -- We have a beta-redex - _ -> rebuild_go env expr cont - where - (fun, args) = collectArgs expr - cont' = pushArgs env Simplified (exprType fun) args cont - occ_fun = occurAnalyseExpr fun -- ToDo:explain; c.f. Note [Occurrence-analyse after rule firing] + | Lam {} <- expr + , hasArgs cont + = simplLam env (occurAnalyseExpr expr) cont + -- ToDo:explain; c.f. Note [Occurrence-analyse after rule firing] + + | Cast e co <- expr -- The inlined expression may be (x |> co) + -- and the cast may cancel with `cont` + = do { cont' <- pushCast env co cont + ; simplOutExpr env e cont' } + + | (Var v, args) <- collectArgs expr + = simplOutId env v (pushArgs env (idType v) args cont) + + | otherwise + = rebuild_go env expr cont --------------------------------------------------------- simplOutId :: SimplEnvIS -> OutId -> SimplCont -> SimplM (SimplFloats, OutExpr) @@ -2654,7 +2670,7 @@ 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' Simplified (exprType rhs) rhs_args $ + pushArgs env' (exprType rhs) rhs_args $ pushArgSpecs env' (drop (ruleArity rule) arg_specs) cont ; return $ if isEmptyBindWrapper wrap -- Not very pretty ===================================== compiler/GHC/Core/Opt/Simplify/Utils.hs ===================================== @@ -25,7 +25,7 @@ module GHC.Core.Opt.Simplify.Utils ( isSimplified, contIsStop, contIsDupable, contResultType, contHoleType, contHoleScaling, contIsTrivial, contArgs, contIsRhs, - countArgs, contOutArgs, dropContArgs, + hasArgs, countArgs, contOutArgs, dropContArgs, mkBoringStop, mkRhsStop, mkLazyArgStop, interestingCallContext, @@ -384,17 +384,17 @@ isStrictArgInfo (ArgInfo { ai_dmds = dmds }) | dmd:_ <- dmds = isStrUsedDmd dmd | otherwise = False -pushArgs :: SimplEnvIS -> DupFlag -> Type -> [OutExpr] -> SimplCont -> SimplCont -pushArgs _env _dup _fun_ty [] cont +pushArgs :: SimplEnvIS -> Type -> [OutExpr] -> SimplCont -> SimplCont +pushArgs _env _fun_ty [] cont = cont -pushArgs env dup fun_ty (arg:args) cont +pushArgs env fun_ty (arg:args) cont | Type ty <- arg = ApplyToTy { sc_hole_ty = fun_ty, sc_arg_ty = ty - , sc_cont = pushArgs env dup (piResultTy fun_ty ty) args cont } + , sc_cont = pushArgs env (piResultTy fun_ty ty) args cont } | otherwise - = ApplyToVal { sc_dup = dup, sc_hole_ty = fun_ty + = ApplyToVal { sc_dup = Simplified, sc_hole_ty = fun_ty , sc_arg = arg, sc_env = env - , sc_cont = pushArgs env dup (funResultTy fun_ty) args cont} + , sc_cont = pushArgs env (funResultTy fun_ty) args cont} pushArgSpecs :: SimplEnvIS -- Barely needed, since sc_dup = Simplified -> [ArgSpec] -- In normal, forward order @@ -522,6 +522,12 @@ contHoleScaling (ApplyToVal { sc_cont = k }) = contHoleScaling k contHoleScaling (TickIt _ k) = contHoleScaling k ------------------- +hasArgs :: SimplCont -> Bool +-- True <=> some leading arguments +hasArgs (ApplyToTy {}) = True +hasArgs (ApplyToVal {}) = True +hasArgs _ = False + countArgs :: SimplCont -> Int -- Count all arguments, including types, coercions, -- and other values; skipping over casts. ===================================== compiler/GHC/Core/Rules.hs ===================================== @@ -65,7 +65,7 @@ import GHC.Core.Tidy ( tidyRules ) import GHC.Core.Map.Expr ( eqCoreExpr ) import GHC.Core.Opt.Arity( etaExpandToJoinPointRule ) import GHC.Core.Make ( mkCoreLams ) -import GHC.Core.Opt.OccurAnal( occurAnalyseExpr ) +import GHC.Core.Opt.OccurAnal( occurAnalyseBndrsAndExpr ) import GHC.Core.Rules.Config (roBuiltinRules) import GHC.Tc.Utils.TcType ( tcSplitTyConApp_maybe ) @@ -200,16 +200,18 @@ mkRule this_mod is_auto is_local name act fn bndrs args rhs = Rule { ru_name = name , ru_act = act , ru_fn = fn - , ru_bndrs = bndrs + , ru_bndrs = bndrs' , ru_args = args - , ru_rhs = occurAnalyseExpr rhs - -- See Note [OccInfo in unfoldings and rules] + , ru_rhs = rhs' , ru_rough = roughTopNames args , ru_origin = this_mod , ru_orphan = orph , ru_auto = is_auto , ru_local = is_local } where + (bndrs', rhs') = occurAnalyseBndrsAndExpr bndrs rhs + -- See Note [OccInfo in unfoldings and rules] + -- Compute orphanhood. See Note [Orphans] in GHC.Core.InstEnv -- A rule is an orphan only if none of the variables -- mentioned on its left-hand side are locally defined ===================================== compiler/GHC/IfaceToCore.hs ===================================== @@ -76,7 +76,7 @@ import GHC.Core.Predicate( isUnaryClass ) import GHC.Core.TyCon import GHC.Core.ConLike import GHC.Core.DataCon -import GHC.Core.Opt.OccurAnal ( occurAnalyseExpr ) +import GHC.Core.Opt.OccurAnal ( occurAnalyseBndrsAndExpr ) import GHC.Core.Ppr import GHC.Hs.Extension ( GhcRn ) @@ -1418,18 +1418,22 @@ tcIfaceRule (IfaceRule {ifRuleName = name, ifActivation = act, ifRuleBndrs = bnd (emptyBag, errs) } ; return (bndrs', args', rhs') } ; let mb_tcs = map ifTopFreeName args + (bndrs_occ, rhs_occ) = occurAnalyseBndrsAndExpr bndrs' rhs' + -- See Note [OccInfo in unfoldings and rules] ; this_mod <- getIfModule - ; return (Rule { ru_name = name, ru_fn = fn, - ru_act = act, - ru_bndrs = bndrs', ru_args = args', - ru_rhs = occurAnalyseExpr rhs', - ru_rough = mb_tcs, - ru_origin = this_mod, - ru_orphan = orph, - ru_auto = auto, - ru_local = False }) } -- An imported RULE is never for a local Id - -- or, even if it is (module loop, perhaps) - -- we'll just leave it in the non-local set + ; return (Rule { ru_name = name + , ru_fn = fn + , ru_act = act + , ru_bndrs = bndrs_occ + , ru_args = args' + , ru_rhs = rhs_occ + , ru_rough = mb_tcs + , ru_origin = this_mod + , ru_orphan = orph + , ru_auto = auto + , ru_local = False }) } + -- ru_local=False: an imported RULE is never for a local Id or, even if + -- it is (module loop, perhaps) we'll just leave it in the non-local set where -- This function *must* mirror exactly what Rules.roughTopNames does -- We could have stored the ru_rough field in the iface file View it on GitLab: https://gitlab.haskell.org/ghc/ghc/-/commit/27d8694fc3cbecf96dc78924ecfac515... -- View it on GitLab: https://gitlab.haskell.org/ghc/ghc/-/commit/27d8694fc3cbecf96dc78924ecfac515... You're receiving this email because of your account on gitlab.haskell.org.