Adam Gundry pushed to branch wip/amg/castz at Glasgow Haskell Compiler / GHC Commits: f9292660 by Adam Gundry at 2025-11-25T14:43:11+00:00 Accept output change for prog-mhu002c - - - - - b5ebc105 by Adam Gundry at 2025-11-25T19:15:27+00:00 Fix forall visibility bugs - - - - - 6aa2899f by Adam Gundry at 2025-11-25T19:32:01+00:00 Optimise ZCoercion in simplifier - - - - - 5afbb4f8 by Adam Gundry at 2025-11-25T20:48:39+00:00 Experiment with heuristic so zonker zaps only large casts - - - - - 5 changed files: - compiler/GHC/Core/Coercion.hs - compiler/GHC/Core/Opt/Arity.hs - compiler/GHC/Core/Opt/Simplify/Iteration.hs - compiler/GHC/Tc/Zonk/Type.hs - testsuite/tests/ghci/prog-mhu002/prog-mhu002c.stdout Changes: ===================================== compiler/GHC/Core/Coercion.hs ===================================== @@ -984,12 +984,13 @@ mkForAllCo v visL visR kind_co co | otherwise = mk_forall_co v visL visR kind_co co -mkForAllCastCo :: HasDebugCallStack => TyCoVar -> ForAllTyFlag -> ForAllTyFlag - -> CastCoercion -> CastCoercion -mkForAllCastCo v visL visR cco = case cco of +mkForAllCastCo :: HasDebugCallStack => Role -> TyCoVar -> ForAllTyFlag -> ForAllTyFlag + -> Type -> CastCoercion -> CastCoercion +mkForAllCastCo r v visL visR ty cco = case cco of CCoercion co -> CCoercion (mkForAllCo v visL visR MRefl co) - ZCoercion ty cos -> ZCoercion (mkTyCoForAllTy v visL ty) cos - ReflCastCo -> ReflCastCo + ZCoercion ty cos -> ZCoercion (mkTyCoForAllTy v visR ty) cos + ReflCastCo | visL `eqForAllVis` visR -> ReflCastCo + | otherwise -> CCoercion (mk_forall_co v visL visR MRefl (mkReflCo r ty)) -- mkForAllVisCos [tv{vis}] constructs a cast -- forall tv. res ~R# forall tv{vis} res`. @@ -1816,7 +1817,7 @@ mkPiCastCo :: Role -> Var -> CastCoercion -> CastCoercion mkPiCastCo _ _ ReflCastCo = ReflCastCo mkPiCastCo r v (CCoercion co) = CCoercion (mkPiCo r v co) mkPiCastCo _ v (ZCoercion ty cos) - | isTyVar v = ZCoercion (mkForAllTy (Bndr v vis) ty) cos + | isTyVar v = ZCoercion (mkTyCoForAllTy v vis ty) cos | otherwise = ZCoercion (mkFunctionType (idMult v) (varType v) ty) cos where vis = coreTyLamForAllTyFlag ===================================== compiler/GHC/Core/Opt/Arity.hs ===================================== @@ -2359,12 +2359,12 @@ mkEtaWW orig_oss ppr_orig_expr in_scope orig_ty -- with an explicit lambda having a non-function type mkEtaForAllMCo :: ForAllTyBinder -> Type -> CastCoercion -> CastCoercion -mkEtaForAllMCo bdnr@(Bndr tcv vis) ty mco +mkEtaForAllMCo (Bndr tcv vis) ty mco = case mco of ReflCastCo | vis == coreTyLamForAllTyFlag -> ReflCastCo | otherwise -> mk_fco (mkRepReflCo ty) CCoercion co -> mk_fco co - ZCoercion tyR cos -> ZCoercion (mkForAllTy bdnr tyR) cos + ZCoercion tyR cos -> ZCoercion (mkTyCoForAllTy tcv coreTyLamForAllTyFlag tyR) cos where mk_fco co = CCoercion (mkForAllCo tcv vis coreTyLamForAllTyFlag MRefl co) -- coreTyLamForAllTyFlag: See Note [The EtaInfo mechanism], particularly @@ -2723,7 +2723,7 @@ tryEtaReduce rec_ids bndrs body eval_sd -- Float app ticks: \x -> Tick t (e x) ==> Tick t e go (b : bs) (App fun arg) co - | Just (co', ticks) <- ok_arg b arg co (exprType fun) + | Just (co', ticks) <- ok_arg b arg co (exprType fun) (exprType (App fun arg)) = fmap (flip (foldr mkTick) ticks) $ go bs fun co' -- Float arg ticks: \x -> e (Tick t x) ==> Tick t e @@ -2798,15 +2798,16 @@ tryEtaReduce rec_ids bndrs body eval_sd -> CastCoercion -- Of kind (t1~t2) -> Type -- Type (arg_t -> t1) of the function -- to which the argument is supplied + -> Type -- Type t1 of the result (AMG TODO: avoid needing to pass this?) -> Maybe (CastCoercion -- Of type (arg_t -> t1 ~ bndr_t -> t2) -- (and similarly for tyvars, coercion args) , [CoreTickish]) -- See Note [Eta reduction with casted arguments] - ok_arg bndr (Type arg_ty) co fun_ty + ok_arg bndr (Type arg_ty) co fun_ty res_ty | Just tv <- getTyVar_maybe arg_ty , bndr == tv = case splitForAllForAllTyBinder_maybe fun_ty of Just (Bndr _ vis, _) -> Just (fco, []) - where !fco = mkForAllCastCo tv vis coreTyLamForAllTyFlag co + where !fco = mkForAllCastCo Representational tv vis coreTyLamForAllTyFlag res_ty co -- The lambda we are eta-reducing always has visibility -- 'coreTyLamForAllTyFlag' which may or may not match -- the visibility on the inner function (#24014) @@ -2814,24 +2815,24 @@ tryEtaReduce rec_ids bndrs body eval_sd (text "fun:" <+> ppr bndr $$ text "arg:" <+> ppr arg_ty $$ text "fun_ty:" <+> ppr fun_ty) - ok_arg bndr (Var v) co fun_ty + ok_arg bndr (Var v) co fun_ty _ | bndr == v , let mult = idMult bndr , Just (_af, fun_mult, _, _) <- splitFunTy_maybe fun_ty , mult `eqType` fun_mult -- There is no change in multiplicity, otherwise we must abort = Just (mkFunResCastCo Representational bndr co, []) - ok_arg bndr (Cast e co_arg) co fun_ty + ok_arg bndr (Cast e co_arg) co fun_ty _ | (ticks, Var v) <- stripTicksTop tickishFloatable e , Just (_, fun_mult, _, res_ty) <- splitFunTy_maybe fun_ty , bndr == v , fun_mult `eqType` idMult bndr - = Just (mkFunCastCoNoFTF Representational fun_mult (castCoercionRKind (exprType e) co_arg) (mkSymCastCo (exprType e) co_arg) res_ty co, ticks) -- TODO check types + = Just (mkFunCastCoNoFTF Representational fun_mult (castCoercionRKind (exprType e) co_arg) (mkSymCastCo (exprType e) co_arg) res_ty co, ticks) -- The simplifier combines multiple casts into one, -- so we can have a simple-minded pattern match here - ok_arg bndr (Tick t arg) co fun_ty - | tickishFloatable t, Just (co', ticks) <- ok_arg bndr arg co fun_ty + ok_arg bndr (Tick t arg) co fun_ty res_ty + | tickishFloatable t, Just (co', ticks) <- ok_arg bndr arg co fun_ty res_ty = Just (co', t:ticks) - ok_arg _ _ _ _ = Nothing + ok_arg _ _ _ _ _ = Nothing -- | Can we eta-reduce the given function -- See Note [Eta reduction soundness], criteria (B), (J), and (W). ===================================== compiler/GHC/Core/Opt/Simplify/Iteration.hs ===================================== @@ -28,7 +28,7 @@ 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.Coercion.Opt ( optCoercion, optCastCoercion ) import GHC.Core.FamInstEnv ( FamInstEnv, topNormaliseType_maybe ) import GHC.Core.DataCon import GHC.Core.Opt.Stats ( Tick(..) ) @@ -1545,7 +1545,7 @@ rebuild_go env expr cont -> rebuild_go env (mkCastCo expr co') cont -- NB: mkCast implements the (Coercion co |> g) optimisation where - co' = optOutCastCoercion env co opt + co' = optOutCoercion env (exprType expr) co opt Select { sc_bndr = bndr, sc_alts = alts, sc_env = se, sc_cont = cont } -> rebuildCase (se `setInScopeFromE` env) expr bndr alts cont @@ -1674,17 +1674,11 @@ on each successive composition -- that's at least quadratic. So: -} -optOutCastCoercion :: SimplEnvIS -> OutCastCoercion -> Bool -> OutCastCoercion -optOutCastCoercion env cco already_optimised = case cco of - ReflCastCo -> ReflCastCo - CCoercion co -> CCoercion (optOutCoercion env co already_optimised) - ZCoercion{} -> cco - -optOutCoercion :: SimplEnvIS -> OutCoercion -> Bool -> OutCoercion +optOutCoercion :: SimplEnvIS -> Type -> OutCastCoercion -> Bool -> OutCastCoercion -- See Note [Avoid re-simplifying coercions] -optOutCoercion env co already_optimised +optOutCoercion env ty co already_optimised | already_optimised = co -- See Note [Avoid re-simplifying coercions] - | otherwise = optCoercion opts empty_subst co + | otherwise = optCastCoercion opts empty_subst ty co where empty_subst = mkEmptySubst (seInScope env) opts = seOptCoercionOpts env @@ -1732,7 +1726,7 @@ simplCast env body co0 cont0 , sc_dup = dup, sc_cont = tail , sc_hole_ty = fun_ty }) | not co_is_opt -- pushCoValArg duplicates the coercion, so optimise first - = addCoerce tyL (optOutCastCoercion (zapSubstEnv env) co co_is_opt) True cont + = addCoerce tyL (optOutCoercion (zapSubstEnv env) tyL co co_is_opt) True cont | Just (_, m_co1, res_ty, m_co2) <- pushCastCoValArg tyL co = {-#SCC "addCoerce-pushCoValArg" #-} @@ -3886,7 +3880,7 @@ mkDupableContWithDmds _ _ (Stop {}) = panic "mkDupableCont" -- Handled by pr mkDupableContWithDmds env dmds (CastIt { sc_co = co, sc_hole_ty = ty, sc_opt = opt, sc_cont = cont }) = do { (floats, cont') <- mkDupableContWithDmds env dmds cont - ; return (floats, CastIt { sc_co = optOutCastCoercion env co opt + ; return (floats, CastIt { sc_co = optOutCoercion env ty co opt , sc_hole_ty = ty , sc_opt = True, sc_cont = cont' }) } -- optOutCoercion: see Note [Avoid re-simplifying coercions] ===================================== compiler/GHC/Tc/Zonk/Type.hs ===================================== @@ -1862,9 +1862,10 @@ zonkEvTerm (EvExpr e) = EvExpr <$> zonkCoreExpr e zonkEvTerm (EvCastExpr e (CCoercion co) co_res_ty) = do { zap_casts <- hasZapCasts <$> lift getDynFlags - ; co_res_ty' <- zonkTcTypeToTypeX co_res_ty - ; if zap_casts - then EvCastExpr <$> zonkCoreExpr e <*> (ZCoercion co_res_ty' <$> zonkShallowCoVarsOfCo co) <*> pure co_res_ty' + ; if zap_casts && coercionSize co > typeSize co_res_ty -- AMG TODO: experimental heuristic + then do { co_res_ty' <- zonkTcTypeToTypeX co_res_ty + ; EvCastExpr <$> zonkCoreExpr e <*> (ZCoercion co_res_ty' <$> zonkShallowCoVarsOfCo co) <*> pure co_res_ty' + } else EvExpr <$> zonkCoreExpr (Cast e (CCoercion co)) } zonkEvTerm ev@(EvCastExpr _ (ZCoercion{}) _) ===================================== testsuite/tests/ghci/prog-mhu002/prog-mhu002c.stdout ===================================== @@ -15,6 +15,7 @@ other dynamic, non-language, flag settings: -fshow-warning-groups -fprefer-byte-code -fbreak-points + -fno-zap-casts warning settings: -Wpattern-namespace-specifier === :set @@ -34,6 +35,7 @@ other dynamic, non-language, flag settings: -fshow-warning-groups -fprefer-byte-code -fbreak-points + -fno-zap-casts warning settings: -Wpattern-namespace-specifier Unit ID: b-0.0.0 @@ -51,6 +53,7 @@ other dynamic, non-language, flag settings: -fshow-warning-groups -fprefer-byte-code -fbreak-points + -fno-zap-casts warning settings: -Wpattern-namespace-specifier Unit ID: c-0.0.0 @@ -68,6 +71,7 @@ other dynamic, non-language, flag settings: -fshow-warning-groups -fprefer-byte-code -fbreak-points + -fno-zap-casts warning settings: -Wpattern-namespace-specifier Unit ID: d-0.0.0 @@ -85,5 +89,6 @@ other dynamic, non-language, flag settings: -fshow-warning-groups -fprefer-byte-code -fbreak-points + -fno-zap-casts warning settings: -Wpattern-namespace-specifier View it on GitLab: https://gitlab.haskell.org/ghc/ghc/-/compare/307ee28a3679bfdece77c6868a7da89... -- View it on GitLab: https://gitlab.haskell.org/ghc/ghc/-/compare/307ee28a3679bfdece77c6868a7da89... You're receiving this email because of your account on gitlab.haskell.org.