Simon Peyton Jones pushed to branch wip/T26989 at Glasgow Haskell Compiler / GHC Commits: 9bbd56e8 by Simon Peyton Jones at 2026-04-27T23:54:56+01:00 Wibbles - - - - - 4 changed files: - compiler/GHC/Core/Coercion.hs - compiler/GHC/Core/Opt/Arity.hs - compiler/GHC/Core/Opt/Simplify/Iteration.hs - compiler/GHC/Core/Opt/Simplify/Utils.hs Changes: ===================================== compiler/GHC/Core/Coercion.hs ===================================== @@ -426,7 +426,8 @@ decomposeFunCo :: HasDebugCallStack decomposeFunCo (FunCo { fco_mult = w, fco_arg = co1, fco_res = co2 }) = (w, co1, co2) - -- Short-circuits the calls to mkSelCo + -- Fast path that short-circuits the calls to mkSelCo, + -- even though they would give the exact same answers decomposeFunCo co = assertPpr all_ok (ppr co) $ ===================================== compiler/GHC/Core/Opt/Arity.hs ===================================== @@ -2691,10 +2691,11 @@ same fix. -- | `tryEtaReduce [x,y,z] e sd` returns `Just e'` if `\x y z -> e` is evaluated -- according to `sd` and can soundly and gainfully be eta-reduced to `e'`. --- See Note [Eta reduction soundness] --- and Note [Eta reduction makes sense] when that is the case. tryEtaReduce :: UnVarSet -> [Var] -> CoreExpr -> SubDemand -> Maybe CoreExpr -- Return an expression equal to (\bndrs. body) +-- See Note [Eta reduction soundness] +-- and Note [Eta reduction makes sense] when that is the case. +-- and Note [Eta reduction based on evaluation context] for the `eval_sd` arg tryEtaReduce rec_ids bndrs body eval_sd = go (reverse bndrs) body (mkRepReflCo (exprType body)) where ===================================== compiler/GHC/Core/Opt/Simplify/Iteration.hs ===================================== @@ -1729,10 +1729,15 @@ optOutCoercion env co already_optimised opts = seOptCoercionOpts env addCastMCo :: MOutCoercion -> SimplCont -> SimplCont --- Simpler version of `pushCast` when optionally want to add a cast to the top +-- Simpler, non-monadic version of pushCastMCo when we are certain that +-- the cast should be at the top; i.e. cont is Stop or StrictArg addCastMCo MRefl cont = cont addCastMCo (MCo co) cont = CastIt { sc_co = co, sc_opt = False, sc_cont = cont } +pushCastMCo :: SimplEnv -> MOutCoercion -> SimplCont -> SimplM SimplCont +pushCastMCo _env MRefl cont = return cont +pushCastMCo env (MCo co) cont = pushCast env co cont + pushCast :: SimplEnv -> OutCoercion -> SimplCont -> SimplM SimplCont pushCast env co cont = go co True cont @@ -1753,7 +1758,7 @@ pushCast env co cont -- NB! As the cast goes past, the -- type of the hole changes (#16312) - -- (f |> co) e ===> (f (e |> co1)) |> co2 + -- (f |> co) arg ===> (f (arg |> co1)) |> co2 -- where co :: (s1->s2) ~ (t1->t2) -- co1 :: t1 ~ s1 -- co2 :: s2 ~ t2 @@ -1763,12 +1768,14 @@ pushCast env co cont = -- pushCoValArg duplicates the coercion, so optimise first go (optOutCoercion (zapSubstEnv env) co co_is_opt) True cont +-- ToDo: return coercionLKind. And similarly pushCoTyArg + | Just (m_co1, m_co2) <- pushCoValArg co = {-#SCC "addCoerce-pushCoValArg" #-} do { tail' <- go_mco m_co2 co_is_opt tail ; return (ApplyToVal { sc_arg = arg , sc_env = arg_se - , sc_cast = m_co1 `mkTransMCo` arg_mco + , sc_cast = arg_mco `mkTransMCo` m_co1 , sc_cont = tail' , sc_hole_ty = coercionLKind co }) } @@ -1778,6 +1785,7 @@ pushCast env co cont -- See Note [Optimising reflexivity] | otherwise = return (CastIt { sc_co = co, sc_opt = co_is_opt, sc_cont = cont }) +-- ToDo: pushCast Refl (ApplylToVal arg1 (ApplyToVal arg2 ...)) will do lots of unnecessary work. -- If the first parameter is MRefl, then simplifying revealed a -- reflexive coercion. Omit. @@ -2295,7 +2303,8 @@ simplInId env var cont | otherwise = case substId env var of ContEx se e mco - -> simplExprF (se `setInScopeFromE` env) e (addCastMCo mco cont) + -> do { cont' <- pushCastMCo env mco cont + ; simplExprF (se `setInScopeFromE` env) e cont' } -- Don't trimJoinCont; haven't already simplified e, -- so the cont is not embodied in e @@ -2393,10 +2402,12 @@ simplOutId env fun cont _ -> do { s' <- newId (fsLit "s") ManyTy realWorldStatePrimTy ; let (m,_,_) = splitFunTy fun_ty env' = arg_env `addNewInScopeIds` [s'] - cont' = addCastMCo arg_mco $ - ApplyToVal { sc_arg = Var s', sc_cast = MRefl - , sc_env = Simplified OkDup, sc_cont = inner_cont - , sc_hole_ty = mkVisFunTy m realWorldStatePrimTy new_runrw_res_ty } + hole_ty = mkVisFunTy m realWorldStatePrimTy new_runrw_res_ty + ; cont' <- pushCastMCo env' arg_mco $ + ApplyToVal { sc_arg = Var s', sc_cast = MRefl + , sc_env = Simplified OkDup + , sc_cont = inner_cont + , sc_hole_ty = hole_ty } -- cont' applies to s', then K ; body' <- simplExprC env' arg cont' ; return (Lam s' body') } ===================================== compiler/GHC/Core/Opt/Simplify/Utils.hs ===================================== @@ -620,26 +620,33 @@ dropContArgs n cont = pprPanic "dropContArgs" (ppr n $$ ppr cont) -- For example, when simplifying the argument `e` in `f e` and `f` has the -- demand signature ``, this function will give you back `P(S,A)` when -- simplifying `e`. --- --- PRECONDITION: Don't call with 'ApplyToVal'. We haven't thoroughly thought --- about what to do then and no call sites so far seem to care. -contEvalContext :: SimplCont -> SubDemand -contEvalContext k = case k of - Stop _ _ sd -> sd - TickIt _ k -> contEvalContext k - CastIt { sc_cont = k } -> contEvalContext k - ApplyToTy{ sc_cont = k } -> contEvalContext k - -- ApplyToVal{sc_cont=k} -> mkCalledOnceDmd $ contEvalContext k +contEvalContext :: [Var] -> SimplCont -> SubDemand +contEvalContext bndrs cont = go cont + where + go (Stop _ _ sd) = sd + go (TickIt _ k) = go k + go (CastIt { sc_cont = k }) = go k + go (ApplyToTy{ sc_cont = k }) = go k + + -- The ApplyToVal case can actually happen, if we have + -- (CastIt co (ApplyToVal ..)) + -- Possible code: + -- go (ApplyToVal{sc_cont=k}) = mkCalledOnceDmd $ contEvalContext k -- Not 100% sure that's correct, . Here's an example: -- f (e x) and f :: -- then what is the evaluation context of 'e' when we simplify it? E.g., -- simpl e (ApplyToVal x $ Stop "C(S,C(1,L))") -- then it *should* be "C(1,C(S,C(1,L))", so perhaps correct after all. - -- But for now we just panic: - ApplyToVal{} -> pprPanic "contEvalContext" (ppr k) - StrictArg{sc_fun=fun_info} -> subDemandIfEvaluated (Partial.head (ai_dmds fun_info)) - StrictBind{sc_bndr=bndr} -> subDemandIfEvaluated (idDemandInfo bndr) - Select{} -> topSubDmd + -- But for now we just return topDmd. + go (ApplyToVal{ sc_arg = arg }) = warnPprTrace True "contEvalContext" + (vcat [ text "arg:" <+> ppr arg + , text "bndrs:" <+> ppr bndrs + , text "cont:" <+> ppr cont ]) + topSubDmd + + go (StrictArg{sc_fun=fun_info}) = subDemandIfEvaluated (Partial.head (ai_dmds fun_info)) + go (StrictBind{sc_bndr=bndr}) = subDemandIfEvaluated (idDemandInfo bndr) + go (Select{}) = topSubDmd -- Perhaps reconstruct the demand on the scrutinee by looking at field -- and case binder dmds, see addCaseBndrDmd. No priority right now. @@ -1957,9 +1964,7 @@ rebuildLam env bndrs@(bndr:_) body cont mb_rhs = contIsRhs cont -- See Note [Eta reduction based on evaluation context] - eval_sd = contEvalContext cont - -- NB: cont is never ApplyToVal, because beta-reduction would - -- have happened. So contEvalContext can panic on ApplyToVal. + eval_sd = contEvalContext bndrs cont try_eta :: [OutBndr] -> OutExpr -> SimplM OutExpr try_eta bndrs body View it on GitLab: https://gitlab.haskell.org/ghc/ghc/-/commit/9bbd56e8ba16b562d10b5b94d92dbc07... -- View it on GitLab: https://gitlab.haskell.org/ghc/ghc/-/commit/9bbd56e8ba16b562d10b5b94d92dbc07... You're receiving this email because of your account on gitlab.haskell.org.