Adam Gundry pushed to branch wip/amg/castz at Glasgow Haskell Compiler / GHC Commits: f56deed3 by Adam Gundry at 2025-11-21T16:15:28+00:00 Remove castCoToCo calls from collectBindersPushingCo - - - - - c49a9fc0 by Adam Gundry at 2025-11-22T20:47:54+00:00 Pass type argument to castCoercionRKind - - - - - 43867efa by Adam Gundry at 2025-11-22T21:05:08+00:00 Add ReflCastCo - - - - - 22 changed files: - compiler/GHC/Core/Coercion.hs - compiler/GHC/Core/FVs.hs - compiler/GHC/Core/Map/Expr.hs - compiler/GHC/Core/Map/Type.hs - compiler/GHC/Core/Opt/Arity.hs - compiler/GHC/Core/Opt/CprAnal.hs - compiler/GHC/Core/Opt/DmdAnal.hs - compiler/GHC/Core/Opt/SpecConstr.hs - compiler/GHC/Core/Ppr.hs - compiler/GHC/Core/TyCo/FVs.hs - compiler/GHC/Core/TyCo/Ppr.hs - compiler/GHC/Core/TyCo/Rep.hs - compiler/GHC/Core/TyCo/Subst.hs - compiler/GHC/Core/TyCo/Tidy.hs - compiler/GHC/Core/Utils.hs - compiler/GHC/CoreToIface.hs - compiler/GHC/Iface/Rename.hs - compiler/GHC/Iface/Syntax.hs - compiler/GHC/Iface/Type.hs - compiler/GHC/IfaceToCore.hs - compiler/GHC/Tc/Types/Evidence.hs - compiler/GHC/Tc/Zonk/Type.hs Changes: ===================================== compiler/GHC/Core/Coercion.hs ===================================== @@ -2452,6 +2452,7 @@ seqMCo (MCo co) = seqCo co seqCastCoercion :: CastCoercion -> () seqCastCoercion (CCoercion co) = seqCo co seqCastCoercion (ZCoercion ty cos) = seqType ty `seq` seqVarSet cos +seqCastCoercion ReflCastCo = () seqCo :: Coercion -> () seqCo (Refl ty) = seqType ty @@ -2874,45 +2875,56 @@ See Note [Zapped casts] in GHC.Core.TyCo.Rep. castCoercionLKind :: HasDebugCallStack => Type -> CastCoercion -> Type castCoercionLKind _ (CCoercion co) = coercionLKind co castCoercionLKind lhs_ty (ZCoercion _ _) = lhs_ty +castCoercionLKind lhs_ty ReflCastCo = lhs_ty -- | Compute the right type of a 'CastCoercion', like 'coercionRKind'. -castCoercionRKind :: HasDebugCallStack => CastCoercion -> Type -castCoercionRKind (CCoercion co) = coercionRKind co -castCoercionRKind (ZCoercion ty _) = ty +-- Corresponds to 'coercionRKind', but requires the type to be supplied by the +-- caller because it cannot be recovered in the 'ReflCastCo' case. +castCoercionRKind :: HasDebugCallStack => Type -> CastCoercion -> Type +castCoercionRKind _ (CCoercion co) = coercionRKind co +castCoercionRKind _ (ZCoercion rhs_ty _) = rhs_ty +castCoercionRKind lhs_ty ReflCastCo = lhs_ty -- | Equality test on 'CastCoercion', where the LHS type is the same for both -- coercions, so we merely need to compare the RHS types. -eqCastCoercion :: CastCoercion -> CastCoercion -> Bool -eqCastCoercion cco1 cco2 = castCoercionRKind cco1 `eqType` castCoercionRKind cco2 +eqCastCoercion :: Type -> CastCoercion -> CastCoercion -> Bool +eqCastCoercion _ ReflCastCo ReflCastCo = True +eqCastCoercion lhs_ty cco1 cco2 = castCoercionRKind lhs_ty cco1 `eqType` castCoercionRKind lhs_ty cco2 -eqCastCoercionX :: RnEnv2 -> CastCoercion -> CastCoercion -> Bool -eqCastCoercionX env = eqTypeX env `on` castCoercionRKind +eqCastCoercionX :: RnEnv2 -> Type -> CastCoercion -> Type -> CastCoercion -> Bool +eqCastCoercionX _ _ ReflCastCo _ ReflCastCo = True +eqCastCoercionX env ty1 co1 ty2 co2 = eqTypeX env ty1 ty2 + && eqTypeX env (castCoercionRKind ty1 co1) (castCoercionRKind ty2 co2) -- | Convert a 'CastCoercion' back into a 'Coercion', using a 'UnivCo' if we -- have discarded the original 'Coercion'. castCoToCo :: Type -> CastCoercion -> CoercionR castCoToCo _ (CCoercion co) = co castCoToCo lhs_ty (ZCoercion rhs_ty cos) = mkUnivCo ZCoercionProv (map CoVarCo (nonDetEltsUniqSet cos)) Representational lhs_ty rhs_ty +castCoToCo lhs_ty ReflCastCo = mkRepReflCo lhs_ty -- | Compose two 'CastCoercion's transitively, like 'mkTransCo'. If either is -- zapped the whole result will be zapped. mkTransCastCo :: HasDebugCallStack => CastCoercion -> CastCoercion -> CastCoercion mkTransCastCo cco (CCoercion co) = mkTransCastCoCo cco co mkTransCastCo cco (ZCoercion ty cos) = ZCoercion ty (shallowCoVarsOfCastCo cco `unionVarSet` cos) +mkTransCastCo cco ReflCastCo = cco -- | Transitively compose a 'CastCoercion' followed by a 'Coercion'. mkTransCastCoCo :: HasDebugCallStack => CastCoercion -> Coercion -> CastCoercion mkTransCastCoCo (CCoercion co1) co2 = CCoercion (mkTransCo co1 co2) mkTransCastCoCo (ZCoercion _ cos) co2 = ZCoercion (coercionRKind co2) (shallowCoVarsOfCo co2 `unionVarSet` cos) +mkTransCastCoCo ReflCastCo co2 = CCoercion co2 -- | Transitively compose a 'Coercion' followed by a 'CastCoercion'. mkTransCoCastCo :: HasDebugCallStack => Coercion -> CastCoercion -> CastCoercion mkTransCoCastCo co1 (CCoercion co2) = CCoercion (mkTransCo co1 co2) mkTransCoCastCo co1 (ZCoercion ty cos) = ZCoercion ty (shallowCoVarsOfCo co1 `unionVarSet` cos) +mkTransCoCastCo co1 ReflCastCo = CCoercion co1 -- | Slowly checks if the coercion is reflexive. Don't call this in a loop, -- as it walks over the entire coercion. isReflexiveCastCo :: Type -> CastCoercion -> Bool isReflexiveCastCo _ (CCoercion co) = isReflexiveCo co isReflexiveCastCo lhs_ty (ZCoercion rhs_ty _) = lhs_ty `eqType` rhs_ty - +isReflexiveCastCo _ ReflCastCo = True ===================================== compiler/GHC/Core/FVs.hs ===================================== @@ -280,6 +280,7 @@ exprFVs (Let (Rec pairs) body) fv_cand in_scope acc cast_co_fvs :: CastCoercion -> FV cast_co_fvs (CCoercion co) fv_cand in_scope acc = (tyCoFVsOfCo co) fv_cand in_scope acc cast_co_fvs (ZCoercion ty cos) fv_cand in_scope acc = (tyCoFVsOfType ty `unionFV` tyCoFVsOfCoVarSet cos) fv_cand in_scope acc +cast_co_fvs ReflCastCo _ _ acc = acc --------- rhs_fvs :: (Id, CoreExpr) -> FV ===================================== compiler/GHC/Core/Map/Expr.hs ===================================== @@ -30,7 +30,9 @@ import GHC.Prelude import GHC.Data.TrieMap import GHC.Core.Map.Type import GHC.Core +import GHC.Core.Coercion import GHC.Core.Type +import GHC.Core.Utils import GHC.Types.Tickish import GHC.Types.Var @@ -159,7 +161,7 @@ eqDeBruijnExpr (D env1 e1) (D env2 e2) = go e1 e2 where go (Type t1) (Type t2) = eqDeBruijnType (D env1 t1) (D env2 t2) -- See Note [Alpha-equality for Coercion arguments] go (Coercion {}) (Coercion {}) = True - go (Cast e1 co1) (Cast e2 co2) = D env1 co1 == D env2 co2 && go e1 e2 + go (Cast e1 co1) (Cast e2 co2) = D env1 (castCoercionRKind (exprType e1) co1) == D env2 (castCoercionRKind (exprType e2) co2) && go e1 e2 go (App f1 a1) (App f2 a2) = go f1 f2 && go a1 a2 go (Tick n1 e1) (Tick n2 e2) = eqDeBruijnTickish (D env1 n1) (D env2 n2) @@ -343,7 +345,7 @@ lkE (D env expr) cm = go expr cm go (Lit l) = cm_lit >.> lookupTM l go (Type t) = cm_type >.> lkG (D env t) go (Coercion c) = cm_co >.> lkG (D env c) - go (Cast e c) = cm_cast >.> lkG (D env e) >=> lkG (D env c) + go (Cast e c) = cm_cast >.> lkG (D env e) >=> lkG (D env (castCoercionRKind (exprType e) c)) go (Tick tickish e) = cm_tick >.> lkG (D env e) >=> lkTickish tickish go (App e1 e2) = cm_app >.> lkG (D env e2) >=> lkG (D env e1) go (Lam v e) = cm_lam >.> lkG (D (extendCME env v) e) @@ -370,7 +372,7 @@ xtE (D env (Coercion c)) f m = m { cm_co = cm_co m |> xtG (D env c) f } xtE (D _ (Lit l)) f m = m { cm_lit = cm_lit m |> alterTM l f } xtE (D env (Cast e c)) f m = m { cm_cast = cm_cast m |> xtG (D env e) - |>> xtG (D env c) f } + |>> xtG (D env (castCoercionRKind (exprType e) c)) f } xtE (D env (Tick t e)) f m = m { cm_tick = cm_tick m |> xtG (D env e) |>> xtTickish t f } xtE (D env (App e1 e2)) f m = m { cm_app = cm_app m |> xtG (D env e2) ===================================== compiler/GHC/Core/Map/Type.hs ===================================== @@ -147,7 +147,7 @@ instance Functor CastCoercionMap where {-# INLINE fmap #-} instance TrieMap CastCoercionMap where - type Key CastCoercionMap = CastCoercion + type Key CastCoercionMap = Type emptyTM = CastCoercionMap emptyTM lookupTM k (CastCoercionMap m) = lookupTM (deBruijnize k) m alterTM k f (CastCoercionMap m) = CastCoercionMap (alterTM (deBruijnize k) f m) @@ -164,7 +164,7 @@ instance Functor CastCoercionMapX where {-# INLINE fmap #-} instance TrieMap CastCoercionMapX where - type Key CastCoercionMapX = DeBruijn CastCoercion + type Key CastCoercionMapX = DeBruijn Type emptyTM = CastCoercionMapX emptyTM lookupTM = lkX alterTM = xtX @@ -172,18 +172,12 @@ instance TrieMap CastCoercionMapX where filterTM f (CastCoercionMapX core_tm) = CastCoercionMapX (filterTM f core_tm) mapMaybeTM f (CastCoercionMapX core_tm) = CastCoercionMapX (mapMaybeTM f core_tm) -instance Eq (DeBruijn CastCoercion) where - D env1 co1 == D env2 co2 - = D env1 (castCoercionRKind co1) == - D env2 (castCoercionRKind co2) - -lkX :: DeBruijn CastCoercion -> CastCoercionMapX a -> Maybe a -lkX (D env co) (CastCoercionMapX core_tm) = lkT (D env $ castCoercionRKind co) - core_tm +lkX :: DeBruijn Type -> CastCoercionMapX a -> Maybe a +lkX (D env co_ty) (CastCoercionMapX core_tm) = lkT (D env co_ty) core_tm -xtX :: DeBruijn CastCoercion -> XT a -> CastCoercionMapX a -> CastCoercionMapX a -xtX (D env co) f (CastCoercionMapX m) - = CastCoercionMapX (xtT (D env $ castCoercionRKind co) f m) +xtX :: DeBruijn Type -> XT a -> CastCoercionMapX a -> CastCoercionMapX a +xtX (D env co_ty) f (CastCoercionMapX m) + = CastCoercionMapX (xtT (D env co_ty) f m) {- ===================================== compiler/GHC/Core/Opt/Arity.hs ===================================== @@ -3119,27 +3119,28 @@ collectBindersPushingCo e go :: [Var] -> CoreExpr -> ([Var], CoreExpr) -- The accumulator is in reverse order go bs (Lam b e) = go (b:bs) e - go bs (Cast e co) = go_c bs e (castCoToCo (exprType e) co) -- TODO: can we do better? + go bs (Cast e co) = go_c bs e co go bs e = (reverse bs, e) -- We are in a cast; peel off casts until we hit a lambda. - go_c :: [Var] -> CoreExpr -> Coercion -> ([Var], CoreExpr) + go_c :: [Var] -> CoreExpr -> CastCoercion -> ([Var], CoreExpr) -- (go_c bs e c) is same as (go bs e (e |> c)) - go_c bs (Cast e co1) co2 = go_c bs e (castCoToCo (exprType e) co1 `mkTransCo` co2) -- TODO: can we do better? + go_c bs (Cast e co1) co2 = go_c bs e (co1 `mkTransCastCo` co2) go_c bs (Lam b e) co = go_lam bs b e co - go_c bs e co = (reverse bs, mkCast e co) + go_c bs e co = (reverse bs, mkCastCo e co) -- We are in a lambda under a cast; peel off lambdas and build a -- new coercion for the body. - go_lam :: [Var] -> Var -> CoreExpr -> CoercionR -> ([Var], CoreExpr) + go_lam :: [Var] -> Var -> CoreExpr -> CastCoercion -> ([Var], CoreExpr) -- (go_lam bs b e c) is same as (go_c bs (\b.e) c) - go_lam bs b e co + -- TODO: does it matter that ZCoercion will not do any of this? + go_lam bs b e (CCoercion co) | isTyVar b , let Pair tyL tyR = coercionKind co , assert (isForAllTy_ty tyL) $ isForAllTy_ty tyR , isReflCo (mkSelCo SelForAll co) -- See Note [collectBindersPushingCo] - = go_c (b:bs) e (mkInstCo co (mkNomReflCo (mkTyVarTy b))) + = go_c (b:bs) e (CCoercion (mkInstCo co (mkNomReflCo (mkTyVarTy b)))) | isCoVar b , let Pair tyL tyR = coercionKind co @@ -3147,7 +3148,7 @@ collectBindersPushingCo e isForAllTy_co tyR , isReflCo (mkSelCo SelForAll co) -- See Note [collectBindersPushingCo] , let cov = mkCoVarCo b - = go_c (b:bs) e (mkInstCo co (mkNomReflCo (mkCoercionTy cov))) + = go_c (b:bs) e (CCoercion (mkInstCo co (mkNomReflCo (mkCoercionTy cov)))) | isId b , let Pair tyL tyR = coercionKind co @@ -3155,9 +3156,9 @@ collectBindersPushingCo e , (co_mult, co_arg, co_res) <- decomposeFunCo co , isReflCo co_mult -- See Note [collectBindersPushingCo] , isReflCo co_arg -- See Note [collectBindersPushingCo] - = go_c (b:bs) e co_res + = go_c (b:bs) e (CCoercion co_res) - | otherwise = (reverse bs, mkCast (Lam b e) co) + go_lam bs b e cco = (reverse bs, mkCastCo (Lam b e) cco) {- Note [collectBindersPushingCo] ~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~ ===================================== compiler/GHC/Core/Opt/CprAnal.hs ===================================== @@ -224,9 +224,9 @@ cprAnal' env (Cast e co) where (cpr_ty, e') = cprAnal env e cpr_ty' - | cpr_ty == topCprType = topCprType -- cheap case first - | isRecNewTyConApp env (castCoercionRKind co) = topCprType -- See Note [CPR for recursive data constructors] - | otherwise = cpr_ty + | cpr_ty == topCprType = topCprType -- cheap case first + | isRecNewTyConApp env (castCoercionRKind (exprType e) co) = topCprType -- See Note [CPR for recursive data constructors] + | otherwise = cpr_ty cprAnal' env (Tick t e) = (cpr_ty, Tick t e') ===================================== compiler/GHC/Core/Opt/DmdAnal.hs ===================================== @@ -2331,6 +2331,7 @@ coercionDmdEnv co = coercionsDmdEnv [co] castCoercionDmdEnv :: CastCoercion -> DmdEnv castCoercionDmdEnv (CCoercion co) = coercionDmdEnv co castCoercionDmdEnv (ZCoercion _ cos) = coVarSetDmdEnv cos +castCoercionDmdEnv ReflCastCo = nopDmdEnv coercionsDmdEnv :: [Coercion] -> DmdEnv coercionsDmdEnv cos ===================================== compiler/GHC/Core/Opt/SpecConstr.hs ===================================== @@ -2693,7 +2693,7 @@ argToPat1 env in_scope val_env (Cast arg co) arg_occ arg_str else return (interesting, Cast arg' co, strict_args) } where - ty2 = castCoercionRKind co + ty2 = castCoercionRKind (exprType arg) co -- Check for a constructor application -- NB: this *precedes* the Var case, so that we catch nullary constrs ===================================== compiler/GHC/Core/Ppr.hs ===================================== @@ -173,6 +173,7 @@ noParens pp = pp pprOptCastCoercion :: CastCoercion -> SDoc pprOptCastCoercion (CCoercion co) = pprOptCo co pprOptCastCoercion (ZCoercion ty cos) = pprOptZappedCo ty cos +pprOptCastCoercion ReflCastCo = text "ReflCastCo" pprOptZappedCo :: Type -> CoVarSet -> SDoc pprOptZappedCo ty cos = sdocOption sdocSuppressCoercions $ \case ===================================== compiler/GHC/Core/TyCo/FVs.hs ===================================== @@ -316,6 +316,7 @@ runTyCoVars f = appEndoOS f emptyVarSet tyCoVarsOfCastCo :: CastCoercion -> TyCoVarSet tyCoVarsOfCastCo (CCoercion co) = coVarsOfCo co tyCoVarsOfCastCo (ZCoercion ty cos) = tyCoVarsOfType ty `unionVarSet` cos +tyCoVarsOfCastCo ReflCastCo = emptyVarSet tyCoVarsOfType :: Type -> TyCoVarSet -- The "deep" TyCoVars of the the type @@ -441,6 +442,7 @@ shallowCoVarsOfType ty = filterVarSet isCoVar $ shallowTyCoVarsOfType ty shallowCoVarsOfCastCo :: CastCoercion -> CoVarSet shallowCoVarsOfCastCo (CCoercion co) = shallowCoVarsOfCo co shallowCoVarsOfCastCo (ZCoercion ty cos) = shallowCoVarsOfType ty `unionVarSet` cos +shallowCoVarsOfCastCo ReflCastCo = emptyVarSet {- ********************************************************************* @@ -468,6 +470,7 @@ See #14880. coVarsOfCastCo :: CastCoercion -> CoVarSet coVarsOfCastCo (CCoercion co) = coVarsOfCo co coVarsOfCastCo (ZCoercion ty cos) = coVarsOfType ty `unionVarSet` cos -- TODO cos doesn't include deep, this isn't enough? +coVarsOfCastCo ReflCastCo = emptyVarSet -- See Note [Finding free coercion variables] coVarsOfType :: Type -> CoVarSet @@ -705,6 +708,7 @@ tyCoFVsOfMCo mco fv_cand in_scope acc tyCoFVsOfCastCoercion :: CastCoercion -> FV tyCoFVsOfCastCoercion (CCoercion co) = tyCoFVsOfCo co tyCoFVsOfCastCoercion (ZCoercion ty cos) = tyCoFVsOfType ty `unionFV` tyCoFVsOfCoVarSet cos +tyCoFVsOfCastCoercion ReflCastCo = mempty tyCoFVsOfCoVarSet :: CoVarSet -> FV tyCoFVsOfCoVarSet = nonDetStrictFoldVarSet (unionFV . tyCoFVsOfCoVar) emptyFV -- TODO better way? Nondeterminism? ===================================== compiler/GHC/Core/TyCo/Ppr.hs ===================================== @@ -142,6 +142,7 @@ pprCastCo co = getPprStyle $ \ sty -> pprIfaceCastCoercion (tidyToIfaceCastCoSty tidyToIfaceCastCoSty :: CastCoercion -> PprStyle -> IfaceCastCoercion tidyToIfaceCastCoSty (CCoercion co) sty = IfaceCCoercion (tidyToIfaceCoSty co sty) tidyToIfaceCastCoSty (ZCoercion ty cos) sty = IfaceZCoercion (tidyToIfaceType ty) (map (flip tidyToIfaceCoSty sty . CoVarCo) (nonDetEltsUniqSet cos)) -- TODO +tidyToIfaceCastCoSty ReflCastCo _ = IfaceReflCastCo tidyToIfaceCoSty :: Coercion -> PprStyle -> IfaceCoercion tidyToIfaceCoSty co sty ===================================== compiler/GHC/Core/TyCo/Rep.hs ===================================== @@ -904,7 +904,7 @@ type KindMCoercion = MCoercionN -- See Note [KindCoercion] data CastCoercion = CCoercion CoercionR -- Not zapped; the Coercion has Representational role | ZCoercion Type CoVarSet -- Zapped; stores only the RHS type and free CoVars - -- | ReflCastCo -- TODO + | ReflCastCo deriving Data.Data -- | A 'Coercion' is concrete evidence of the equality/convertibility @@ -2143,6 +2143,7 @@ typesSize tys = foldr ((+) . typeSize) 0 tys castCoercionSize :: CastCoercion -> Int castCoercionSize (CCoercion co) = coercionSize co castCoercionSize (ZCoercion ty cos) = typeSize ty + sizeVarSet cos +castCoercionSize ReflCastCo = 1 coercionSize :: Coercion -> Int coercionSize (Refl ty) = typeSize ty ===================================== compiler/GHC/Core/TyCo/Subst.hs ===================================== @@ -837,6 +837,7 @@ lookupTyVar (Subst _ _ tenv _) tv substCastCo :: HasDebugCallStack => Subst -> CastCoercion -> CastCoercion substCastCo subst (CCoercion co) = CCoercion (substCo subst co) substCastCo subst (ZCoercion ty cos) = ZCoercion (substTy subst ty) (substCoVarSet subst cos) +substCastCo _ ReflCastCo = ReflCastCo substCoVarSet :: HasDebugCallStack => Subst -> CoVarSet -> CoVarSet substCoVarSet subst = nonDetStrictFoldVarSet (unionVarSet . shallowCoVarsOfCo . substCoVar subst) emptyVarSet -- TODO better impl; determinism? ===================================== compiler/GHC/Core/TyCo/Tidy.hs ===================================== @@ -366,5 +366,6 @@ tidyCos :: TidyEnv -> [Coercion] -> [Coercion] tidyCos env = strictMap (tidyCo env) tidyCastCo :: TidyEnv -> CastCoercion -> CastCoercion -tidyCastCo env (CCoercion co) = CCoercion (tidyCo env co) +tidyCastCo env (CCoercion co) = CCoercion (tidyCo env co) tidyCastCo env (ZCoercion ty cos) = ZCoercion (tidyType env ty) (mapVarSet (tidyTyCoVarOcc env) cos) +tidyCastCo _ ReflCastCo = ReflCastCo ===================================== compiler/GHC/Core/Utils.hs ===================================== @@ -141,7 +141,7 @@ exprType (Let bind body) , Type ty <- rhs = substTyWithUnchecked [tv] [ty] (exprType body) | otherwise = exprType body exprType (Case _ _ ty _) = ty -exprType (Cast _ co) = castCoercionRKind co +exprType (Cast e co) = castCoercionRKind (exprType e) co exprType (Tick _ e) = exprType e exprType (Lam binder expr) = mkLamType binder (exprType expr) exprType e@(App _ _) @@ -271,6 +271,7 @@ mkPiMCo v (MCo co) = MCo (mkPiCo Representational v co) mkCastCo :: HasDebugCallStack => CoreExpr -> CastCoercion -> CoreExpr mkCastCo expr (CCoercion co) = mkCast expr co mkCastCo expr (ZCoercion ty cos) = mkCastZ expr ty cos +mkCastCo expr ReflCastCo = expr -- | Wrap the given expression in the coercion safely, dropping -- identity coercions and coalescing nested coercions @@ -2512,11 +2513,11 @@ c.f. add_evals in GHC.Core.Opt.Simplify.simplAlt -- | A cheap equality test which bales out fast! -- If it returns @True@ the arguments are definitely equal, -- otherwise, they may or may not be equal. -cheapEqExpr :: Expr b -> Expr b -> Bool +cheapEqExpr :: CoreExpr -> CoreExpr -> Bool cheapEqExpr = cheapEqExpr' (const False) -- | Cheap expression equality test, can ignore ticks by type. -cheapEqExpr' :: (CoreTickish -> Bool) -> Expr b -> Expr b -> Bool +cheapEqExpr' :: (CoreTickish -> Bool) -> CoreExpr -> CoreExpr -> Bool {-# INLINE cheapEqExpr' #-} cheapEqExpr' ignoreTick e1 e2 = go e1 e2 @@ -2526,7 +2527,7 @@ cheapEqExpr' ignoreTick e1 e2 go (Type t1) (Type t2) = t1 `eqType` t2 go (Coercion c1) (Coercion c2) = c1 `eqCoercion` c2 go (App f1 a1) (App f2 a2) = f1 `go` f2 && a1 `go` a2 - go (Cast e1 co1) (Cast e2 co2) = e1 `go` e2 && eqCastCoercion co1 co2 + go (Cast e1 co1) (Cast e2 co2) = e1 `go` e2 && eqCastCoercion (exprType e1) co1 co2 go (Tick t1 e1) e2 | ignoreTick t1 = go e1 e2 go e1 (Tick t2 e2) | ignoreTick t2 = go e1 e2 @@ -2622,7 +2623,7 @@ diffExpr _ env (Type t1) (Type t2) | eqTypeX env t1 t2 = [] diffExpr _ env (Coercion co1) (Coercion co2) | eqCoercionX env co1 co2 = [] diffExpr top env (Cast e1 co1) (Cast e2 co2) - | eqCastCoercionX env co1 co2 = diffExpr top env e1 e2 + | eqCastCoercionX env (exprType e1) co1 (exprType e2) co2 = diffExpr top env e1 e2 diffExpr top env (Tick n1 e1) e2 | not (tickishIsCode n1) = diffExpr top env e1 e2 diffExpr top env e1 (Tick n2 e2) ===================================== compiler/GHC/CoreToIface.hs ===================================== @@ -273,6 +273,7 @@ toIfaceTyLit (CharTyLit x) = IfaceCharTyLit x toIfaceCastCoercion :: CastCoercion -> IfaceCastCoercion toIfaceCastCoercion (CCoercion co) = IfaceCCoercion (toIfaceCoercion co) toIfaceCastCoercion (ZCoercion ty cos) = IfaceZCoercion (toIfaceType ty) (map (toIfaceCoercion . CoVarCo) (nonDetEltsUniqSet cos)) -- TODO determinism +toIfaceCastCoercion ReflCastCo = IfaceReflCastCo toIfaceCoercion :: Coercion -> IfaceCoercion toIfaceCoercion = toIfaceCoercionX emptyVarSet ===================================== compiler/GHC/Iface/Rename.hs ===================================== @@ -888,8 +888,9 @@ rnIfaceMCo IfaceMRefl = pure IfaceMRefl rnIfaceMCo (IfaceMCo co) = IfaceMCo <$> rnIfaceCo co rnIfaceCastCo :: Rename IfaceCastCoercion -rnIfaceCastCo (IfaceCCoercion co) = IfaceCCoercion <$> rnIfaceCo co +rnIfaceCastCo (IfaceCCoercion co) = IfaceCCoercion <$> rnIfaceCo co rnIfaceCastCo (IfaceZCoercion ty cos) = IfaceZCoercion <$> rnIfaceType ty <*> mapM rnIfaceCo cos +rnIfaceCastCo IfaceReflCastCo = pure IfaceReflCastCo rnIfaceCo :: Rename IfaceCoercion rnIfaceCo (IfaceReflCo ty) = IfaceReflCo <$> rnIfaceType ty ===================================== compiler/GHC/Iface/Syntax.hs ===================================== @@ -2075,8 +2075,9 @@ freeNamesIfMCoercion IfaceMRefl = emptyNameSet freeNamesIfMCoercion (IfaceMCo co) = freeNamesIfCoercion co freeNamesIfCastCoercion :: IfaceCastCoercion -> NameSet -freeNamesIfCastCoercion (IfaceCCoercion co) = freeNamesIfCoercion co +freeNamesIfCastCoercion (IfaceCCoercion co) = freeNamesIfCoercion co freeNamesIfCastCoercion (IfaceZCoercion ty cos) = freeNamesIfType ty &&& fnList freeNamesIfCoercion cos +freeNamesIfCastCoercion IfaceReflCastCo = emptyNameSet freeNamesIfCoercion :: IfaceCoercion -> NameSet freeNamesIfCoercion (IfaceReflCo t) = freeNamesIfType t ===================================== compiler/GHC/Iface/Type.hs ===================================== @@ -480,6 +480,7 @@ data IfaceMCoercion data IfaceCastCoercion = IfaceCCoercion IfaceCoercion | IfaceZCoercion IfaceType [IfaceCoercion] + | IfaceReflCastCo deriving (Eq, Ord) data IfaceCoercion @@ -2040,10 +2041,12 @@ pprIfaceTyLit (IfaceCharTyLit c) = text (show c) pprIfaceCastCoercion :: IfaceCastCoercion -> SDoc pprIfaceCastCoercion (IfaceCCoercion co) = pprIfaceCoercion co pprIfaceCastCoercion (IfaceZCoercion ty cos) = text "Zap" <+> pprParendIfaceType ty <+> ppr cos +pprIfaceCastCoercion IfaceReflCastCo = text "ReflCastCo" pprParendIfaceCastCoercion :: IfaceCastCoercion -> SDoc pprParendIfaceCastCoercion (IfaceCCoercion co) = pprParendIfaceCoercion co pprParendIfaceCastCoercion (IfaceZCoercion ty cos) = parens (pprIfaceCastCoercion (IfaceZCoercion ty cos)) +pprParendIfaceCastCoercion IfaceReflCastCo = text "ReflCastCo" pprIfaceCoercion, pprParendIfaceCoercion :: IfaceCoercion -> SDoc pprIfaceCoercion = ppr_co topPrec @@ -2447,6 +2450,7 @@ instance Binary IfaceCastCoercion where putByte bh 2 put_ bh a put_ bh b + put_ bh IfaceReflCastCo = putByte bh 3 get bh = do tag <- getByte bh @@ -2456,6 +2460,7 @@ instance Binary IfaceCastCoercion where 2 -> do a <- get bh b <- get bh return $ IfaceZCoercion a b + 3 -> return IfaceReflCastCo _ -> panic ("get IfaceCastCoercion " ++ show tag) @@ -2643,6 +2648,7 @@ instance NFData IfaceCastCoercion where rnf = \case IfaceCCoercion f1 -> rnf f1 IfaceZCoercion f1 f2 -> rnf f1 `seq` rnf f2 + IfaceReflCastCo -> () instance NFData IfaceCoercion where rnf = \case ===================================== compiler/GHC/IfaceToCore.hs ===================================== @@ -1582,6 +1582,7 @@ tcIfaceTyLit (IfaceCharTyLit n) = return (CharTyLit n) tcIfaceCastCoercion :: IfaceCastCoercion -> IfL CastCoercion tcIfaceCastCoercion (IfaceCCoercion co) = CCoercion <$> tcIfaceCo co tcIfaceCastCoercion (IfaceZCoercion ty cos) = ZCoercion <$> tcIfaceType ty <*> (shallowCoVarsOfCos <$> mapM tcIfaceCo cos) +tcIfaceCastCoercion IfaceReflCastCo = pure ReflCastCo tcIfaceCo :: IfaceCoercion -> IfL Coercion tcIfaceCo = go ===================================== compiler/GHC/Tc/Types/Evidence.hs ===================================== @@ -649,6 +649,7 @@ optSubTypeHsWrapper wrap CCoercion co -> not (anyFreeVarsOfCo (== v) co) ZCoercion ty cvs -> not (anyFreeVarsOfType (== v) ty) && not (v `elemVarSet` cvs) + ReflCastCo -> True not_in_submult :: TyVar -> SubMultCo -> Bool not_in_submult v = \case ===================================== compiler/GHC/Tc/Zonk/Type.hs ===================================== @@ -551,6 +551,7 @@ _zonkCosToCos :: [Coercion] -> ZonkTcM [Coercion] zonkCastCo :: CastCoercion -> ZonkTcM CastCoercion zonkCastCo (CCoercion co) = CCoercion <$> zonkCoToCo co zonkCastCo (ZCoercion ty cos) = ZCoercion <$> zonkTcTypeToTypeX ty <*> zonkCoVarSet cos +zonkCastCo ReflCastCo = pure ReflCastCo zonkCoVarSet :: CoVarSet -> ZonkTcM CoVarSet zonkCoVarSet = fmap shallowCoVarsOfCos . mapM zonkCoVarOcc . nonDetEltsUniqSet @@ -1868,6 +1869,8 @@ zonkEvTerm (EvCastExpr e (CCoercion co) co_res_ty) } zonkEvTerm ev@(EvCastExpr _ (ZCoercion{}) _) = pprPanic "zonkEvTerm: ZCoercion" (ppr ev) +zonkEvTerm (EvCastExpr e ReflCastCo _) + = EvExpr <$> zonkCoreExpr e zonkEvTerm (EvTypeable ty ev) = EvTypeable <$> zonkTcTypeToTypeX ty <*> zonkEvTypeable ev zonkEvTerm (EvFun { et_tvs = tvs, et_given = evs View it on GitLab: https://gitlab.haskell.org/ghc/ghc/-/compare/df288bc2b2dc5b657cb3ea7ea7cba71... -- View it on GitLab: https://gitlab.haskell.org/ghc/ghc/-/compare/df288bc2b2dc5b657cb3ea7ea7cba71... You're receiving this email because of your account on gitlab.haskell.org.