Simon Peyton Jones pushed to branch wip/26543 at Glasgow Haskell Compiler / GHC Commits: 1dd5d86a by Simon Peyton Jones at 2025-12-11T13:49:57+00:00 Wibbles - - - - - 2 changed files: - compiler/GHC/Core/Opt/Simplify/Iteration.hs - compiler/GHC/Core/Opt/Simplify/Utils.hs Changes: ===================================== compiler/GHC/Core/Opt/Simplify/Iteration.hs ===================================== @@ -26,8 +26,8 @@ import GHC.Core.Opt.OccurAnal ( occurAnalyseExpr, zapLambdaBndrs, scrutOkForBind import GHC.Core.Make ( FloatBind, mkImpossibleExpr, castBottomExpr ) import qualified GHC.Core.Make import GHC.Core.Coercion hiding ( substCo, substCoVar ) -import GHC.Core.Reduction import GHC.Core.Coercion.Opt ( optCoercion ) +import GHC.Core.Reduction import GHC.Core.FamInstEnv ( FamInstEnv, topNormaliseType_maybe ) import GHC.Core.DataCon import GHC.Core.Opt.Stats ( Tick(..) ) @@ -35,8 +35,7 @@ import GHC.Core.Unfold import GHC.Core.Unfold.Make import GHC.Core.Utils import GHC.Core.Opt.Arity ( ArityType, exprArity, arityTypeBotSigs_maybe - , pushCoTyArg, pushCoValArg, exprIsDeadEnd - , typeArity, arityTypeArity, etaExpandAT ) + , exprIsDeadEnd, typeArity, arityTypeArity, etaExpandAT ) import GHC.Core.SimpleOpt ( exprIsConApp_maybe, joinPointBinding_maybe, joinPointBindings_maybe ) import GHC.Core.FVs ( mkRuleInfo {- exprsFreeIds -} ) import GHC.Core.Rules ( lookupRule, getRules ) @@ -1676,70 +1675,12 @@ optOutCoercion env co already_optimised 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 + = do { co1 <- {-#SCC "simplCast-simplCoercion" #-} simplCoercion env co0 + ; let cont1 = {-#SCC "simplCast-addCoerce" #-} + pushCastCont env co1 True cont0 -- True <=> co1 is optimised - ; {-#SCC "simplCast-simplExprF" #-} simplExprF env body cont1 } - where - - -- 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_clo - , sc_dup = dup, sc_cont = tail }) - | 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 { 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 }) } } } - - 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 }) + ; {-#SCC "simplCast-simplExprF" #-} simplExprF env body cont1 } {- ************************************************************************ @@ -1870,7 +1811,7 @@ simplNonRecE env from_what bndr (ContEx rhs_se rhs mco) body cont is_strict_bind = -- Evaluate RHS strictly simplExprF (rhs_se `setInScopeFromE` env) rhs - (pushCastCont mco $ + (pushCastMCont env mco True $ StrictBind { sc_bndr = bndr, sc_body = body, sc_from = from_what , sc_env = env, sc_cont = cont, sc_dup = NoDup }) @@ -2226,7 +2167,7 @@ simplClo :: SimplEnv simplClo env clo cont = case clo of ContEx se e mco -> simplExprF (se `setInScopeFromE` env) e $ - pushCastCont mco cont + pushCastMCont env mco True cont -- Don't trimJoinCont; we haven't already simplified e, -- so the cont is not embodied in e @@ -2247,7 +2188,7 @@ simplCloArg :: SimplEnvIS -- ^ Used only for its InScopeSet -> SimplClo -> SimplM OutExpr simplCloArg env fun_ty mb_arg_info (ContEx arg_se arg mco) - = simplExprC arg_env arg (pushCastCont mco stop) + = simplExprC arg_env arg (pushCastMCont env mco True stop) where arg_env = arg_se `setInScopeFromE` env arg_ty = funArgTy fun_ty @@ -2393,7 +2334,7 @@ rebuildCall env 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 - (pushCastCont mco $ + (pushCastMCont env mco True $ StrictArg { sc_fun = fun_info, sc_fun_ty = fun_ty , sc_dup = NoDup, sc_cont = cont }) -- Note [Shadowing in the Simplifier] ===================================== compiler/GHC/Core/Opt/Simplify/Utils.hs ===================================== @@ -29,7 +29,7 @@ module GHC.Core.Opt.Simplify.Utils ( contIsTrivial, contArgs, contIsRhs, countArgs, contOutArgs, dropContArgs, mkBoringStop, mkRhsStop, mkLazyArgStop, - interestingCallContext, pushCastCont, + interestingCallContext, pushCastCont, pushCastMCont, -- ArgInfo ArgInfo(..), ArgSpec(..), mkArgInfo, @@ -63,6 +63,7 @@ import GHC.Core.Unfold.Make import GHC.Core.Opt.Simplify.Monad import GHC.Core.Type hiding( substTy ) import GHC.Core.Coercion hiding( substCo ) +import GHC.Core.Coercion.Opt ( optCoercion ) import GHC.Core.DataCon ( dataConWorkId, isNullaryRepDataCon ) import GHC.Core.Multiplicity import GHC.Core.Opt.ConstantFold @@ -415,11 +416,6 @@ mkLazyArgStop ty fun_info = Stop ty (lazyArgContext fun_info) arg_sd where arg_sd = subDemandIfEvaluated (Partial.head (ai_dmds fun_info)) -pushCastCont :: MOutCoercion -> SimplCont -> SimplCont --- Assumes the MOutCoercion is optimised -pushCastCont MRefl cont = cont -pushCastCont (MCo co) cont = CastIt { sc_co = co, sc_opt = True, sc_cont = cont } - ------------------- contIsRhs :: SimplCont -> Maybe RecFlag contIsRhs (Stop _ (RhsCtxt is_rec) _) = Just is_rec @@ -704,6 +700,63 @@ make use of the strictness info for the function. -} +{- ********************************************************************* +* * + Pushing a cast onto a continuation +* * +********************************************************************* -} + +pushCastMCont :: SimplEnvIS -> MOutCoercion -> Bool -> SimplCont -> SimplCont +-- Bool = True <=> the coercion is already optimised +pushCastMCont _ MRefl _ cont = cont +pushCastMCont env (MCo co) opt cont = pushCastCont env co opt cont + +pushCastCont :: SimplEnvIS -> OutCoercion -> Bool -> SimplCont -> SimplCont +pushCastCont _env co _opt cont + | isReflCo co -- isReflCo is cheap + = cont -- Having this test made a huge difference in T12227, for some reason + -- See Note [Optimising reflexivity] + +pushCastCont env co _opt (CastIt { sc_co = co2, sc_cont = cont }) -- See Note [Optimising reflexivity] + = pushCastCont env (mkTransCo co co2) False cont + -- False: (mkTransCo co co2) is not fully optimised + -- See Note [Avoid re-simplifying coercions] + +pushCastCont env co opt (ApplyToTy { sc_arg_ty = arg_ty, sc_cont = tail }) + | Just (arg_ty', m_co') <- pushCoTyArg co arg_ty + = {-#SCC "addCoerce-pushCoTyArg" #-} + ApplyToTy { sc_arg_ty = arg_ty' + , sc_hole_ty = coercionLKind co + , sc_cont = pushCastMCont env m_co' opt tail } + -- sc_hole_ty: As the cast goes past, the hole type changes (#16312) + +pushCastCont env co opt cont@(ApplyToVal {}) + | not opt -- pushCoValArg duplicates the coercion, so optimise first + = pushCastCont env (optCoercion opts empty_subst co) True cont + where + empty_subst = mkEmptySubst (seInScope env) + opts = seOptCoercionOpts env + +pushCastCont env co _opt (ApplyToVal { sc_arg = clo, sc_dup = dup, sc_cont = tail }) + | Just (m_co1, m_co2) <- pushCoValArg co + = -- (f |> co) e ===> (f (e |> co1)) |> co2 + -- where co :: (s1->s2) ~ (t1->t2) + -- co1 :: t1 ~ s1 + -- co2 :: s2 ~ t2 + ApplyToVal { sc_arg = mkCloCastMCo clo m_co1 + , sc_dup = dup + , sc_hole_ty = coercionLKind co + , sc_cont = pushCastMCont env m_co2 True tail } + +pushCastCont _env co opt cont + = CastIt { sc_co = co, sc_opt = opt, sc_cont = cont } + +mkCloCastMCo :: SimplClo -> MOutCoercion -> SimplClo +mkCloCastMCo clo MRefl = clo +mkCloCastMCo (DoneId v) (MCo co) = DoneEx (Cast (Var v) co) NotJoinPoint +mkCloCastMCo (DoneEx e _jp) (MCo co) = DoneEx (Cast e co) NotJoinPoint +mkCloCastMCo (ContEx se e mco) (MCo co) = ContEx se e (mkTransMCoL mco co) + {- ************************************************************************ * * @@ -1859,7 +1912,9 @@ rebuildLam _env [] body _cont = return body rebuildLam env bndrs@(bndr:_) body cont - = {-# SCC "rebuildLam" #-} try_eta bndrs body + = {-# SCC "rebuildLam" #-} + do { traceSmpl "rebuildLam" (ppr bndrs $$ ppr cont) + ; try_eta bndrs body } where rec_ids = seRecIds env in_scope = getInScope env -- Includes 'bndrs' View it on GitLab: https://gitlab.haskell.org/ghc/ghc/-/commit/1dd5d86a6d9b33d2f7507d0ec074cba7... -- View it on GitLab: https://gitlab.haskell.org/ghc/ghc/-/commit/1dd5d86a6d9b33d2f7507d0ec074cba7... You're receiving this email because of your account on gitlab.haskell.org.