Adam Gundry pushed to branch wip/amg/castz at Glasgow Haskell Compiler / GHC Commits: 07ad307e by Adam Gundry at 2025-11-26T13:27:55+00:00 Fix a bug in pushCastCoValArg - - - - - 23014618 by Adam Gundry at 2025-11-26T13:28:34+00:00 Avoid potentially unnecessary work in simplCastCoercion - - - - - a2676c3d by Adam Gundry at 2025-11-26T13:55:32+00:00 Rethink simplCastCoercion - - - - - be7015a8 by Adam Gundry at 2025-11-26T15:20:23+00:00 Make pushCoDataCon not ignore ZCoercion entirely - - - - - bbf23b12 by Adam Gundry at 2025-11-26T15:28:32+00:00 Do better in pushCastCoTyArg - - - - - 5 changed files: - compiler/GHC/Core/Coercion.hs - compiler/GHC/Core/Coercion/Opt.hs - compiler/GHC/Core/Opt/Arity.hs - compiler/GHC/Core/Opt/Simplify/Iteration.hs - compiler/GHC/Core/SimpleOpt.hs Changes: ===================================== compiler/GHC/Core/Coercion.hs ===================================== @@ -64,6 +64,7 @@ module GHC.Core.Coercion ( mkForAllCastCo, mkFunResCastCo, mkFunCastCoNoFTF, + applyForAllTy, -- ** Decomposition instNewTyCon_maybe, @@ -1386,6 +1387,18 @@ mkInstCo co_fun co_arg substCo subst body_co mkInstCo co arg = InstCo co arg +-- Given @tyR = forall tcv . body_ty@, produces @body_ty[arg/tcv]@ +-- AMG TODO: surely this must exist somewhere already? +applyForAllTy :: Type -> Type -> Type +applyForAllTy tyR arg = + let (tcv, body_ty) = splitForAllTyCoVar tyR + in_scope = mkInScopeSet $ + tyCoVarsOfType arg `unionVarSet` tyCoVarsOfType body_ty + subst = extendTCvSubst (mkEmptySubst in_scope) tcv arg + in substTy subst body_ty + + + -- | Given @ty :: k1@, @co :: k1 ~ k2@, -- produces @co' :: ty ~r (ty |> co)@ mkGReflRightCo :: Role -> Type -> KindCoercion -> Coercion ===================================== compiler/GHC/Core/Coercion/Opt.hs ===================================== @@ -170,12 +170,14 @@ newtype OptCoercionOpts = OptCoercionOpts { optCoercionEnabled :: Bool -- ^ Enable coercion optimisation (reduce its size) } -optCastCoercion :: OptCoercionOpts -> Subst -> Type -> CastCoercion -> CastCoercion -optCastCoercion _ _ _ ReflCastCo = ReflCastCo -optCastCoercion opts env _ (CCoercion co) = CCoercion (optCoercion opts env co) +-- AMG TODO: not clear if coercionLKind or substTy is better choice here +optCastCoercion :: OptCoercionOpts -> Subst -> Type -> CastCoercion -> (Type, CastCoercion) +optCastCoercion _ env tyL ReflCastCo = (substTy env tyL, ReflCastCo) +optCastCoercion opts env _ (CCoercion co) = let co' = optCoercion opts env co + in (coercionLKind co', CCoercion co') optCastCoercion _ env tyL (ZCoercion tyR cos) - | tyL `eqTypeIgnoringMultiplicity` tyR = ReflCastCo - | otherwise = ZCoercion (substTy env tyR) (substCoVarSet env cos) + | tyL `eqTypeIgnoringMultiplicity` tyR = (substTy env tyL, ReflCastCo) + | otherwise = (substTy env tyL, ZCoercion (substTy env tyR) (substCoVarSet env cos)) optCoercion :: OptCoercionOpts -> Subst -> Coercion -> NormalCo -- ^ optCoercion applies a substitution to a coercion, ===================================== compiler/GHC/Core/Opt/Arity.hs ===================================== @@ -56,6 +56,7 @@ import GHC.Core.DataCon import GHC.Core.TyCon ( TyCon, tyConArity, isInjectiveTyCon ) import GHC.Core.TyCon.RecWalk ( initRecTc, checkRecTc ) import GHC.Core.Predicate ( isDictTy, isEvId, isCallStackPredTy, isCallStackTy ) +import GHC.Core.Make import GHC.Core.Multiplicity -- We have two sorts of substitution: @@ -2890,7 +2891,7 @@ pushCoArg :: Type -> CastCoercion -> CoreArg -> Maybe (CoreArg, Type, CastCoerci -- 'co' is always Representational pushCoArg fun_ty co arg | Type ty <- arg - = do { (ty', ty, m_co') <- pushCastCoTyArg co ty + = do { (ty', ty, m_co') <- pushCastCoTyArg fun_ty co ty ; return (Type ty', ty, m_co') } | otherwise = do { (arg_ty, arg_mco, res_ty, m_co') <- pushCastCoValArg fun_ty co @@ -2900,10 +2901,13 @@ pushCoArg fun_ty co arg -- the argument coercion actually being ReflCo ; return (arg `mkCastCo` arg_mco', res_ty, m_co') } -pushCastCoTyArg :: CastCoercion -> Type -> Maybe (Type, Type, CastCoercion) -pushCastCoTyArg (CCoercion co) ty = pushCoTyArg co ty -pushCastCoTyArg ReflCastCo ty = Just (ty, error "TODO: asdasdad", ReflCastCo) -pushCastCoTyArg (ZCoercion _fun_ty _cos) _ty = Nothing -- TODO do better +pushCastCoTyArg :: Type -> CastCoercion -> Type -> Maybe (Type, Type, CastCoercion) +pushCastCoTyArg tyL ReflCastCo arg = Just (arg, applyForAllTy tyL arg, ReflCastCo) +pushCastCoTyArg _ (CCoercion co) arg = pushCoTyArg co arg +pushCastCoTyArg tyL cco@ZCoercion{} arg = pushCoTyArg co arg + where + co = castCoToCo tyL cco + pushCoTyArg :: CoercionR -> Type -> Maybe (Type, Type, CastCoercion) -- We have (fun |> co) @ty @@ -2948,10 +2952,11 @@ pushCastCoValArg tyL (ZCoercion tyR cos) | isFunTy tyL -- TODO: do we need to check this or can we assume it? , isFunTy tyR , typeHasFixedRuntimeRep new_arg_ty - = Just (funArgTy tyL, ZCoercion new_arg_ty cos, funResultTy tyL, ZCoercion (funResultTy tyR) cos) + = Just (old_arg_ty, ZCoercion new_arg_ty cos, funResultTy tyL, ZCoercion (funResultTy tyR) cos) | otherwise = Nothing where - new_arg_ty = funArgTy tyR + old_arg_ty = funArgTy tyR + new_arg_ty = funArgTy tyL -- | If @pushCoValArg co = Just (co_arg, co_res)@, then -- @@ -3049,7 +3054,13 @@ pushCoDataCon :: DataCon -> [CoreExpr] -> CastCoercion -- but the right-hand one might not be. (Though it usually will.) pushCoDataCon dc dc_args ReflCastCo = Just $! (push_dc_refl dc dc_args) pushCoDataCon dc dc_args (CCoercion co) = push_dc_gen dc dc_args co (coercionKind co) -pushCoDataCon _dc _dc_args (ZCoercion _ty _cos) = Nothing -- AMG TODO: pushCoDataCon +pushCoDataCon dc dc_args cco@(ZCoercion to_ty _) = + -- Generalising push_data_con to work for a CastCoercion instead of a + -- Coercion seems pretty difficult, so instead we fall back on castCoToCo. + push_dc_gen dc dc_args (castCoToCo from_ty cco) (Pair from_ty to_ty) + where + from_ty = exprType (mkCoreConApps dc dc_args) -- TODO: can we calculate from_ty more efficiently? + push_dc_refl :: DataCon -> [CoreExpr] -> (DataCon, [Type], [CoreExpr]) push_dc_refl dc dc_args ===================================== compiler/GHC/Core/Opt/Simplify/Iteration.hs ===================================== @@ -19,7 +19,6 @@ import GHC.Core.Opt.Simplify.Monad import GHC.Core.Opt.ConstantFold import GHC.Core.Type hiding ( substCo, substTy, substTyVar, extendTvSubst, extendCvSubst ) import GHC.Core.TyCo.Compare( eqType ) -import GHC.Core.TyCo.Subst ( substCoVarSet ) import GHC.Core.Opt.Simplify.Env import GHC.Core.Opt.Simplify.Inline import GHC.Core.Opt.Simplify.Utils @@ -55,7 +54,6 @@ import GHC.Types.Unique ( hasKey ) import GHC.Types.Basic import GHC.Types.Tickish import GHC.Types.Var ( isTyCoVar ) -import GHC.Types.Var.Set import GHC.Builtin.Types.Prim( realWorldStatePrimTy ) import GHC.Builtin.Names( runRWKey, seqHashKey ) @@ -1364,12 +1362,17 @@ simplCoercion env co opts = seOptCoercionOpts env simplCastCoercion :: SimplEnv -> InType -> InCastCoercion -> SimplM (OutType, OutCastCoercion) -simplCastCoercion env _ (CCoercion co) = (\co -> (coercionLKind co, CCoercion co)) <$> simplCoercion env co -simplCastCoercion env tyL (ZCoercion tyR cos) = (,) <$> simplType env tyL <*> (ZCoercion <$> simplType env tyR <*> simplCoVars env cos) -simplCastCoercion env tyL ReflCastCo = (,) <$> simplType env tyL <*> pure ReflCastCo - -simplCoVars :: SimplEnv -> CoVarSet -> SimplM CoVarSet -simplCoVars env covars = pure $ substCoVarSet (getTCvSubst env) covars +simplCastCoercion env ty co + = do { let (opt_ty, opt_co) | reSimplifying env = (substTy env ty, substCastCo subst co) + | otherwise = optCastCoercion opts subst ty co + -- If (reSimplifying env) is True we have already simplified + -- this coercion once, and we don't want do so again; doing + -- so repeatedly risks non-linear behaviour + -- See Note [Inline depth] in GHC.Core.Opt.Simplify.Env + ; seqCastCoercion opt_co `seq` return (opt_ty, opt_co) } + where + subst = getTCvSubst env + opts = seOptCoercionOpts env ----------------------------------- @@ -1678,7 +1681,7 @@ optOutCoercion :: SimplEnvIS -> Type -> OutCastCoercion -> Bool -> OutCastCoerci -- See Note [Avoid re-simplifying coercions] optOutCoercion env ty co already_optimised | already_optimised = co -- See Note [Avoid re-simplifying coercions] - | otherwise = optCastCoercion opts empty_subst ty co + | otherwise = snd $ optCastCoercion opts empty_subst ty co where empty_subst = mkEmptySubst (seInScope env) opts = seOptCoercionOpts env @@ -1710,7 +1713,7 @@ simplCast env body co0 cont0 -- See Note [Avoid re-simplifying coercions] addCoerce tyL co co_is_opt (ApplyToTy { sc_arg_ty = arg_ty, sc_cont = tail }) - | Just (arg_ty', res_ty, m_co') <- pushCastCoTyArg co arg_ty + | Just (arg_ty', res_ty, m_co') <- pushCastCoTyArg tyL co arg_ty = {-#SCC "addCoerce-pushCoTyArg" #-} do { tail' <- addCoerceM res_ty m_co' co_is_opt tail ; return (ApplyToTy { sc_arg_ty = arg_ty' ===================================== compiler/GHC/Core/SimpleOpt.hs ===================================== @@ -464,7 +464,7 @@ add_cast env tyL co1 as CastIt co2:rest -> CastIt (co1' `mkTransCastCo` co2):rest _ -> CastIt co1':as where - co1' = optCastCoercion (so_co_opts (soe_opts env)) (soe_subst env) tyL co1 + (_, co1') = optCastCoercion (so_co_opts (soe_opts env)) (soe_subst env) tyL co1 rebuild_app :: HasDebugCallStack => SimpleOptEnv -> OutExpr -> [SimpleContItem] -> OutExpr View it on GitLab: https://gitlab.haskell.org/ghc/ghc/-/compare/5afbb4f85765d55f475d2dcec868237... -- View it on GitLab: https://gitlab.haskell.org/ghc/ghc/-/compare/5afbb4f85765d55f475d2dcec868237... You're receiving this email because of your account on gitlab.haskell.org.