diff options
69 files changed, 4228 insertions, 1142 deletions
diff --git a/compiler/GHC/Core/Coercion.hs b/compiler/GHC/Core/Coercion.hs index 21d537112e..f9febf29c2 100644 --- a/compiler/GHC/Core/Coercion.hs +++ b/compiler/GHC/Core/Coercion.hs @@ -14,6 +14,7 @@ module GHC.Core.Coercion ( -- * Main data type Coercion, CoercionN, CoercionR, CoercionP, + DCoercion(..), DCoercionN, MCoercion(..), MCoercionN, MCoercionR, CoSel(..), FunSel(..), UnivCoProvenance, CoercionHole(..), @@ -50,6 +51,26 @@ module GHC.Core.Coercion ( mkKindCo, castCoercionKind, castCoercionKind1, castCoercionKind2, + mkReflDCo, + mkAppDCo, + mkAppDCos, + mkTyConAppDCo, + mkFunDCo, + mkForAllDCo, + mkHomoForAllDCos, + mkGReflLeftDCo, + mkGReflRightDCo, + mkCoherenceLeftDCo, + mkCoherenceRightDCo, + mkTransDCo, mkHydrateDCo, + followDCo, fullyHydrateDCo, hydrateOneLayerDCo, + expandDCo, expandAxiomInstDCo, expandOneStepDCo, + mkDehydrateCo, + mkCoVarDCo, + castDCoercionKind1, castDCoercionKind2, + mkUnivDCo, mkProofIrrelDCo, + mkSubDCo, + mkPrimEqPred, mkReprPrimEqPred, mkPrimEqPredRole, mkNomPrimEqPred, @@ -64,6 +85,7 @@ module GHC.Core.Coercion ( splitFunCo_maybe, splitForAllCo_maybe, splitForAllCo_ty_maybe, splitForAllCo_co_maybe, + splitForAllDCo_ty_maybe, splitForAllDCo_co_maybe, tyConRole, tyConRolesX, tyConRolesRepresentational, setNominalRole_maybe, tyConRoleListX, tyConRoleListRepresentational, funRole, @@ -77,13 +99,15 @@ module GHC.Core.Coercion ( mkHomoForAllMCo, mkFunResMCo, mkPiMCos, isReflMCo, checkReflexiveMCo, + isReflDCo, isReflexiveDCo, + -- ** Coercion variables mkCoVar, isCoVar, coVarName, setCoVarName, setCoVarUnique, -- ** Free variables tyCoVarsOfCo, tyCoVarsOfCos, coVarsOfCo, tyCoFVsOfCo, tyCoFVsOfCos, tyCoVarsOfCoDSet, - coercionSize, anyFreeVarsOfCo, + coercionSize, anyFreeVarsOfCo, anyFreeVarsOfDCo, -- ** Substitution CvSubstEnv, emptyCvSubstEnv, @@ -97,8 +121,10 @@ module GHC.Core.Coercion ( emptyLiftingContext, extendLiftingContext, extendLiftingContextAndInScope, liftCoSubstVarBndrUsing, isMappedByLC, + mkLiftingContext, mkSubstLiftingContext, zapLiftingContext, - substForAllCoBndrUsingLC, lcSubst, lcInScopeSet, + substForAllCoBndrUsingLC, substForAllDCoBndrUsingLC, + lcSubst, lcInScopeSet, LiftCoEnv, LiftingContext(..), liftEnvSubstLeft, liftEnvSubstRight, substRightCo, substLeftCo, swapLiftCoEnv, lcSubstLeft, lcSubstRight, @@ -121,6 +147,9 @@ module GHC.Core.Coercion ( -- * Other promoteCoercion, buildCoercion, + downgradeRole_maybe, + downgradeDCoToRepresentational, + multToCo, mkRuntimeRepCo, hasCoercionHoleTy, hasCoercionHoleCo, hasThisCoercionHoleTy, @@ -143,6 +172,8 @@ import GHC.Core.Type import GHC.Core.TyCon import GHC.Core.TyCon.RecWalk import GHC.Core.Coercion.Axiom +import {-# SOURCE #-} GHC.Core.FamInstEnv ( chooseBranch ) +import {-# SOURCE #-} GHC.Core.Unify ( tcMatchTys ) import GHC.Types.Var import GHC.Types.Var.Env import GHC.Types.Var.Set @@ -160,6 +191,7 @@ import GHC.Types.Unique.FM import GHC.Data.List.Infinite (Infinite (..)) import qualified GHC.Data.List.Infinite as Inf +import GHC.Utils.Monad import GHC.Utils.Misc import GHC.Utils.Outputable import GHC.Utils.Panic @@ -167,6 +199,8 @@ import GHC.Utils.Panic.Plain import Control.Monad (foldM, zipWithM) import Data.Function ( on ) +import Data.Functor.Identity (Identity(..)) +import Data.List ( zipWith4 ) import Data.Char( isDigit ) import qualified Data.Monoid as Monoid @@ -571,6 +605,18 @@ splitForAllCo_co_maybe (ForAllCo cv k_co co) | isCoVar cv = Just (cv, k_co, co) splitForAllCo_co_maybe _ = Nothing +-- | Like 'splitForAllCo_maybe', but only returns Just for tyvar binder +splitForAllDCo_ty_maybe :: DCoercion -> Maybe (TyVar, DCoercion, DCoercion) +splitForAllDCo_ty_maybe (ForAllDCo tv k_dco dco) + | isTyVar tv = Just (tv, k_dco, dco) +splitForAllDCo_ty_maybe _ = Nothing + +-- | Like 'splitForAllCo_maybe', but only returns Just for covar binder +splitForAllDCo_co_maybe :: DCoercion -> Maybe (CoVar, DCoercion, DCoercion) +splitForAllDCo_co_maybe (ForAllDCo cv k_dco dco) + | isCoVar cv = Just (cv, k_dco, dco) +splitForAllDCo_co_maybe _ = Nothing + ------------------------------------------------------- -- and some coercion kind stuff @@ -593,7 +639,7 @@ coVarKindsTypesRole cv coVarKind :: CoVar -> Type coVarKind cv - = assert (isCoVar cv ) + = assert (isCoVar cv) varType cv coVarRole :: CoVar -> Role @@ -663,6 +709,7 @@ isReflCoVar_maybe cv isGReflCo :: Coercion -> Bool isGReflCo (GRefl{}) = True isGReflCo (Refl{}) = True -- Refl ty == GRefl N ty MRefl +isGReflCo (HydrateDCo _ _ dco _) = isGReflDCo dco isGReflCo _ = False -- | Tests if this coercion is obviously reflexive. Guaranteed to work @@ -671,6 +718,7 @@ isGReflCo _ = False isReflCo :: Coercion -> Bool isReflCo (Refl{}) = True isReflCo (GRefl _ _ mco) | isGReflMCo mco = True +isReflCo (HydrateDCo _ _ dco _) = isReflDCo dco isReflCo _ = False -- | Returns the type coerced if this coercion is a generalized reflexive @@ -678,6 +726,9 @@ isReflCo _ = False isGReflCo_maybe :: Coercion -> Maybe (Type, Role) isGReflCo_maybe (GRefl r ty _) = Just (ty, r) isGReflCo_maybe (Refl ty) = Just (ty, Nominal) +isGReflCo_maybe (HydrateDCo r ty dco _) + | isGReflDCo dco + = Just (ty, r) isGReflCo_maybe _ = Nothing -- | Returns the type coerced if this coercion is reflexive. Guaranteed @@ -686,6 +737,9 @@ isGReflCo_maybe _ = Nothing isReflCo_maybe :: Coercion -> Maybe (Type, Role) isReflCo_maybe (Refl ty) = Just (ty, Nominal) isReflCo_maybe (GRefl r ty mco) | isGReflMCo mco = Just (ty, r) +isReflCo_maybe (HydrateDCo r ty dco _) + | isReflDCo dco + = Just (ty, r) isReflCo_maybe _ = Nothing -- | Slowly checks if the coercion is reflexive. Don't call this in a loop, @@ -696,15 +750,35 @@ isReflexiveCo = isJust . isReflexiveCo_maybe -- | Extracts the coerced type from a reflexive coercion. This potentially -- walks over the entire coercion, so avoid doing this in a loop. isReflexiveCo_maybe :: Coercion -> Maybe (Type, Role) -isReflexiveCo_maybe (Refl ty) = Just (ty, Nominal) -isReflexiveCo_maybe (GRefl r ty mco) | isGReflMCo mco = Just (ty, r) isReflexiveCo_maybe co + | Just res <- isReflCo_maybe co + = Just res | ty1 `eqType` ty2 = Just (ty1, r) | otherwise = Nothing where (Pair ty1 ty2, r) = coercionKindRole co +isReflDCo :: DCoercion -> Bool +isReflDCo ReflDCo = True +isReflDCo (GReflRightDCo co) = isGReflCo co +isReflDCo (GReflLeftDCo co) = isGReflCo co +isReflDCo (DehydrateCo co) = isReflCo co +isReflDCo _ = False + +isGReflDCo :: DCoercion -> Bool +isGReflDCo ReflDCo = True +isGReflDCo (GReflRightDCo {}) = True +isGReflDCo (GReflLeftDCo {}) = True +isGReflDCo (DehydrateCo co) = isGReflCo co +isGReflDCo _ = False + +isReflexiveDCo :: Role -> Type -> DCoercion -> Type -> Bool +isReflexiveDCo _r l_ty dco r_ty + | isReflDCo dco + = True + | otherwise + = l_ty `eqType` r_ty {- %************************************************************************ @@ -919,6 +993,493 @@ mkAppCos :: Coercion -> Coercion mkAppCos co1 cos = foldl' mkAppCo co1 cos +mkReflDCo :: DCoercion +mkReflDCo = ReflDCo + +mkTyConAppDCo :: [DCoercion] -> DCoercion +mkTyConAppDCo cos + | all isReflDCo cos = mkReflDCo -- See Note [Refl invariant] + | otherwise = TyConAppDCo cos + +mkSubDCo :: HasDebugCallStack + => Type -- ^ LHS type + -> DCoercion + -> Type -- ^ RHS type + -> DCoercion +mkSubDCo l_ty dco r_ty = case dco of + ReflDCo -> ReflDCo + GReflRightDCo co -> GReflRightDCo co + GReflLeftDCo co -> GReflLeftDCo co + TyConAppDCo dcos + | Just (tc, arg_l_tys) <- splitTyConApp_maybe l_ty + , Just (_ , arg_r_tys) <- splitTyConApp_maybe r_ty + -> TyConAppDCo (applyRoles_dco tc arg_l_tys dcos arg_r_tys) + -- SLD TODO: we might need to get rid of this case, + -- to avoid calling applyRoles, which calls mkHydrateDCo. + DehydrateCo co + -> DehydrateCo (mkSubCo co) + UnivDCo prov r + -> UnivDCo prov r + _ -> SubDCo dco + +-- | Like 'mkTyConAppDCo', but specialised to the function arrow. +-- +-- Unlike for 'Coercion', for 'DCoercion' the function arrow does not +-- have special treatment, so this is just a helper function around +-- 'mkTyConAppDCo'. +mkFunDCo :: FunTyFlag + -> DCoercionN -- ^ multiplicity + -> DCoercionN -- ^ argument representation + -> DCoercionN -- ^ result representation + -> DCoercion -- ^ argument + -> DCoercion -- ^ result + -> DCoercion +mkFunDCo ftf w repco1 repco2 co1 co2 = + if isFUNArg ftf + then mkTyConAppDCo [w, repco1, repco2, co1, co2] + else mkTyConAppDCo [ repco1, repco2, co1, co2] + +mkAppDCo :: DCoercion -- ^ :: t1 ~r t2 + -> DCoercion -- ^ :: s1 ~N s2, where s1 :: k1, s2 :: k2 + -> DCoercion -- ^ :: t1 s1 ~r t2 s2 +mkAppDCo ReflDCo ReflDCo = ReflDCo +mkAppDCo (TyConAppDCo args) arg = TyConAppDCo (args ++ [arg]) +mkAppDCo co arg = AppDCo co arg + +mkAppDCos :: DCoercion + -> [DCoercion] + -> DCoercion +mkAppDCos co1 cos = foldl' mkAppDCo co1 cos + +-- | Transitivity for directed coercions. +-- +-- Does some basic simplifications, i.e. either coercion is 'ReflDCo' +-- or both are 'StepsDCo', but nothing more elaborate. +mkTransDCo :: DCoercion -> DCoercion -> DCoercion + -- NB: if you change this function in an attempt to gain more simplification, + -- e.g. simplifying @StepsDCo n `mkTransCo` ( StepsDCo m ; dco )@ to + -- @StepsDCo (n+m) ; dco@, check it is not causing significant regressions + -- in the rewriter, e.g. T13386. +mkTransDCo dco1 dco2 + | isReflDCo dco1 + = dco2 + | isReflDCo dco2 + = dco1 +-- SLD TODO: GRefl cases? +mkTransDCo (StepsDCo n) (StepsDCo m) + = StepsDCo (n+m) +mkTransDCo dco1 dco2 + = TransDCo dco1 dco2 + +-- | Make a Coercion from a tycovar, a kind coercion, and a body coercion. +-- The kind of the tycovar should be the left-hand kind of the kind coercion. +-- See Note [Unused coercion variable in ForAllCo] +mkForAllDCo :: TyCoVar -> DCoercionN -> DCoercion -> DCoercion +mkForAllDCo v kind_dco dco + | assert (isTyVar v || almostDevoidCoVarOfDCo v dco) True + , isReflDCo dco + , isGReflDCo kind_dco + = ReflDCo +mkForAllDCo v kind_dco dco + = ForAllDCo v kind_dco dco + +-- | Like 'mkForAllCo', but the inner coercion shouldn't be an obvious +-- reflexive coercion. For example, it is guaranteed in 'mkForAllCos'. +-- The kind of the tycovar should be the left-hand kind of the kind coercion. +mkForAllDCo_NoRefl :: TyCoVar -> DCoercionN -> TypeOrConstraint -> DCoercion -> DCoercion +mkForAllDCo_NoRefl v kind_dco body_torc dco + | assert (isTyVar v || almostDevoidCoVarOfDCo v dco) True + , assert (not (isReflDCo dco)) True + , isCoVar v + , not (v `elemVarSet` tyCoVarsOfDCo dco) + = let var_torc = case sORTKind_maybe (tyVarKind v) of + Just (torc, _) -> torc + Nothing -> pprPanic "mkForAllDCo_NoRefl" (ppr v $$ ppr kind_dco) + ftf = mkFunTyFlag var_torc body_torc + in mkFunDCo ftf mkReflDCo mkReflDCo mkReflDCo kind_dco dco + -- Functions from coercions are always unrestricted + | otherwise + = ForAllDCo v kind_dco dco + +-- | Make a Coercion quantified over a type/coercion variable; +-- the variable has the same type in both sides of the coercion +mkHomoForAllDCos :: [TyCoVar] -> TypeOrConstraint -> DCoercion -> DCoercion +mkHomoForAllDCos _ _ ReflDCo = ReflDCo +mkHomoForAllDCos vs body_torc co = mkHomoForAllDCos_NoRefl vs body_torc co + +-- | Like 'mkHomoForAllCos', but the inner coercion shouldn't be an obvious +-- reflexive coercion. For example, it is guaranteed in 'mkHomoForAllCos'. +mkHomoForAllDCos_NoRefl :: [TyCoVar] -> TypeOrConstraint -> DCoercion -> DCoercion +mkHomoForAllDCos_NoRefl vs body_torc orig_co + = assert (not (isReflDCo orig_co)) + foldr go orig_co vs + where + go v co = mkForAllDCo_NoRefl v mkReflDCo body_torc co + +-- | Given @ty :: k1@, @co :: k1 ~ k2@, +-- produces @co' :: ty ~r (ty |> co)@ +mkGReflRightDCo :: CoercionN -> DCoercion +mkGReflRightDCo co + | isGReflCo co = mkReflDCo + -- the kinds of @k1@ and @k2@ are the same, thus @isGReflCo@ + -- instead of @isReflCo@ + | otherwise = GReflRightDCo co + +-- | Given @ty :: k1@, @co :: k1 ~ k2@, +-- produces @co' :: (ty |> co) ~r ty@ +mkGReflLeftDCo :: CoercionN -> DCoercion +mkGReflLeftDCo co + | isGReflCo co = mkReflDCo + -- the kinds of @k1@ and @k2@ are the same, thus @isGReflCo@ + -- instead of @isReflCo@ + | otherwise = GReflLeftDCo co + +-- | Given @ty :: k1@, @co :: k1 ~ k2@, @co2:: ty ~r ty'@, +-- produces @co' :: (ty |> co) ~r ty' +-- It is not only a utility function, but it saves allocation when co +-- is a GRefl coercion. +mkCoherenceLeftDCo :: CoercionN -> DCoercion -> DCoercion +mkCoherenceLeftDCo co dco + | isGReflCo co = dco + | otherwise = GReflLeftDCo co `mkTransDCo` dco + +-- | Given @ty :: k1@, @co :: k1 ~ k2@, @co2:: ty' ~r ty@, +-- produces @co' :: ty' ~r (ty |> co) +-- It is not only a utility function, but it saves allocation when co +-- is a GRefl coercion. +mkCoherenceRightDCo :: CoercionN -> DCoercion -> DCoercion +mkCoherenceRightDCo co dco + | isGReflCo co = dco + | otherwise = dco `mkTransDCo` GReflRightDCo co + +{- Note [Following a directed coercion] +~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~ +Following a directed coercion means taking a directed coercion `dco`, a role `r` +and a LHS (input) type `lhs`, and computing the RHS type of the directed coercion, +`rhs`. This amounts to reconstituting a coercion `co :: lhs ~r rhs` from `dco`. + +This process however requires that lhs be sufficiently zonked. For example, +if `dco = TyConAppDCo`, then we require that `lhs = TyConApp tc tys`, as we need +to read off the `TyCon` from `lhs` in order to compute the `rhs`. + +To avoid any problems, we make sure we never call `followDCo` on an unzonked +type; that is, we should not call this function from within the typechecker, +when there are still metavariables floating around. +-} + +-- | Turn a 'DCoercion' into a full 'Coercion' by specifying +-- a 'Role' and the LHS and RHS 'Type's of the coercion. +mkHydrateDCo :: HasDebugCallStack => Role -> Type -> DCoercion -> Type -> Coercion +mkHydrateDCo r l_ty dco r_ty = + -- NB: don't assert that r_ty = followDCo r l_ty dco, + -- as we sometimes call this function in the typechecker, which means that + -- l_ty might not be zonked, in which case followDCo could crash. + -- See Note [Following a directed coercion] + case dco of + ReflDCo -> mkReflCo r r_ty + CoVarDCo cv -> CoVarCo cv + DehydrateCo co -> let co_r = coercionRole co in + assertPpr (r == co_r) + (vcat [ text "mkHydrateCo: role mismatch" + , text "Expected:" <+> ppr r + , text " Actual:" <+> ppr co_r ]) + $ co + _ -> HydrateDCo r l_ty dco r_ty + + +fullyHydrateDCo :: HasDebugCallStack => Role -> Type -> DCoercion -> Coercion +fullyHydrateDCo r ty dco = fst $ expandDCo r ty dco + +hydrateOneLayerDCo :: HasDebugCallStack => Role -> Type -> DCoercion -> Coercion +hydrateOneLayerDCo r l_ty dco = fst $ expandDCoWith hydrate r l_ty dco + where + hydrate r l_ty dco + = let r_ty = followDCo r l_ty dco + co = mkHydrateDCo r l_ty dco r_ty + in (co, r_ty) + +followDCo :: HasDebugCallStack => Role -> Type -> DCoercion -> Type +followDCo r ty dco = snd $ expandDCo r ty dco + +expandDCo :: HasDebugCallStack => Role -> Type -> DCoercion -> (Coercion, Type) +expandDCo = expandDCoWith expandDCo + +expandDCoWith :: HasDebugCallStack + => (Role -> Type -> DCoercion -> (Coercion, Type)) + -- ^ Function to use to recursively expand nested directed coercions + -> Role -> Type -> DCoercion -> (Coercion, Type) +expandDCoWith _ r ty dco + | Just ty' <- coreView ty + = expandDCo r ty' dco + +expandDCoWith _ r l_ty ReflDCo + = (mkReflCo r l_ty, l_ty) + +expandDCoWith _ r l_ty (GReflRightDCo kco) + | let co = mkGReflCo r l_ty (coToMCo kco) + = (co, coercionRKind co) + +expandDCoWith _ r l_ty (GReflLeftDCo kco) + | let co = mkGReflCo r l_ty (mkSymMCo $ coToMCo kco) + -- N.B.: mkSymCo (mkGReflCo r l_ty mco) would be wrong, + -- because the LHS type of mco would not be the kind of l_ty. + = (co, coercionRKind co) + +expandDCoWith expander r l_ty dco@(TyConAppDCo dcos) + | Just (tc, l_tys) <- splitTyConApp_maybe l_ty + , let (cos, tys) = unzip $ zipWith3 expander (tyConRoleListX r tc) l_tys dcos + = (mkTyConAppCo r tc cos, mkTyConApp tc tys) + | otherwise + = pprPanic "expandDCo" (vcat [ text "TyConAppDCo where type is not a TyCon:" + , text "l_ty:" <+> ppr l_ty + , text "dco:" <+> ppr dco ]) + +expandDCoWith expander r l_ty (AppDCo dco1 dco2) + | Just (l_ty1, l_ty2) <- splitAppTy_maybe l_ty + , let + (co1, ty1) = expander r l_ty1 dco1 + r' + | Phantom <- r = Phantom + | otherwise = Nominal + (co2, ty2) = expander r' l_ty2 dco2 + = (mkAppCo co1 co2, mkAppTy ty1 ty2) + | otherwise + = pprPanic "expandDCo" (text "AppDCo where type is not an AppTy:" <+> ppr l_ty) + +expandDCoWith expander r l_ty co@(ForAllDCo tcv kdco body_dco) + | not (isTyCoVar tcv) + = pprPanic "expandDCo" (text "Non tyco binder in ForAllDCo:" <+> ppr co) + | otherwise + = case coreFullView l_ty of + ForAllTy bndr body_ty + | (body_co, rhs_ty) <- expander r body_ty body_dco + , let (kco, _) = expandDCoWith expander Nominal (tyVarKind tcv) kdco + -> + (mkForAllCo tcv kco body_co + ,mkForAllTy bndr rhs_ty) + _ -> pprPanic "expandDCo" (text "ForAllDCo where type is not a ForAllTy:" <+> ppr l_ty <+> ppr co) + +expandDCoWith _ r _ (CoVarDCo cv) + = let cv_r = coVarRole cv in + assertPpr (r == cv_r) + (vcat [ text "expandDCo: wrong role" + , text "Expected:" <+> ppr r + , text " Actual:" <+> ppr cv_r + , text "cv:" <+> ppr cv ]) + (CoVarCo cv, coVarRType cv) + +expandDCoWith _ r l_ty (AxiomInstDCo ax) + = runIdentity $ expandAxiomInstDCo assertPpr (pprPanic "expandDCo") r l_ty ax + +expandDCoWith _ r l_ty (StepsDCo 0) + = (mkReflCo r l_ty, l_ty) + +expandDCoWith expander r l_ty (StepsDCo n) + = let (co, ty) = runIdentity $ expandOneStepDCo assertPpr (pprPanic "expandDCo") r l_ty + (co', ty') = expandDCoWith expander r ty (StepsDCo (n-1)) + in (co `mkTransCo` co', ty') + +expandDCoWith expander r l_ty (TransDCo dco1 dco2) + = let + (co1, ty1) = expander r l_ty dco1 + (co2, ty2) = expander r ty1 dco2 + in + (TransCo co1 co2, ty2) + +expandDCoWith expander r l_ty (SubDCo dco) + -- Keep expanding one more level through SubDCo. + = assert (r == Representational) + $ case expandDCoWith expander Nominal l_ty dco of + (co, rhs) -> (mkSubCo co, rhs) + +expandDCoWith _ r _ (DehydrateCo co) + = let co_r = coercionRole co in + assertPpr (r == co_r) + (vcat [ text "expandDCo: wrong role" + , text "Expected:" <+> ppr r + , text " Actual:" <+> ppr co_r + , text "co:" <+> ppr co ]) + (co, coercionRKind co) + +expandDCoWith _ r l_ty (UnivDCo prov r_ty) + = (UnivCo (expandProv r l_ty prov) r l_ty r_ty, r_ty) + +-- | Expand an 'AxiomInstDCo' directed coercion by matching on an open type +-- or data family instance. (Use 'expandOneStepDCo' for closed type families). +-- +-- This function is used in both 'expandDCo' (which panics on failure) +-- and in 'GHC.Core.Lint.lintDCoercion' (which errors in the 'LintM' monad). +expandAxiomInstDCo :: (HasDebugCallStack, Applicative m) + => (Bool -> SDoc -> m (Coercion, Type) -> m (Coercion, Type)) + -- ^ How to check assertions in @m@ + -> (SDoc -> m (Coercion, Type)) + -- ^ How to throw hard errors in @m@ + -> Role -- ^ input role for expansion + -> Type -- ^ input LHS type for expansion + -> CoAxiom Branched -- ^ axiom to use + -> m (Coercion, Type) +expandAxiomInstDCo check_prop throw_err r l_ty ax + | r == Phantom + = expandAxiomInstDCo check_prop throw_err Representational l_ty ax + -- AMG TODO: think about better fix to the above; + -- role could be Phantom because the coercion was downgraded, + -- maybe change the following to check role <= rather than exact matches + + | otherwise + = case splitTyConApp_maybe l_ty of + Just (tc, tys) + | let (match_tys, other_tys) = splitAtList ax_lhs $ (map (\ x -> fromMaybe x $ coreView x) tys) + debug_info2 = debug_info $$ + text "match_tys:" <+> ppr match_tys $$ + text "other_tys:" <+> ppr other_tys + -> + case tcMatchTys ax_lhs match_tys of + Just subst -> + let inst_tys = substTyVars subst (coAxBranchTyVars branch) `chkAppend` other_tys + inst_cos = substCoVars subst (coAxBranchCoVars branch) + co = mkUnbranchedAxInstCo r ax' inst_tys inst_cos + in check_prop (tc_is_ok tc) (text "AxiomInstDCo: incorrect TyCon for Axiom" $$ debug_info2) $ + pure (co, coercionRKind co) + Nothing -> + throw_err (text "AxiomInstDCo: couldn't match axiom" $$ debug_info2) + Nothing -> + throw_err (text "AxiomInstDCo: lhs not a TyConApp" $$ debug_info) + where + ax' = toUnbranchedAxiom ax + branch = coAxiomSingleBranch ax' + ax_lhs = coAxBranchLHS branch + tc_is_ok tc = coAxiomTyCon ax == tc && + case r of + Representational -> isOpenFamilyTyCon tc + _ -> isOpenTypeFamilyTyCon tc + debug_info = vcat [ text "ax:" <+> ppr ax + , text "ax_lhs:" <+> ppr ax_lhs ] + +-- | Expand a @StepsDCo 1@ directed coercion by taking a single reduction step, +-- matching on closed type family equations (and built-in type families), or +-- unwrapping newtypes (not including data family newtype instances). +-- (Use 'expandAxiomInstDCo' for open family axioms.) +-- +-- This function is used in both 'expandDCo' (which panics on failure) +-- and in 'GHC.Core.Lint.lintDCoercion' (which errors in the 'LintM' monad). +expandOneStepDCo :: (HasDebugCallStack, Applicative m) + => (Bool -> SDoc -> m (Coercion, Type) -> m (Coercion, Type)) + -- ^ How to check assertions in @m@ + -> (SDoc -> m (Coercion, Type)) + -- ^ How to throw hard errors in @m@ + -> Role -- ^ input role for expansion + -> Type -- ^ input LHS type for expansion + -> m (Coercion, Type) +expandOneStepDCo check_prop throw_err r l_ty + = case splitTyConApp_maybe l_ty of + Just (tc,tys) + -- Closed type family axioms. + | Just ax <- isClosedSynFamilyTyConWithAxiom_maybe tc + -> case chooseBranch ax tys of + Just (ind, inst_tys, inst_cos) -> + let + co = mkAxInstCo r ax ind inst_tys inst_cos + ty = coercionRKind co + in pure (co, ty) + Nothing -> + throw_err + (text "StepsDCo: couldn't choose branch" $$ debug_info2 $$ (text "ax:" <+> ppr ax)) + + -- Newtype axioms. + | Just (ty, co) <- instNewTyCon_maybe tc tys + , r == Representational + -> pure (co, ty) + + -- Built-in type family axioms. + | Just sf <- isBuiltInSynFamTyCon_maybe tc + -> case sfMatchFam sf tys of + Just (ax, ts, ty) -> + let co = mkAxiomRuleCo ax (zipWith mkReflCo (coaxrAsmpRoles ax) ts) + in check_prop (r == coaxrRole ax) + (text "StepsDCo: axiom role mismatch" $$ debug_info2 $$ (text "ax:" <+> ppr ax)) + $ pure (co, ty) + Nothing -> + throw_err (text "StepsDCo: couldn't match built-in axiom" $$ debug_info2) + + -- Couldn't find any axiom associated to this TyCon. + | otherwise + -> throw_err (text "StepsDCo: no axiom to use" $$ debug_info2 $$ (text "tc:" <+> ppr tc)) + where + debug_info2 = debug_info $$ (text "tys:" <+> ppr tys) + + -- LHS type is not a TyConApp. + Nothing -> + throw_err (text "StepsDCo: LHS not a TyConApp" $$ debug_info) + where + debug_info = vcat [ text "r:" <+> ppr r + , text "l_ty:" <+> ppr l_ty ] + +expandProv :: HasDebugCallStack => Role -> Type -> UnivCoProvenance DCoercion -> UnivCoProvenance Coercion +expandProv r l_ty (PhantomProv dco) + = assertPpr (r == Phantom) (text "expandProv PhantomProv") + $ PhantomProv (fullyHydrateDCo r l_ty dco) +expandProv r l_ty (ProofIrrelProv dco) + = assertPpr (r /= Phantom) (text "expandProv ProofIrrelProv") + $ ProofIrrelProv (fullyHydrateDCo r l_ty dco) +expandProv _ _ (PluginProv str) + = PluginProv str +expandProv _ _ (CorePrepProv homo) + = CorePrepProv homo + +mkDehydrateCo :: Coercion -> DCoercion +mkDehydrateCo co | isReflCo co = ReflDCo +mkDehydrateCo (SymCo (GRefl _ _ MRefl)) + = ReflDCo +mkDehydrateCo (SymCo (GRefl _ _ (MCo co))) + = mkGReflLeftDCo co +mkDehydrateCo (GRefl _ _ MRefl) = ReflDCo +mkDehydrateCo (GRefl _ _ (MCo co)) = mkGReflRightDCo co +mkDehydrateCo (HydrateDCo _ _ dco _) = dco +--mkDehydrateCo (TyConAppCo _ _ cos) +-- = mkTyConAppDCo $ map mkDehydrateCo cos +--mkDehydrateCo (AppCo co1 co2) +-- = mkAppDCo (mkDehydrateCo co1) (mkDehydrateCo co2) +--mkDehydrateCo (ForAllCo tcv kind body) +-- = mkForAllDCo tcv (mkDehydrateCo kind) (mkDehydrateCo body) +mkDehydrateCo (AxiomInstCo coax _branch cos) + | all isReflCo cos -- AMG TODO: can we avoid the need for this check? + , isOpenFamilyTyCon (coAxiomTyCon coax) + = AxiomInstDCo coax + | all isReflCo cos + = singleStepDCo +mkDehydrateCo (AxiomRuleCo _coax cos) + | all isReflCo cos -- AMG TODO: can we avoid the need for this check? + = singleStepDCo +mkDehydrateCo (CoVarCo cv) + = CoVarDCo cv +mkDehydrateCo (SubCo co) + = mkSubDCo (coercionLKind co) (mkDehydrateCo co) (coercionRKind co) +--mkDehydrateCo (TransCo co1 co2) +-- = mkTransDCo (mkDehydrateCo co1) (mkDehydrateCo co2) +mkDehydrateCo co + = DehydrateCo co + +singleStepDCo :: DCoercion +singleStepDCo = StepsDCo 1 + +mkUnivDCo :: UnivCoProvenance DCoercion + -> Type -- RHS type + -> DCoercion +mkUnivDCo = UnivDCo + +mkCoVarDCo :: CoVar -> DCoercion +mkCoVarDCo v = CoVarDCo v + +mkProofIrrelDCo :: DCoercionN -> Type -> DCoercion + +-- if the two coercion prove the same fact, I just don't care what +-- the individual coercions are. +mkProofIrrelDCo dco rhs + | isGReflDCo dco + = mkReflDCo + | otherwise + = mkUnivDCo (ProofIrrelProv dco) rhs + {- Note [Unused coercion variable in ForAllCo] ~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~ See Note [Unused coercion variable in ForAllTy] in GHC.Core.TyCo.Rep for the @@ -1112,7 +1673,7 @@ mkHoleCo :: CoercionHole -> Coercion mkHoleCo h = HoleCo h -- | Make a universal coercion between two arbitrary types. -mkUnivCo :: UnivCoProvenance +mkUnivCo :: UnivCoProvenance KindCoercion -> Role -- ^ role of the built coercion, "r" -> Type -- ^ t1 :: k1 -> Type -- ^ t2 :: k2 @@ -1131,6 +1692,8 @@ mkSymCo :: Coercion -> Coercion mkSymCo co | isReflCo co = co mkSymCo (SymCo co) = co mkSymCo (SubCo (SymCo co)) = SubCo co +mkSymCo (HydrateDCo r l_ty (GReflLeftDCo mco) r_ty) = HydrateDCo r r_ty (GReflRightDCo mco) l_ty +mkSymCo (HydrateDCo r l_ty (GReflRightDCo mco) r_ty) = HydrateDCo r r_ty (GReflLeftDCo mco) l_ty mkSymCo co = SymCo co -- | Create a new 'Coercion' by composing the two given 'Coercion's transitively. @@ -1140,7 +1703,10 @@ mkTransCo co1 co2 | isReflCo co1 = co2 | isReflCo co2 = co1 mkTransCo (GRefl r t1 (MCo co1)) (GRefl _ _ (MCo co2)) = GRefl r t1 (MCo $ mkTransCo co1 co2) -mkTransCo co1 co2 = TransCo co1 co2 +mkTransCo (HydrateDCo r lhs dco1 _) (HydrateDCo _ _ dco2 rhs) + = mkHydrateDCo r lhs (mkTransDCo dco1 dco2) rhs +mkTransCo dco1 dco2 + = TransCo dco1 dco2 mkSelCo :: HasDebugCallStack => CoSel @@ -1170,18 +1736,42 @@ mkSelCo_maybe cs co -- If co :: (forall a1:t1 ~ t2. t1) ~ (forall a2:t3 ~ t4. t2) -- then (nth SelForAll co :: (t1 ~ t2) ~N (t3 ~ t4)) + go SelForAll dco@(HydrateDCo _ _ (ForAllDCo tv kind_co _) rhs) + = case splitForAllTyCoVar_maybe rhs of + Just (tv', _) -> Just $ + mkHydrateDCo Nominal (tyVarKind tv) kind_co (tyVarKind tv') + _ -> pprPanic "mkSelCo_maybe" (ppr dco $$ ppr rhs) + go (SelFun fs) (FunCo _ _ _ w arg res) = Just (getNthFun fs w arg res) + -- no FunDCo + go (SelTyCon i r) (TyConAppCo r0 tc arg_cos) = assertPpr (r == tyConRole r0 tc i) (vcat [ ppr tc, ppr arg_cos, ppr r0, ppr i, ppr r ]) $ Just (arg_cos `getNth` i) + go (SelTyCon n r) (HydrateDCo r0 l_ty (TyConAppDCo arg_dcos) r_ty) + | Just (tc, arg_tys) <- splitTyConApp_maybe l_ty + , Just (_, rhs_tys) <- splitTyConApp_maybe r_ty + = assertPpr (r == tyConRole r0 tc n) + (vcat [ text "tc:" <+> ppr tc + , text "arg_dcos:" <+> ppr arg_dcos + , text "r0:" <+> ppr r0 + , text "n:" <+> ppr n + , text "r:" <+> ppr r ]) $ + Just $ mkHydrateDCo + (tyConRole r0 tc n) + (arg_tys `getNth` n) + (arg_dcos `getNth` n) + (rhs_tys `getNth` n) + go cs (SymCo co) -- Recurse, hoping to get to a TyConAppCo or FunCo = do { co' <- go cs co; return (mkSymCo co') } - go _ _ = Nothing + go _ _ + = Nothing -- Assertion checking bad_call_msg = vcat [ text "Coercion =" <+> ppr co @@ -1194,7 +1784,7 @@ mkSelCo_maybe cs co good_call SelForAll | Just (_tv1, _) <- splitForAllTyCoVar_maybe ty1 , Just (_tv2, _) <- splitForAllTyCoVar_maybe ty2 - = True + = True good_call (SelFun {}) = isFunTy ty1 && isFunTy ty2 @@ -1226,6 +1816,13 @@ mkLRCo :: LeftOrRight -> Coercion -> Coercion mkLRCo lr co | Just (ty, eq) <- isReflCo_maybe co = mkReflCo eq (pickLR lr (splitAppTy ty)) + | AppCo l r <- co + = pickLR lr (l,r) + | HydrateDCo r l_ty (AppDCo dco1 dco2) r_ty <- co + , Just (l_ty_1, l_ty_2) <- splitAppTy_maybe l_ty + , Just (r_ty_1, r_ty_2) <- splitAppTy_maybe r_ty + = pickLR lr ( mkHydrateDCo r l_ty_1 dco1 r_ty_1 + , mkHydrateDCo Nominal l_ty_2 dco2 r_ty_2 ) | otherwise = LRCo lr co @@ -1277,8 +1874,14 @@ mkCoherenceRightCo r ty co co2 mkKindCo :: Coercion -> Coercion mkKindCo co | Just (ty, _) <- isReflCo_maybe co = Refl (typeKind ty) mkKindCo (GRefl _ _ (MCo co)) = co +mkKindCo (HydrateDCo _ _ (GReflRightDCo co) _) = co +mkKindCo (HydrateDCo _ _ (GReflLeftDCo co) _) = mkSymCo co mkKindCo (UnivCo (PhantomProv h) _ _ _) = h mkKindCo (UnivCo (ProofIrrelProv h) _ _ _) = h +mkKindCo (HydrateDCo _ lhs (UnivDCo (PhantomProv h) rhs) _) + = mkHydrateDCo Nominal (typeKind lhs) h (typeKind rhs) +mkKindCo (HydrateDCo _ lhs (UnivDCo (ProofIrrelProv h) rhs) _) + = mkHydrateDCo Nominal (typeKind lhs) h (typeKind rhs) mkKindCo co | Pair ty1 ty2 <- coercionKind co -- generally, calling coercionKind during coercion creation is a bad idea, @@ -1302,11 +1905,29 @@ mkSubCo co@(FunCo { fco_role = Nominal, fco_arg = arg, fco_res = res }) = co { fco_role = Representational , fco_arg = downgradeRole Representational Nominal arg , fco_res = downgradeRole Representational Nominal res } +mkSubCo (UnivCo p Nominal t1 t2) = UnivCo p Representational t1 t2 +mkSubCo (HydrateDCo _r l_ty dco r_ty) + = assertPpr (_r == Nominal) + (vcat [ text "mkSubCo (HydrateDCo): unexpected role " <+> ppr _r + , text "l_ty:" <+> ppr l_ty + , text "dco:" <+> ppr dco ]) + $ mkHydrateDCo Representational l_ty (mkSubDCo l_ty dco r_ty) r_ty mkSubCo co = assertPpr (coercionRole co == Nominal) (ppr co <+> ppr (coercionRole co)) $ SubCo co +downgradeDCoToRepresentational :: Role -- ^ Role of input 'DCoercion' + -> Type -- ^ LHS type of coercion + -> DCoercion + -> Type -- ^ RHS type of coercion + -> DCoercion +downgradeDCoToRepresentational Nominal lhs dco rhs = mkSubDCo lhs dco rhs +downgradeDCoToRepresentational Representational _ dco _ = dco +downgradeDCoToRepresentational Phantom _ dco _ + = pprPanic "downgradeToRepresentationalDCo: Phantom" (ppr dco) + -- | Changes a role, but only a downgrade. See Note [Role twiddling functions] -downgradeRole_maybe :: Role -- ^ desired role +downgradeRole_maybe :: HasDebugCallStack + => Role -- ^ desired role -> Role -- ^ current role -> Coercion -> Maybe Coercion -- In (downgradeRole_maybe dr cr co) it's a precondition that @@ -1324,7 +1945,8 @@ downgradeRole_maybe Phantom _ co = Just (toPhantomCo co) -- | Like 'downgradeRole_maybe', but panics if the change isn't a downgrade. -- See Note [Role twiddling functions] -downgradeRole :: Role -- desired role +downgradeRole :: HasDebugCallStack + => Role -- desired role -> Role -- current role -> Coercion -> Coercion downgradeRole r1 r2 co @@ -1344,10 +1966,12 @@ mkProofIrrelCo :: Role -- ^ role of the created coercion, "r" -- if the two coercion prove the same fact, I just don't care what -- the individual coercions are. -mkProofIrrelCo r co g _ | isGReflCo co = mkReflCo r (mkCoercionTy g) +mkProofIrrelCo r co g _ + | isGReflCo co = mkReflCo r (mkCoercionTy g) -- kco is a kind coercion, thus @isGReflCo@ rather than @isReflCo@ -mkProofIrrelCo r kco g1 g2 = mkUnivCo (ProofIrrelProv kco) r - (mkCoercionTy g1) (mkCoercionTy g2) +mkProofIrrelCo r kco g1 g2 + = mkUnivCo (ProofIrrelProv kco) r + (mkCoercionTy g1) (mkCoercionTy g2) {- %************************************************************************ @@ -1400,14 +2024,54 @@ setNominalRole_maybe r co pprPanic "setNominalRole_maybe: the coercion should already be nominal" (ppr co) setNominalRole_maybe_helper (InstCo co arg) = InstCo <$> setNominalRole_maybe_helper co <*> pure arg + setNominalRole_maybe_helper (HydrateDCo r ty1 dco mrty) + = (\ d -> HydrateDCo Nominal ty1 d mrty) <$> setNominalRole_maybe_dco r ty1 dco setNominalRole_maybe_helper (UnivCo prov _ co1 co2) - | case prov of PhantomProv _ -> False -- should always be phantom - ProofIrrelProv _ -> True -- it's always safe - PluginProv _ -> False -- who knows? This choice is conservative. - CorePrepProv _ -> True - = Just $ UnivCo prov Nominal co1 co2 + | Just prov' <- setNominalRole_maybe_prov prov + = Just $ UnivCo prov' Nominal co1 co2 setNominalRole_maybe_helper _ = Nothing +setNominalRole_maybe_dco :: Role -> Type -> DCoercion -> Maybe DCoercion +setNominalRole_maybe_dco _ _ dco@ReflDCo = pure dco +setNominalRole_maybe_dco _ _ dco@GReflRightDCo{} = pure dco +setNominalRole_maybe_dco _ _ dco@GReflLeftDCo{} = pure dco +setNominalRole_maybe_dco _ ty (TyConAppDCo dcos) + = do { let (tc, tys) = splitTyConApp ty + ; dcos' <- zipWith3M setNominalRole_maybe_dco (tyConRoleListX Representational tc) tys dcos + ; return $ TyConAppDCo dcos' } +setNominalRole_maybe_dco r ty (AppDCo dco1 dco2) + = do { let (ty1, _) = splitAppTy ty + ; AppDCo <$> setNominalRole_maybe_dco r ty1 dco1 <*> pure dco2 + } +setNominalRole_maybe_dco r ty (ForAllDCo tv kind_co dco) + = do { let (_, body_ty) = splitForAllTyCoVar ty + ; ForAllDCo tv kind_co <$> setNominalRole_maybe_dco r body_ty dco + } +setNominalRole_maybe_dco _ _ CoVarDCo{} = Nothing +setNominalRole_maybe_dco _ _ dco@(AxiomInstDCo coax) + | coAxiomRole coax == Nominal = pure dco + | otherwise = Nothing +setNominalRole_maybe_dco _ _ StepsDCo{} = Nothing +setNominalRole_maybe_dco r ty (TransDCo dco1 dco2) + = TransDCo <$> setNominalRole_maybe_dco r ty dco1 <*> setNominalRole_maybe_dco r mid_ty dco2 + where + mid_ty = followDCo r ty dco1 + -- OK to call followDCo here: this function is always called on fully zonked types. +setNominalRole_maybe_dco _ _ (SubDCo dco) = Just dco +setNominalRole_maybe_dco r _ (DehydrateCo co) = DehydrateCo <$> setNominalRole_maybe r co +setNominalRole_maybe_dco _ _ (UnivDCo prov rhs) + | Just prov' <- setNominalRole_maybe_prov prov + = Just $ UnivDCo prov' rhs + | otherwise + = Nothing + +setNominalRole_maybe_prov :: UnivCoProvenance co -> Maybe (UnivCoProvenance co) +setNominalRole_maybe_prov prov = case prov of + PhantomProv _ -> Nothing -- should always be phantom + ProofIrrelProv _ -> Just prov -- it's always safe + PluginProv _ -> Nothing -- who knows? This choice is conservative. + CorePrepProv _ -> Just prov + -- | Make a phantom coercion between two types. The coercion passed -- in must be a nominal coercion between the kinds of the -- types. @@ -1426,6 +2090,17 @@ applyRoles :: TyCon -> [Coercion] -> [Coercion] applyRoles = zipWith (`downgradeRole` Nominal) . tyConRoleListRepresentational -- The Role parameter is the Role of the TyConAppCo +applyRoles_dco :: TyCon -> [Type] -> [DCoercion] -> [Type] -> [DCoercion] +applyRoles_dco tc l_tys dcos r_tys + = zipWith4 downgrade (tyConRoleListRepresentational tc) l_tys dcos r_tys + where + downgrade r l_ty dco r_ty = case r of + Nominal -> dco + Representational -> mkSubDCo l_ty dco r_ty + Phantom -> mkDehydrateCo $ mkPhantomCo (mkKindCo co) l_ty r_ty + where + co = mkHydrateDCo Nominal l_ty dco r_ty + -- defined here because this is intimately concerned with the implementation -- of TyConAppCo -- Always returns an infinite list (with a infinite tail of Nominal) @@ -1532,6 +2207,8 @@ promoteCoercion co = case co of UnivCo (PluginProv _) _ _ _ -> mkKindCo co UnivCo (CorePrepProv _) _ _ _ -> mkKindCo co + HydrateDCo {} -> mkKindCo co + SymCo g -> mkSymCo (promoteCoercion g) @@ -1613,17 +2290,32 @@ instCoercions g ws = do { g' <- instCoercion g_tys g w ; return (piResultTy <$> g_tys <*> w_tys, g') } +castDCoercionKind2 :: DCoercion -> CoercionN -> CoercionN -> DCoercion +castDCoercionKind2 g h1 h2 + = mkCoherenceRightDCo h2 (mkCoherenceLeftDCo h1 g) + +castDCoercionKind1 :: DCoercion -> CoercionN -> DCoercion +castDCoercionKind1 g h + = case g of + ReflDCo -> ReflDCo + GReflRightDCo kind_co -> GReflRightDCo $ + mkSymCo h `mkTransCo` kind_co `mkTransCo` h + GReflLeftDCo kind_co -> GReflLeftDCo $ + mkSymCo h `mkTransCo` kind_co `mkTransCo` h + _ -> castDCoercionKind2 g h h + + -- | Creates a new coercion with both of its types casted by different casts -- @castCoercionKind2 g r t1 t2 h1 h2@, where @g :: t1 ~r t2@, -- has type @(t1 |> h1) ~r (t2 |> h2)@. -- @h1@ and @h2@ must be nominal. castCoercionKind2 :: Coercion -> Role -> Type -> Type - -> CoercionN -> CoercionN -> Coercion + -> CoercionN -> CoercionN -> Coercion castCoercionKind2 g r t1 t2 h1 h2 = mkCoherenceRightCo r t2 h2 (mkCoherenceLeftCo r t1 h1 g) --- | @castCoercionKind1 g r t1 t2 h@ = @coercionKind g r t1 t2 h h@ --- That is, it's a specialised form of castCoercionKind, where the two +-- | @castCoercionKind1 g r t1 t2 h@ = @castCoercionKind2 g r t1 t2 h h@ +-- That is, it's a specialised form of castCoercionKind2, where the two -- kind coercions are identical -- @castCoercionKind1 g r t1 t2 h@, where @g :: t1 ~r t2@, -- has type @(t1 |> h) ~r (t2 |> h)@. @@ -1950,7 +2642,8 @@ type LiftCoEnv = VarEnv Coercion -- Also maps coercion variables to ProofIrrelCos. -- like liftCoSubstWith, but allows for existentially-bound types as well -liftCoSubstWithEx :: Role -- desired role for output coercion +liftCoSubstWithEx :: HasDebugCallStack + => Role -- desired role for output coercion -> [TyVar] -- universally quantified tyvars -> [Coercion] -- coercions to substitute for those -> [TyCoVar] -- existentially quantified tycovars @@ -2054,13 +2747,25 @@ zapLiftingContext (LC subst _) = LC (zapSubst subst) emptyVarEnv -- | Like 'substForAllCoBndr', but works on a lifting context substForAllCoBndrUsingLC :: Bool - -> (Coercion -> Coercion) - -> LiftingContext -> TyCoVar -> Coercion - -> (LiftingContext, TyCoVar, Coercion) -substForAllCoBndrUsingLC sym sco (LC subst lc_env) tv co + -> (Type -> Type) + -> (Coercion -> Coercion) + -> LiftingContext -> TyCoVar -> Coercion + -> (LiftingContext, TyCoVar, Coercion) +substForAllCoBndrUsingLC sym sty sco (LC subst lc_env) tv co + = (LC subst' lc_env, tv', co') + where + (subst', tv', co') = substForAllCoBndrUsing Co sym sty sco subst tv co + +-- | Like 'substForAllDCoBndr', but works on a lifting context +substForAllDCoBndrUsingLC :: Bool + -> (Type -> Type) + -> (DCoercion -> DCoercion) + -> LiftingContext -> TyCoVar -> DCoercion + -> (LiftingContext, TyCoVar, DCoercion) +substForAllDCoBndrUsingLC sym sty sco (LC subst lc_env) tv co = (LC subst' lc_env, tv', co') where - (subst', tv', co') = substForAllCoBndrUsing sym sco subst tv co + (subst', tv', co') = substForAllCoBndrUsing DCo sym sty sco subst tv co -- | The \"lifting\" operation which substitutes coercions for type -- variables in a type to produce a coercion. @@ -2229,6 +2934,9 @@ liftCoSubstCoVarBndrUsing view_co fun lc@(LC subst cenv) old_var eta = view_co stuff k1 = coercionLKind eta new_var = uniqAway (getSubstInScope subst) (setVarType old_var k1) + -- SLD TODO (LC): we should be able to get rid of this call to 'setVarType', + -- and thus remove this call to 'coercionLKind' entirely, if we don't store + -- the kind of the variable in ForAllCo/ForAllDCo. -- old_var :: s1 ~r s2 -- eta :: (s1' ~r s2') ~N (t1 ~r t2) @@ -2338,8 +3046,9 @@ seqCo (FunCo r af1 af2 w co1 co2) = r `seq` af1 `seq` af2 `seq` seqCo (CoVarCo cv) = cv `seq` () seqCo (HoleCo h) = coHoleCoVar h `seq` () seqCo (AxiomInstCo con ind cos) = con `seq` ind `seq` seqCos cos -seqCo (UnivCo p r t1 t2) - = seqProv p `seq` r `seq` seqType t1 `seq` seqType t2 +seqCo (HydrateDCo r t1 dco rty) = r `seq` seqType t1 `seq` seqDCo dco `seq` seqType rty +seqCo (UnivCo p r t1 t2) = seqProv seqCo p `seq` r `seq` seqType t1 + `seq` seqType t2 seqCo (SymCo co) = seqCo co seqCo (TransCo co1 co2) = seqCo co1 `seq` seqCo co2 seqCo (SelCo n co) = n `seq` seqCo co @@ -2349,16 +3058,37 @@ seqCo (KindCo co) = seqCo co seqCo (SubCo co) = seqCo co seqCo (AxiomRuleCo _ cs) = seqCos cs -seqProv :: UnivCoProvenance -> () -seqProv (PhantomProv co) = seqCo co -seqProv (ProofIrrelProv co) = seqCo co -seqProv (PluginProv _) = () -seqProv (CorePrepProv _) = () +seqDCo :: DCoercion -> () +seqDCo ReflDCo = () +seqDCo (GReflRightDCo co) = seqCo co +seqDCo (GReflLeftDCo co) = seqCo co +seqDCo (TyConAppDCo cos) = seqDCos cos +seqDCo (AppDCo co1 co2) = seqDCo co1 `seq` seqDCo co2 +seqDCo (ForAllDCo tv k co) = seqType (varType tv) `seq` seqDCo k + `seq` seqDCo co +seqDCo (CoVarDCo cv) = cv `seq` () +seqDCo (AxiomInstDCo con) = con `seq` () +seqDCo StepsDCo{} = () +seqDCo (TransDCo co1 co2) = seqDCo co1 `seq` seqDCo co2 +seqDCo (SubDCo co) = seqDCo co +seqDCo (DehydrateCo co) = seqCo co +seqDCo (UnivDCo prov rhs) = seqProv seqDCo prov `seq` seqType rhs + +seqProv :: (co -> ()) -> UnivCoProvenance co -> () +seqProv seq_co (PhantomProv co) = seq_co co +seqProv seq_co (ProofIrrelProv co) = seq_co co +seqProv _ (PluginProv _) = () +seqProv _ (CorePrepProv _) = () seqCos :: [Coercion] -> () seqCos [] = () seqCos (co:cos) = seqCo co `seq` seqCos cos +seqDCos :: [DCoercion] -> () +seqDCos [] = () +seqDCos (co:cos) = seqDCo co `seq` seqDCos cos + + {- %************************************************************************ %* * @@ -2404,6 +3134,7 @@ coercionLKind co go (CoVarCo cv) = coVarLType cv go (HoleCo h) = coVarLType (coHoleCoVar h) go (UnivCo _ _ ty1 _) = ty1 + go (HydrateDCo _ ty1 _ _) = ty1 go (SymCo co) = coercionRKind co go (TransCo co1 _) = go co1 go (LRCo lr co) = pickLR lr (splitAppTy (go co)) @@ -2465,6 +3196,7 @@ coercionRKind co {- See Note [FunCo] -} = FunTy { ft_af = af, ft_mult = go mult , ft_arg = go arg, ft_res = go res } go (UnivCo _ _ _ ty2) = ty2 + go (HydrateDCo _ _ _ rty) = rty go (SymCo co) = coercionLKind co go (TransCo _ co2) = go co2 go (LRCo lr co) = pickLR lr (splitAppTy (go co)) @@ -2571,6 +3303,7 @@ coercionRole = go go (CoVarCo cv) = coVarRole cv go (HoleCo h) = coVarRole (coHoleCoVar h) go (AxiomInstCo ax _ _) = coAxiomRole ax + go (HydrateDCo r _ _ _) = r go (UnivCo _ r _ _) = r go (SymCo co) = go co go (TransCo co1 _co2) = go co1 @@ -2747,7 +3480,7 @@ buildCoercion orig_ty1 orig_ty2 = go orig_ty1 orig_ty2 has_co_hole_ty :: Type -> Monoid.Any has_co_hole_co :: Coercion -> Monoid.Any -(has_co_hole_ty, _, has_co_hole_co, _) +(has_co_hole_ty, _, has_co_hole_co, _, _, _) = foldTyCo folder () where folder = TyCoFolder { tcf_view = noView @@ -2770,7 +3503,7 @@ hasCoercionHoleCo = Monoid.getAny . has_co_hole_co hasThisCoercionHoleTy :: Type -> CoercionHole -> Bool hasThisCoercionHoleTy ty hole = Monoid.getAny (f ty) where - (f, _, _, _) = foldTyCo folder () + (f, _, _, _, _, _) = foldTyCo folder () folder = TyCoFolder { tcf_view = noView , tcf_tyvar = const2 (Monoid.Any False) diff --git a/compiler/GHC/Core/Coercion.hs-boot b/compiler/GHC/Core/Coercion.hs-boot index 276a48cf81..6430e3f6ee 100644 --- a/compiler/GHC/Core/Coercion.hs-boot +++ b/compiler/GHC/Core/Coercion.hs-boot @@ -23,7 +23,7 @@ mkFunCo2 :: Role -> FunTyFlag -> FunTyFlag -> CoercionN -> Coercion -> Coerc mkCoVarCo :: CoVar -> Coercion mkAxiomInstCo :: CoAxiom Branched -> BranchIndex -> [Coercion] -> Coercion mkPhantomCo :: Coercion -> Type -> Type -> Coercion -mkUnivCo :: UnivCoProvenance -> Role -> Type -> Type -> Coercion +mkUnivCo :: UnivCoProvenance Coercion -> Role -> Type -> Type -> Coercion mkSymCo :: Coercion -> Coercion mkTransCo :: Coercion -> Coercion -> Coercion mkSelCo :: HasDebugCallStack => CoSel -> Coercion -> Coercion @@ -38,6 +38,20 @@ mkAxiomRuleCo :: CoAxiomRule -> [Coercion] -> Coercion funRole :: Role -> FunSel -> Role +mkTyConAppDCo :: [DCoercion] -> DCoercion +mkAppDCo :: DCoercion -> DCoercion -> DCoercion +mkTransDCo :: DCoercion -> DCoercion -> DCoercion +mkForAllDCo :: TyCoVar -> DCoercion -> DCoercion -> DCoercion +mkReflDCo :: DCoercion +mkGReflRightDCo :: CoercionN -> DCoercion +mkGReflLeftDCo :: CoercionN -> DCoercion +mkDehydrateCo :: Coercion -> DCoercion +mkHydrateDCo :: HasDebugCallStack => Role -> Type -> DCoercion -> Type -> Coercion +mkCoVarDCo :: CoVar -> DCoercion +mkUnivDCo :: UnivCoProvenance DCoercion -> Type -> DCoercion +mkSubDCo :: HasDebugCallStack => Type -> DCoercion -> Type -> DCoercion +followDCo :: HasDebugCallStack => Role -> Type -> DCoercion -> Type + isGReflCo :: Coercion -> Bool isReflCo :: Coercion -> Bool isReflexiveCo :: Coercion -> Bool diff --git a/compiler/GHC/Core/Coercion/Opt.hs b/compiler/GHC/Core/Coercion/Opt.hs index 98506c444e..8df3dc31e5 100644 --- a/compiler/GHC/Core/Coercion/Opt.hs +++ b/compiler/GHC/Core/Coercion/Opt.hs @@ -1,10 +1,15 @@ -- (c) The University of Glasgow 2006 {-# LANGUAGE CPP #-} +{-# LANGUAGE GADTs #-} +{-# LANGUAGE StandaloneKindSignatures #-} +{-# LANGUAGE TypeFamilies #-} +{-# LANGUAGE ViewPatterns #-} module GHC.Core.Coercion.Opt ( optCoercion , OptCoercionOpts (..) + , OptDCoMethod (..) ) where @@ -21,6 +26,7 @@ import GHC.Core.TyCon import GHC.Core.Coercion.Axiom import GHC.Core.Unify +import GHC.Types.Var import GHC.Types.Var.Set import GHC.Types.Var.Env import GHC.Types.Unique.Set @@ -35,6 +41,7 @@ import GHC.Utils.Panic import GHC.Utils.Panic.Plain import Control.Monad ( zipWithM ) +import qualified Data.Kind ( Type ) {- %************************************************************************ @@ -123,31 +130,40 @@ So we substitute the coercion variable c for the coercion -- | Coercion optimisation options newtype OptCoercionOpts = OptCoercionOpts - { optCoercionEnabled :: Bool -- ^ Enable coercion optimisation (reduce its size) + { optCoercionOpts :: Maybe OptDCoMethod + -- ^ @Nothing@: no coercion optimisation. + -- ^ @Just opt@: do full coercion optimisation, with @opt@ specifying + -- how to deal with directed coercions. } +data OptDCoMethod + = HydrateDCos + -- ^ Turn directed coercions back into fully-fledged coercions in the + -- coercion optimiser, so that they can be fully optimised. + | OptDCos + -- ^ Optimise directed coercions with the (currently limited) + -- forms of optimisation avaiable for directed coercions. + { skipDCoOpt :: !Bool + -- ^ Whether to skip optimisation of directed coercions entirely + -- when possible. + } + +data OptCoParams = + OptCoParams { optDCoMethod :: !OptDCoMethod } + optCoercion :: OptCoercionOpts -> Subst -> Coercion -> NormalCo -- ^ optCoercion applies a substitution to a coercion, -- *and* optimises it to reduce its size -optCoercion opts env co - | optCoercionEnabled opts - = optCoercion' env co -{- - = pprTrace "optCoercion {" (text "Co:" <+> ppr co) $ - let result = optCoercion' env co in - pprTrace "optCoercion }" (vcat [ text "Co:" <+> ppr co - , text "Optco:" <+> ppr result ]) $ - result --} - - | otherwise - = substCo env co - - -optCoercion' :: Subst -> Coercion -> NormalCo -optCoercion' env co +optCoercion (OptCoercionOpts opts) env co + | Just dco_method <- opts = optCoercion' + (OptCoParams { optDCoMethod = dco_method }) env + $ co + | otherwise = substCo env $ co + +optCoercion' :: OptCoParams -> Subst -> Coercion -> NormalCo +optCoercion' opts env co | debugIsOn - = let out_co = opt_co1 lc False co + = let out_co = opt_co1 opts lc False co (Pair in_ty1 in_ty2, in_role) = coercionKindRole co (Pair out_ty1 out_ty2, out_role) = coercionKindRole out_co in @@ -167,7 +183,7 @@ optCoercion' env co , text "subst:" <+> ppr env ])) out_co - | otherwise = opt_co1 lc False co + | otherwise = opt_co1 opts lc False co where lc = mkSubstLiftingContext env ppr_one cv = ppr cv <+> dcolon <+> ppr (coVarKind cv) @@ -179,7 +195,10 @@ type NormalCo = Coercion -- * For trans coercions (co1 `trans` co2) -- co1 is not a trans, and neither co1 nor co2 is identity +type NormalDCo = DCoercion + type NormalNonIdCo = NormalCo -- Extra invariant: not the identity +type NormalNonIdDCo = NormalDCo -- Extra invariant: not the identity -- | Do we apply a @sym@ to the result? type SymFlag = Bool @@ -189,65 +208,71 @@ type ReprFlag = Bool -- | Optimize a coercion, making no assumptions. All coercions in -- the lifting context are already optimized (and sym'd if nec'y) -opt_co1 :: LiftingContext +opt_co1 :: OptCoParams + -> LiftingContext -> SymFlag -> Coercion -> NormalCo -opt_co1 env sym co = opt_co2 env sym (coercionRole co) co +opt_co1 opts env sym co = opt_co2 opts env sym (coercionRole co) co -- See Note [Optimising coercion optimisation] -- | Optimize a coercion, knowing the coercion's role. No other assumptions. -opt_co2 :: LiftingContext +opt_co2 :: OptCoParams + -> LiftingContext -> SymFlag -> Role -- ^ The role of the input coercion -> Coercion -> NormalCo -opt_co2 env sym Phantom co = opt_phantom env sym co -opt_co2 env sym r co = opt_co3 env sym Nothing r co +opt_co2 opts env sym Phantom co = opt_phantom opts env sym co +opt_co2 opts env sym r co = opt_co3 opts env sym Nothing r co -- See Note [Optimising coercion optimisation] -- | Optimize a coercion, knowing the coercion's non-Phantom role. -opt_co3 :: LiftingContext -> SymFlag -> Maybe Role -> Role -> Coercion -> NormalCo -opt_co3 env sym (Just Phantom) _ co = opt_phantom env sym co -opt_co3 env sym (Just Representational) r co = opt_co4_wrap env sym True r co +opt_co3 :: OptCoParams -> LiftingContext -> SymFlag -> Maybe Role -> Role -> Coercion -> NormalCo +opt_co3 opts env sym (Just Phantom) _ co = opt_phantom opts env sym co +opt_co3 opts env sym (Just Representational) r co = opt_co4 opts env sym True r co -- if mrole is Just Nominal, that can't be a downgrade, so we can ignore -opt_co3 env sym _ r co = opt_co4_wrap env sym False r co +opt_co3 opts env sym _ r co = opt_co4 opts env sym False r co + +-- | Utility function for debugging coercion optimisation: uncomment +-- the logging functions in the body of this function, and the coercion +-- optimiser will produce a log of what it is doing. +wrap :: (Outputable in_co, Outputable out_co) => String -> Optimiser in_co out_co -> Optimiser in_co out_co +wrap _str opt_thing opts env sym rep r co + = {- pprTrace (_str ++ " wrap {") + ( vcat [ text "Sym:" <+> ppr sym + , text "Rep:" <+> ppr rep + , text "Role:" <+> ppr r + , text "Co:" <+> ppr co + , text "LC:" <+> ppr env + , text "Subst:" <+> ppr (lcTCvSubst env)]) $ + --assert (r == coercionRole co) + pprTrace (_str ++ " wrap }") (ppr co $$ text "---" $$ ppr result) $ -} + result + where result = opt_thing opts env sym rep r co -- See Note [Optimising coercion optimisation] -- | Optimize a non-phantom coercion. -opt_co4, opt_co4_wrap :: LiftingContext -> SymFlag -> ReprFlag - -> Role -> Coercion -> NormalCo +opt_co4_wrap :: String -> OptCoParams -> LiftingContext -> SymFlag -> ReprFlag -> Role -> Coercion -> NormalCo -- Precondition: In every call (opt_co4 lc sym rep role co) -- we should have role = coercionRole co -opt_co4_wrap = opt_co4 - -{- -opt_co4_wrap env sym rep r co - = pprTrace "opt_co4_wrap {" - ( vcat [ text "Sym:" <+> ppr sym - , text "Rep:" <+> ppr rep - , text "Role:" <+> ppr r - , text "Co:" <+> ppr co ]) $ - assert (r == coercionRole co ) $ - let result = opt_co4 env sym rep r co in - pprTrace "opt_co4_wrap }" (ppr co $$ text "---" $$ ppr result) $ - result --} +opt_co4_wrap str opts env sym rep r co = wrap ("opt_co4 " ++ str) opt_co4 opts env sym rep r co -opt_co4 env _ rep r (Refl ty) +opt_co4 :: OptCoParams -> LiftingContext -> SymFlag -> ReprFlag -> Role -> Coercion -> NormalCo +opt_co4 _ env _ rep r (Refl ty) = assertPpr (r == Nominal) (text "Expected role:" <+> ppr r $$ text "Found role:" <+> ppr Nominal $$ text "Type:" <+> ppr ty) $ liftCoSubst (chooseRole rep r) env ty -opt_co4 env _ rep r (GRefl _r ty MRefl) +opt_co4 _ env _ rep r (GRefl _r ty MRefl) = assertPpr (r == _r) (text "Expected role:" <+> ppr r $$ text "Found role:" <+> ppr _r $$ text "Type:" <+> ppr ty) $ liftCoSubst (chooseRole rep r) env ty -opt_co4 env sym rep r (GRefl _r ty (MCo co)) +opt_co4 opts env sym rep r (GRefl _r ty (MCo co)) = assertPpr (r == _r) (text "Expected role:" <+> ppr r $$ text "Found role:" <+> ppr _r $$ @@ -258,58 +283,58 @@ opt_co4 env sym rep r (GRefl _r ty (MCo co)) where r' = chooseRole rep r ty' = substTy (lcSubstLeft env) ty - co' = opt_co4 env False False Nominal co + co' = opt_co4 opts env False False Nominal co -opt_co4 env sym rep r (SymCo co) = opt_co4_wrap env (not sym) rep r co +opt_co4 opts env sym rep r (SymCo co) = opt_co4_wrap "SymCo" opts env (not sym) rep r co -- surprisingly, we don't have to do anything to the env here. This is -- because any "lifting" substitutions in the env are tied to ForAllCos, -- which treat their left and right sides differently. We don't want to -- exchange them. -opt_co4 env sym rep r g@(TyConAppCo _r tc cos) +opt_co4 opts env sym rep r g@(TyConAppCo _r tc cos) = assert (r == _r) $ case (rep, r) of (True, Nominal) -> mkTyConAppCo Representational tc - (zipWith3 (opt_co3 env sym) + (zipWith3 (opt_co3 opts env sym) (map Just (tyConRoleListRepresentational tc)) (repeat Nominal) cos) (False, Nominal) -> - mkTyConAppCo Nominal tc (map (opt_co4_wrap env sym False Nominal) cos) + mkTyConAppCo Nominal tc (map (opt_co4_wrap "TyConAppCo (False, Nominal)" opts env sym False Nominal) cos) (_, Representational) -> -- must use opt_co2 here, because some roles may be P -- See Note [Optimising coercion optimisation] - mkTyConAppCo r tc (zipWith (opt_co2 env sym) + mkTyConAppCo r tc (zipWith (opt_co2 opts env sym) (tyConRoleListRepresentational tc) -- the current roles cos) (_, Phantom) -> pprPanic "opt_co4 sees a phantom!" (ppr g) -opt_co4 env sym rep r (AppCo co1 co2) - = mkAppCo (opt_co4_wrap env sym rep r co1) - (opt_co4_wrap env sym False Nominal co2) +opt_co4 opts env sym rep r (AppCo co1 co2) + = mkAppCo (opt_co4_wrap "AppCo co1" opts env sym rep r co1) + (opt_co4_wrap "AppCo co2" opts env sym False Nominal co2) -opt_co4 env sym rep r (ForAllCo tv k_co co) - = case optForAllCoBndr env sym tv k_co of +opt_co4 opts env sym rep r (ForAllCo tv k_co co) + = case optForAllCoBndr opts env sym tv k_co of (env', tv', k_co') -> mkForAllCo tv' k_co' $ - opt_co4_wrap env' sym rep r co + opt_co4_wrap "ForAllCo" opts env' sym rep r co -- Use the "mk" functions to check for nested Refls -opt_co4 env sym rep r (FunCo _r afl afr cow co1 co2) +opt_co4 opts env sym rep r (FunCo _r afl afr cow co1 co2) = assert (r == _r) $ mkFunCo2 r' afl' afr' cow' co1' co2' where - co1' = opt_co4_wrap env sym rep r co1 - co2' = opt_co4_wrap env sym rep r co2 - cow' = opt_co1 env sym cow + co1' = opt_co4_wrap "FunCo co1" opts env sym rep r co1 + co2' = opt_co4_wrap "FunCo co2" opts env sym rep r co2 + cow' = opt_co1 opts env sym cow !r' | rep = Representational | otherwise = r !(afl', afr') | sym = (afr,afl) | otherwise = (afl,afr) -opt_co4 env sym rep r (CoVarCo cv) +opt_co4 opts env sym rep r (CoVarCo cv) | Just co <- lookupCoVar (lcSubst env) cv - = opt_co4_wrap (zapLiftingContext env) sym rep r co + = opt_co4_wrap "CoVarCo" opts (zapLiftingContext env) sym rep r co | ty1 `eqType` ty2 -- See Note [Optimise CoVarCo to Refl] = mkReflCo (chooseRole rep r) ty1 @@ -330,10 +355,10 @@ opt_co4 env sym rep r (CoVarCo cv) cv -- cv1 might have a substituted kind! -opt_co4 _ _ _ _ (HoleCo h) +opt_co4 _ _ _ _ _ (HoleCo h) = pprPanic "opt_univ fell into a hole" (ppr h) -opt_co4 env sym rep r (AxiomInstCo con ind cos) +opt_co4 opts env sym rep r (AxiomInstCo con ind cos) -- Do *not* push sym inside top-level axioms -- e.g. if g is a top-level axiom -- g a : f a ~ a @@ -343,43 +368,64 @@ opt_co4 env sym rep r (AxiomInstCo con ind cos) wrapSym sym $ -- some sub-cos might be P: use opt_co2 -- See Note [Optimising coercion optimisation] - AxiomInstCo con ind (zipWith (opt_co2 env False) + AxiomInstCo con ind (zipWith (opt_co2 opts env False) (coAxBranchRoles (coAxiomNthBranch con ind)) cos) -- Note that the_co does *not* have sym pushed into it -opt_co4 env sym rep r (UnivCo prov _r t1 t2) - = assert (r == _r ) - opt_univ env sym prov (chooseRole rep r) t1 t2 +opt_co4 opts env@(LC _ _lift_co_env) sym rep r (HydrateDCo _r lhs_ty dco rhs_ty) + = case optDCoMethod opts of + HydrateDCos -> + opt_co4 opts env sym rep r (hydrateOneLayerDCo r lhs_ty dco) + OptDCos { skipDCoOpt = do_skip } + | do_skip && isEmptyVarEnv _lift_co_env + -> let res = substCo (lcSubst env) (HydrateDCo r lhs_ty dco rhs_ty) + in assert (r == _r) $ + wrapSym sym $ + wrapRole rep r $ + res + | otherwise + -> assert (r == _r) $ + wrapSym sym $ + (\ (lhs', dco') -> mkHydrateDCo r' lhs' dco' rhs') $ + opt_dco4_wrap "HydrateDCo" opts env rep r lhs_ty dco + where + rhs' = substTyUnchecked (lcSubstRight env) rhs_ty + r' = chooseRole rep r + +opt_co4 opts env sym rep r (UnivCo prov _r t1 t2) + = assert (r == _r) $ + opt_univ Co opts env sym prov (chooseRole rep r) t1 t2 -opt_co4 env sym rep r (TransCo co1 co2) +opt_co4 opts env sym rep r (TransCo co1 co2) -- sym (g `o` h) = sym h `o` sym g - | sym = opt_trans in_scope co2' co1' - | otherwise = opt_trans in_scope co1' co2' + | sym = opt_trans opts in_scope co2' co1' + | otherwise = opt_trans opts in_scope co1' co2' + where - co1' = opt_co4_wrap env sym rep r co1 - co2' = opt_co4_wrap env sym rep r co2 + co1' = opt_co4_wrap "TransCo co1" opts env sym rep r co1 + co2' = opt_co4_wrap "TransCo co2" opts env sym rep r co2 in_scope = lcInScopeSet env -opt_co4 env _sym rep r (SelCo n co) +opt_co4 _ env _sym rep r (SelCo n co) | Just (ty, _co_role) <- isReflCo_maybe co = liftCoSubst (chooseRole rep r) env (getNthFromType n ty) -- NB: it is /not/ true that r = _co_role -- Rather, r = coercionRole (SelCo n co) -opt_co4 env sym rep r (SelCo (SelTyCon n r1) (TyConAppCo _ _ cos)) +opt_co4 opts env sym rep r (SelCo (SelTyCon n r1) (TyConAppCo _ _ cos)) = assert (r == r1 ) - opt_co4_wrap env sym rep r (cos `getNth` n) + opt_co4_wrap "SelTyCon" opts env sym rep r (cos `getNth` n) -- see the definition of GHC.Builtin.Types.Prim.funTyCon -opt_co4 env sym rep r (SelCo (SelFun fs) (FunCo _r2 _afl _afr w co1 co2)) - = opt_co4_wrap env sym rep r (getNthFun fs w co1 co2) +opt_co4 opts env sym rep r (SelCo (SelFun fs) (FunCo _r2 _afl _afr w co1 co2)) + = opt_co4_wrap "SelFun" opts env sym rep r (getNthFun fs w co1 co2) -opt_co4 env sym rep _ (SelCo SelForAll (ForAllCo _ eta _)) +opt_co4 opts env sym rep _ (SelCo SelForAll (ForAllCo _ eta _)) -- works for both tyvar and covar - = opt_co4_wrap env sym rep Nominal eta + = opt_co4_wrap "SelForAll" opts env sym rep Nominal eta -opt_co4 env sym rep r (SelCo n co) +opt_co4 opts env sym rep r (SelCo n co) | Just nth_co <- case (co', n) of (TyConAppCo _ _ cos, SelTyCon n _) -> Just (cos `getNth` n) (FunCo _ _ _ w co1 co2, SelFun fs) -> Just (getNthFun fs w co1 co2) @@ -387,71 +433,73 @@ opt_co4 env sym rep r (SelCo n co) _ -> Nothing = if rep && (r == Nominal) -- keep propagating the SubCo - then opt_co4_wrap (zapLiftingContext env) False True Nominal nth_co + then opt_co4_wrap "NthCo" opts (zapLiftingContext env) False True Nominal nth_co else nth_co | otherwise = wrapRole rep r $ SelCo n co' where - co' = opt_co1 env sym co + co' = opt_co1 opts env sym co -opt_co4 env sym rep r (LRCo lr co) +opt_co4 opts env sym rep r (LRCo lr co) | Just pr_co <- splitAppCo_maybe co = assert (r == Nominal ) - opt_co4_wrap env sym rep Nominal (pick_lr lr pr_co) + opt_co4_wrap "LrCO AppCo" opts env sym rep Nominal (pick_lr lr pr_co) | Just pr_co <- splitAppCo_maybe co' = assert (r == Nominal) $ if rep - then opt_co4_wrap (zapLiftingContext env) False True Nominal (pick_lr lr pr_co) + then opt_co4_wrap "LrCo AppCo'" opts (zapLiftingContext env) False True Nominal (pick_lr lr pr_co) else pick_lr lr pr_co | otherwise = wrapRole rep Nominal $ LRCo lr co' where - co' = opt_co4_wrap env sym False Nominal co + co' = opt_co4_wrap "LrCo co'" opts env sym False Nominal co pick_lr CLeft (l, _) = l pick_lr CRight (_, r) = r -- See Note [Optimising InstCo] -opt_co4 env sym rep r (InstCo co1 arg) +opt_co4 opts env sym rep r (InstCo co1 arg) -- forall over type... | Just (tv, kind_co, co_body) <- splitForAllCo_ty_maybe co1 - = opt_co4_wrap (extendLiftingContext env tv - (mkCoherenceRightCo Nominal t2 (mkSymCo kind_co) sym_arg)) - -- mkSymCo kind_co :: k1 ~ k2 - -- sym_arg :: (t1 :: k1) ~ (t2 :: k2) - -- tv |-> (t1 :: k1) ~ (((t2 :: k2) |> (sym kind_co)) :: k1) - sym rep r co_body + = opt_co4_wrap "InstCo ForAllTy" opts + (extendLiftingContext env tv + (mkCoherenceRightCo Nominal t2 (mkSymCo kind_co) sym_arg)) + -- mkSymCo kind_co :: k1 ~ k2 + -- sym_arg :: (t1 :: k1) ~ (t2 :: k2) + -- tv |-> (t1 :: k1) ~ (((t2 :: k2) |> (sym kind_co)) :: k1) + sym rep r co_body -- forall over coercion... | Just (cv, kind_co, co_body) <- splitForAllCo_co_maybe co1 , CoercionTy h1 <- t1 , CoercionTy h2 <- t2 - = let new_co = mk_new_co cv (opt_co4_wrap env sym False Nominal kind_co) h1 h2 - in opt_co4_wrap (extendLiftingContext env cv new_co) sym rep r co_body + = let new_co = mk_new_co cv (opt_co4_wrap "InstCo kind_co" opts env sym False Nominal kind_co) h1 h2 + in opt_co4_wrap "InstCo ForAllCo" opts (extendLiftingContext env cv new_co) sym rep r co_body -- See if it is a forall after optimization -- If so, do an inefficient one-variable substitution, then re-optimize -- forall over type... | Just (tv', kind_co', co_body') <- splitForAllCo_ty_maybe co1' - = opt_co4_wrap (extendLiftingContext (zapLiftingContext env) tv' - (mkCoherenceRightCo Nominal t2' (mkSymCo kind_co') arg')) - False False r' co_body' + = opt_co4_wrap "InstCo ForAllTy 2" opts + (extendLiftingContext (zapLiftingContext env) tv' + (mkCoherenceRightCo Nominal t2' (mkSymCo kind_co') arg')) + False False r' co_body' -- forall over coercion... | Just (cv', kind_co', co_body') <- splitForAllCo_co_maybe co1' , CoercionTy h1' <- t1' , CoercionTy h2' <- t2' = let new_co = mk_new_co cv' kind_co' h1' h2' - in opt_co4_wrap (extendLiftingContext (zapLiftingContext env) cv' new_co) + in opt_co4_wrap "InstCo ForAllCo 2" opts (extendLiftingContext (zapLiftingContext env) cv' new_co) False False r' co_body' | otherwise = InstCo co1' arg' where - co1' = opt_co4_wrap env sym rep r co1 + co1' = opt_co4_wrap "InstCo recur co1" opts env sym rep r co1 r' = chooseRole rep r - arg' = opt_co4_wrap env sym False Nominal arg + arg' = opt_co4_wrap "InstCo recur arg" opts env sym False Nominal arg sym_arg = wrapSym sym arg' -- Performance note: don't be alarmed by the two calls to coercionKind @@ -479,25 +527,28 @@ opt_co4 env sym rep r (InstCo co1 arg) in mkProofIrrelCo Nominal (Refl (coercionType h1)) h1 (n1 `mkTransCo` h2 `mkTransCo` (mkSymCo n2)) -opt_co4 env sym _rep r (KindCo co) +opt_co4 opts env sym _rep r (KindCo co) = assert (r == Nominal) $ let kco' = promoteCoercion co in case kco' of - KindCo co' -> promoteCoercion (opt_co1 env sym co') - _ -> opt_co4_wrap env sym False Nominal kco' + KindCo co' -> promoteCoercion (opt_co1 opts env sym co') + _ -> opt_co4_wrap "KindCo" opts env sym False Nominal kco' -- This might be able to be optimized more to do the promotion -- and substitution/optimization at the same time -opt_co4 env sym _ r (SubCo co) - = assert (r == Representational) $ - opt_co4_wrap env sym True Nominal co +opt_co4 opts env sym _ _r (SubCo co) + = assert (_r == Representational) $ + let res = opt_co4_wrap "SubCo" opts env sym True Nominal co + in case coercionRole res of + Nominal -> SubCo res + _ -> res -- This could perhaps be optimized more. -opt_co4 env sym rep r (AxiomRuleCo co cs) +opt_co4 opts env sym rep r (AxiomRuleCo co cs) = assert (r == coaxrRole co) $ wrapRole rep r $ wrapSym sym $ - AxiomRuleCo co (zipWith (opt_co2 env False) (coaxrAsmpRoles co) cs) + AxiomRuleCo co (zipWith (opt_co2 opts env False) (coaxrAsmpRoles co) cs) {- Note [Optimise CoVarCo to Refl] ~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~ @@ -511,9 +562,9 @@ in GHC.Core.Coercion. ------------- -- | Optimize a phantom coercion. The input coercion may not necessarily -- be a phantom, but the output sure will be. -opt_phantom :: LiftingContext -> SymFlag -> Coercion -> NormalCo -opt_phantom env sym co - = opt_univ env sym (PhantomProv (mkKindCo co)) Phantom ty1 ty2 +opt_phantom :: OptCoParams -> LiftingContext -> SymFlag -> Coercion -> NormalCo +opt_phantom opts env sym co + = opt_univ Co opts env sym (PhantomProv (mkKindCo co)) Phantom ty1 ty2 where Pair ty1 ty2 = coercionKind co @@ -548,17 +599,41 @@ See #19509. -} -opt_univ :: LiftingContext -> SymFlag -> UnivCoProvenance -> Role - -> Type -> Type -> Coercion -opt_univ env sym (PhantomProv h) _r ty1 ty2 - | sym = mkPhantomCo h' ty2' ty1' - | otherwise = mkPhantomCo h' ty1' ty2' +type OptRes :: Data.Kind.Type -> Data.Kind.Type +type family OptRes co_or_dco where + OptRes Coercion = Coercion + OptRes DCoercion = ( Type, DCoercion ) + +type Optimiser in_co out_co = + OptCoParams -> LiftingContext -> SymFlag -> ReprFlag -> Role -> in_co -> out_co + +opt_co_or_dco :: CoOrDCo co_or_dco -> Type -> Optimiser co_or_dco co_or_dco +opt_co_or_dco Co _ = opt_co4 +opt_co_or_dco DCo l_ty = \ opts lc sym repr r dco -> + assert (sym == False) $ + snd $ + opt_dco4 opts lc repr r l_ty dco + +opt_univ :: forall co_or_dco + . Outputable co_or_dco + => CoOrDCo co_or_dco + -> OptCoParams + -> LiftingContext -> SymFlag -> UnivCoProvenance co_or_dco -> Role + -> Type -> Type -> OptRes co_or_dco +opt_univ co_or_dco opts env sym (PhantomProv h) _r ty1 ty2 + | sym = mk_phantom h' ty2' ty1' + | otherwise = mk_phantom h' ty1' ty2' where - h' = opt_co4 env sym False Nominal h + h' = wrap "opt_univ PhantomProv" (opt_co_or_dco co_or_dco ty1) opts env sym False Nominal h ty1' = substTy (lcSubstLeft env) ty1 ty2' = substTy (lcSubstRight env) ty2 -opt_univ env sym prov role oty1 oty2 + mk_phantom :: co_or_dco -> Type -> Type -> OptRes co_or_dco + mk_phantom = case co_or_dco of + Co -> mkPhantomCo + DCo -> \ h t1 t2 -> (t1, mkUnivDCo (PhantomProv h) t2) + +opt_univ co_or_dco opts env sym prov role oty1 oty2 | Just (tc1, tys1) <- splitTyConApp_maybe oty1 , Just (tc2, tys2) <- splitTyConApp_maybe oty2 , tc1 == tc2 @@ -567,10 +642,19 @@ opt_univ env sym prov role oty1 oty2 -- NB: prov must not be the two interesting ones (ProofIrrel & Phantom); -- Phantom is already taken care of, and ProofIrrel doesn't relate tyconapps = let roles = tyConRoleListX role tc1 - arg_cos = zipWith3 (mkUnivCo prov') roles tys1 tys2 - arg_cos' = zipWith (opt_co4 env sym False) roles arg_cos - in - mkTyConAppCo role tc1 arg_cos' + in case co_or_dco of + Co -> + let + arg_cos = zipWith3 mk_univ roles tys1 tys2 + arg_cos' = zipWith (opt_co4 opts env sym False) roles arg_cos + in + mkTyConAppCo role tc1 arg_cos' + DCo -> + let + arg_cos = zipWith3 (\ r x y -> snd $ mk_univ r x y) roles tys1 tys2 + (arg_lhs', arg_dcos') = unzip $ zipWith3 (opt_dco4 opts env False) roles tys1 arg_cos + in + (mkTyConApp tc1 arg_lhs', mkTyConAppDCo arg_dcos') -- can't optimize the AppTy case because we can't build the kind coercions. @@ -579,13 +663,16 @@ opt_univ env sym prov role oty1 oty2 -- NB: prov isn't interesting here either = let k1 = tyVarKind tv1 k2 = tyVarKind tv2 - eta = mkUnivCo prov' Nominal k1 k2 + eta = case co_or_dco of + Co -> mk_univ Nominal k1 k2 + DCo -> snd $ mk_univ Nominal k1 k2 + tv1' = mk_castTy (TyVarTy tv1) k1 eta k2 -- eta gets opt'ed soon, but not yet. - ty2' = substTyWith [tv2] [TyVarTy tv1 `mkCastTy` eta] ty2 + ty2' = substTyWith [tv2] [tv1'] ty2 - (env', tv1', eta') = optForAllCoBndr env sym tv1 eta + (env', tv1'', eta') = opt_forall tv1 eta in - mkForAllCo tv1' eta' (opt_univ env' sym prov' role ty1 ty2') + mk_forall tv1'' eta' (opt_univ co_or_dco opts env' sym prov' role ty1 ty2') | Just (cv1, ty1) <- splitForAllCoVar_maybe oty1 , Just (cv2, ty2) <- splitForAllCoVar_maybe oty2 @@ -593,17 +680,22 @@ opt_univ env sym prov role oty1 oty2 = let k1 = varType cv1 k2 = varType cv2 r' = coVarRole cv1 - eta = mkUnivCo prov' Nominal k1 k2 - eta_d = downgradeRole r' Nominal eta + eta = case co_or_dco of + Co -> mk_univ Nominal k1 k2 + DCo -> snd $ mk_univ Nominal k1 k2 + eta_d = downgradeRole r' Nominal $ + case co_or_dco of + Co -> eta + DCo -> mkHydrateDCo Nominal k1 eta k2 -- eta gets opt'ed soon, but not yet. n_co = (mkSymCo $ mkSelCo (SelTyCon 2 r') eta_d) `mkTransCo` (mkCoVarCo cv1) `mkTransCo` (mkSelCo (SelTyCon 3 r') eta_d) ty2' = substTyWithCoVars [cv2] [n_co] ty2 - (env', cv1', eta') = optForAllCoBndr env sym cv1 eta + (env', cv1', eta') = opt_forall cv1 eta in - mkForAllCo cv1' eta' (opt_univ env' sym prov' role ty1 ty2') + mk_forall cv1' eta' (opt_univ co_or_dco opts env' sym prov' role ty1 ty2') | otherwise = let ty1 = substTyUnchecked (lcSubstLeft env) oty1 @@ -611,87 +703,122 @@ opt_univ env sym prov role oty1 oty2 (a, b) | sym = (ty2, ty1) | otherwise = (ty1, ty2) in - mkUnivCo prov' role a b + mk_univ role a b where + mk_castTy :: Type -> Type -> co_or_dco -> Type -> Type + mk_castTy = case co_or_dco of + Co -> \ ty _ co _ -> CastTy ty co + DCo -> \ ty l dco r -> CastTy ty (mkHydrateDCo Nominal l dco r) + mk_univ :: Role -> Type -> Type -> OptRes co_or_dco + mk_univ = case co_or_dco of + Co -> mkUnivCo prov' + DCo -> \ _ l_ty r_ty -> (l_ty, mkUnivDCo prov' r_ty) + mk_forall :: TyCoVar -> co_or_dco -> OptRes co_or_dco -> OptRes co_or_dco + mk_forall cv eta = case co_or_dco of + Co -> mkForAllCo cv eta + DCo -> \ (_,body) -> (mkTyVarTy cv, mkForAllDCo cv eta body) + opt_forall :: TyCoVar -> co_or_dco -> (LiftingContext,TyCoVar,co_or_dco) + opt_forall tv co = case co_or_dco of + Co -> optForAllCoBndr opts env sym tv co + DCo -> optForAllDCoBndr opts env sym tv co + prov' :: UnivCoProvenance co_or_dco prov' = case prov of #if __GLASGOW_HASKELL__ < 901 -- This alt is redundant with the first match of the FunDef - PhantomProv kco -> PhantomProv $ opt_co4_wrap env sym False Nominal kco + PhantomProv kco -> PhantomProv + $ wrap "univ_co phantom" (opt_co_or_dco co_or_dco oty1) + opts env sym False Nominal kco #endif - ProofIrrelProv kco -> ProofIrrelProv $ opt_co4_wrap env sym False Nominal kco - PluginProv _ -> prov - CorePrepProv _ -> prov + ProofIrrelProv kco -> ProofIrrelProv + $ wrap "univ_co proof_irrel" (opt_co_or_dco co_or_dco oty1) + opts env sym False Nominal kco + PluginProv str -> PluginProv str + CorePrepProv homo -> CorePrepProv homo ------------- -opt_transList :: HasDebugCallStack => InScopeSet -> [NormalCo] -> [NormalCo] -> [NormalCo] -opt_transList is = zipWithEqual "opt_transList" (opt_trans is) +opt_transList :: HasDebugCallStack => OptCoParams -> InScopeSet -> [NormalCo] -> [NormalCo] -> [NormalCo] +opt_transList opts is = zipWithEqual "opt_transList" (opt_trans opts is) -- The input lists must have identical length. -opt_trans :: InScopeSet -> NormalCo -> NormalCo -> NormalCo -opt_trans is co1 co2 +opt_trans :: OptCoParams -> InScopeSet -> NormalCo -> NormalCo -> NormalCo +opt_trans opts is co1 co2 | isReflCo co1 = co2 -- optimize when co1 is a Refl Co - | otherwise = opt_trans1 is co1 co2 + | otherwise = opt_trans1 opts is co1 co2 -opt_trans1 :: InScopeSet -> NormalNonIdCo -> NormalCo -> NormalCo +opt_trans1 :: OptCoParams -> InScopeSet -> NormalNonIdCo -> NormalCo -> NormalCo -- First arg is not the identity -opt_trans1 is co1 co2 +opt_trans1 opts is co1 co2 | isReflCo co2 = co1 -- optimize when co2 is a Refl Co - | otherwise = opt_trans2 is co1 co2 + | otherwise = opt_trans2 opts is co1 co2 -opt_trans2 :: InScopeSet -> NormalNonIdCo -> NormalNonIdCo -> NormalCo +opt_trans2 :: OptCoParams -> InScopeSet -> NormalNonIdCo -> NormalNonIdCo -> NormalCo -- Neither arg is the identity -opt_trans2 is (TransCo co1a co1b) co2 +opt_trans2 opts is (TransCo co1a co1b) co2 -- Don't know whether the sub-coercions are the identity - = opt_trans is co1a (opt_trans is co1b co2) + = opt_trans opts is co1a (opt_trans opts is co1b co2) -opt_trans2 is co1 co2 - | Just co <- opt_trans_rule is co1 co2 +opt_trans2 opts is co1 co2 + | Just co <- opt_trans_rule opts is co1 co2 = co -opt_trans2 is co1 (TransCo co2a co2b) - | Just co1_2a <- opt_trans_rule is co1 co2a +opt_trans2 opts is co1 (TransCo co2a co2b) + | Just co1_2a <- opt_trans_rule opts is co1 co2a = if isReflCo co1_2a then co2b - else opt_trans1 is co1_2a co2b + else opt_trans1 opts is co1_2a co2b -opt_trans2 _ co1 co2 +opt_trans2 _ _ co1 co2 = mkTransCo co1 co2 ------ + -- Optimize coercions with a top-level use of transitivity. -opt_trans_rule :: InScopeSet -> NormalNonIdCo -> NormalNonIdCo -> Maybe NormalCo +opt_trans_rule :: OptCoParams -> InScopeSet -> NormalNonIdCo -> NormalNonIdCo -> Maybe NormalCo + +-- Handle a composition of two directed coercions. +opt_trans_rule opts is (HydrateDCo r lty1 dco1 _) (HydrateDCo _ lty2 dco2 rhs2) + = ( \ dco -> mkHydrateDCo r lty1 dco rhs2 ) + <$> opt_trans_rule_dco opts is r lty1 dco1 lty2 dco2 -opt_trans_rule is in_co1@(GRefl r1 t1 (MCo co1)) in_co2@(GRefl r2 _ (MCo co2)) +opt_trans_rule opts is (SymCo (HydrateDCo r lty1 dco1 rhs1)) (SymCo (HydrateDCo _ lty2 dco2 _)) + = ( \ dco -> mkSymCo $ mkHydrateDCo r lty2 dco rhs1 ) + <$> opt_trans_rule_dco opts is r lty2 dco2 lty1 dco1 + +-- When composing a Coercion with a DCoercion, we could imagine hydrating the DCoercion +-- a single step (e.g. using 'hydrateOneLayerDCo') to expose cancellation opportunities. +-- We don't do that for now. + +opt_trans_rule opts is in_co1@(GRefl r1 t1 (MCo co1)) in_co2@(GRefl r2 _ (MCo co2)) = assert (r1 == r2) $ fireTransRule "GRefl" in_co1 in_co2 $ - mkGReflRightCo r1 t1 (opt_trans is co1 co2) + mkGReflRightCo r1 t1 (opt_trans opts is co1 co2) -- Push transitivity through matching destructors -opt_trans_rule is in_co1@(SelCo d1 co1) in_co2@(SelCo d2 co2) +opt_trans_rule opts is in_co1@(SelCo d1 co1) in_co2@(SelCo d2 co2) | d1 == d2 , coercionRole co1 == coercionRole co2 , co1 `compatible_co` co2 = fireTransRule "PushNth" in_co1 in_co2 $ - mkSelCo d1 (opt_trans is co1 co2) + mkSelCo d1 (opt_trans opts is co1 co2) -opt_trans_rule is in_co1@(LRCo d1 co1) in_co2@(LRCo d2 co2) +opt_trans_rule opts is in_co1@(LRCo d1 co1) in_co2@(LRCo d2 co2) | d1 == d2 , co1 `compatible_co` co2 = fireTransRule "PushLR" in_co1 in_co2 $ - mkLRCo d1 (opt_trans is co1 co2) + mkLRCo d1 (opt_trans opts is co1 co2) -- Push transitivity inside instantiation -opt_trans_rule is in_co1@(InstCo co1 ty1) in_co2@(InstCo co2 ty2) +opt_trans_rule opts is in_co1@(InstCo co1 ty1) in_co2@(InstCo co2 ty2) | ty1 `eqCoercion` ty2 , co1 `compatible_co` co2 = fireTransRule "TrPushInst" in_co1 in_co2 $ - mkInstCo (opt_trans is co1 co2) ty1 + mkInstCo (opt_trans opts is co1 co2) ty1 -opt_trans_rule is in_co1@(UnivCo p1 r1 tyl1 _tyr1) - in_co2@(UnivCo p2 r2 _tyl2 tyr2) +opt_trans_rule opts is in_co1@(UnivCo p1 r1 tyl1 _tyr1) + in_co2@(UnivCo p2 r2 _tyl2 tyr2) | Just prov' <- opt_trans_prov p1 p2 = assert (r1 == r2) $ fireTransRule "UnivCo" in_co1 in_co2 $ @@ -699,54 +826,56 @@ opt_trans_rule is in_co1@(UnivCo p1 r1 tyl1 _tyr1) where -- if the provenances are different, opt'ing will be very confusing opt_trans_prov (PhantomProv kco1) (PhantomProv kco2) - = Just $ PhantomProv $ opt_trans is kco1 kco2 + = Just $ PhantomProv $ opt_trans opts is kco1 kco2 opt_trans_prov (ProofIrrelProv kco1) (ProofIrrelProv kco2) - = Just $ ProofIrrelProv $ opt_trans is kco1 kco2 - opt_trans_prov (PluginProv str1) (PluginProv str2) | str1 == str2 = Just p1 + = Just $ ProofIrrelProv $ opt_trans opts is kco1 kco2 + opt_trans_prov (PluginProv str1) (PluginProv str2) + | str1 == str2 + = Just p1 opt_trans_prov _ _ = Nothing -- Push transitivity down through matching top-level constructors. -opt_trans_rule is in_co1@(TyConAppCo r1 tc1 cos1) in_co2@(TyConAppCo r2 tc2 cos2) +opt_trans_rule opts is in_co1@(TyConAppCo r1 tc1 cos1) in_co2@(TyConAppCo r2 tc2 cos2) | tc1 == tc2 = assert (r1 == r2) $ fireTransRule "PushTyConApp" in_co1 in_co2 $ - mkTyConAppCo r1 tc1 (opt_transList is cos1 cos2) + mkTyConAppCo r1 tc1 (opt_transList opts is cos1 cos2) -opt_trans_rule is in_co1@(FunCo r1 afl1 afr1 w1 co1a co1b) - in_co2@(FunCo r2 afl2 afr2 w2 co2a co2b) +opt_trans_rule opts is in_co1@(FunCo r1 afl1 afr1 w1 co1a co1b) + in_co2@(FunCo r2 afl2 afr2 w2 co2a co2b) = assert (r1 == r2) $ -- Just like the TyConAppCo/TyConAppCo case assert (afr1 == afl2) $ fireTransRule "PushFun" in_co1 in_co2 $ - mkFunCo2 r1 afl1 afr2 (opt_trans is w1 w2) - (opt_trans is co1a co2a) - (opt_trans is co1b co2b) + mkFunCo2 r1 afl1 afr2 (opt_trans opts is w1 w2) + (opt_trans opts is co1a co2a) + (opt_trans opts is co1b co2b) -opt_trans_rule is in_co1@(AppCo co1a co1b) in_co2@(AppCo co2a co2b) +opt_trans_rule opts is in_co1@(AppCo co1a co1b) in_co2@(AppCo co2a co2b) -- Must call opt_trans_rule_app; see Note [EtaAppCo] - = opt_trans_rule_app is in_co1 in_co2 co1a [co1b] co2a [co2b] + = opt_trans_rule_app opts is in_co1 in_co2 co1a [co1b] co2a [co2b] -- Eta rules -opt_trans_rule is co1@(TyConAppCo r tc cos1) co2 +opt_trans_rule opts is co1@(TyConAppCo r tc cos1) co2 | Just cos2 <- etaTyConAppCo_maybe tc co2 = fireTransRule "EtaCompL" co1 co2 $ - mkTyConAppCo r tc (opt_transList is cos1 cos2) + mkTyConAppCo r tc (opt_transList opts is cos1 cos2) -opt_trans_rule is co1 co2@(TyConAppCo r tc cos2) +opt_trans_rule opts is co1 co2@(TyConAppCo r tc cos2) | Just cos1 <- etaTyConAppCo_maybe tc co1 = fireTransRule "EtaCompR" co1 co2 $ - mkTyConAppCo r tc (opt_transList is cos1 cos2) + mkTyConAppCo r tc (opt_transList opts is cos1 cos2) -opt_trans_rule is co1@(AppCo co1a co1b) co2 +opt_trans_rule opts is co1@(AppCo co1a co1b) co2 | Just (co2a,co2b) <- etaAppCo_maybe co2 - = opt_trans_rule_app is co1 co2 co1a [co1b] co2a [co2b] + = opt_trans_rule_app opts is co1 co2 co1a [co1b] co2a [co2b] -opt_trans_rule is co1 co2@(AppCo co2a co2b) +opt_trans_rule opts is co1 co2@(AppCo co2a co2b) | Just (co1a,co1b) <- etaAppCo_maybe co1 - = opt_trans_rule_app is co1 co2 co1a [co1b] co2a [co2b] + = opt_trans_rule_app opts is co1 co2 co1a [co1b] co2a [co2b] -- Push transitivity inside forall -- forall over types. -opt_trans_rule is co1 co2 +opt_trans_rule opts is co1 co2 | Just (tv1, eta1, r1) <- splitForAllCo_ty_maybe co1 , Just (tv2, eta2, r2) <- etaForAllCo_ty_maybe co2 = push_trans tv1 eta1 r1 tv2 eta2 r2 @@ -763,14 +892,14 @@ opt_trans_rule is co1 co2 -- Wanted: -- /\tv1 : (eta1;eta2). (r1; r2[tv2 |-> tv1 |> eta1]) = fireTransRule "EtaAllTy_ty" co1 co2 $ - mkForAllCo tv1 (opt_trans is eta1 eta2) (opt_trans is' r1 r2') + mkForAllCo tv1 (opt_trans opts is eta1 eta2) (opt_trans opts is' r1 r2') where is' = is `extendInScopeSet` tv1 r2' = substCoWithUnchecked [tv2] [mkCastTy (TyVarTy tv1) eta1] r2 -- Push transitivity inside forall -- forall over coercions. -opt_trans_rule is co1 co2 +opt_trans_rule opts is co1 co2 | Just (cv1, eta1, r1) <- splitForAllCo_co_maybe co1 , Just (cv2, eta2, r2) <- etaForAllCo_co_maybe co2 = push_trans cv1 eta1 r1 cv2 eta2 r2 @@ -789,7 +918,7 @@ opt_trans_rule is co1 co2 -- n2 = nth 3 eta1 -- nco = /\ cv1 : (eta1;eta2). (r1; r2[cv2 |-> (sym n1);cv1;n2]) = fireTransRule "EtaAllTy_co" co1 co2 $ - mkForAllCo cv1 (opt_trans is eta1 eta2) (opt_trans is' r1 r2') + mkForAllCo cv1 (opt_trans opts is eta1 eta2) (opt_trans opts is' r1 r2') where is' = is `extendInScopeSet` cv1 role = coVarRole cv1 @@ -801,7 +930,7 @@ opt_trans_rule is co1 co2 r2 -- Push transitivity inside axioms -opt_trans_rule is co1 co2 +opt_trans_rule opts is co1 co2 -- See Note [Push transitivity inside axioms] and -- Note [Push transitivity inside newtype axioms only] @@ -810,34 +939,34 @@ opt_trans_rule is co1 co2 , isNewTyCon (coAxiomTyCon con) , True <- sym , Just cos2 <- matchAxiom sym con ind co2 - , let newAxInst = AxiomInstCo con ind (opt_transList is (map mkSymCo cos2) cos1) + , let newAxInst = AxiomInstCo con ind (opt_transList opts is (map mkSymCo cos2) cos1) = fireTransRule "TrPushSymAxR" co1 co2 $ SymCo newAxInst - -- TrPushAxR + -- TrPushAxR (AxSuckR) | Just (sym, con, ind, cos1) <- co1_is_axiom_maybe , isNewTyCon (coAxiomTyCon con) , False <- sym , Just cos2 <- matchAxiom sym con ind co2 - , let newAxInst = AxiomInstCo con ind (opt_transList is cos1 cos2) + , let newAxInst = AxiomInstCo con ind (opt_transList opts is cos1 cos2) = fireTransRule "TrPushAxR" co1 co2 newAxInst - -- TrPushSymAxL + -- TrPushSymAxL (SymAxSuckL) | Just (sym, con, ind, cos2) <- co2_is_axiom_maybe , isNewTyCon (coAxiomTyCon con) , True <- sym , Just cos1 <- matchAxiom (not sym) con ind co1 - , let newAxInst = AxiomInstCo con ind (opt_transList is cos2 (map mkSymCo cos1)) + , let newAxInst = AxiomInstCo con ind (opt_transList opts is cos2 (map mkSymCo cos1)) = fireTransRule "TrPushSymAxL" co1 co2 $ SymCo newAxInst - -- TrPushAxL + -- TrPushAxL (AxSuckL) | Just (sym, con, ind, cos2) <- co2_is_axiom_maybe , isNewTyCon (coAxiomTyCon con) , False <- sym , Just cos1 <- matchAxiom (not sym) con ind co1 - , let newAxInst = AxiomInstCo con ind (opt_transList is cos1 cos2) + , let newAxInst = AxiomInstCo con ind (opt_transList opts is cos1 cos2) = fireTransRule "TrPushAxL" co1 co2 newAxInst - -- TrPushAxSym/TrPushSymAx + -- TrPushAxSym/TrPushSymAx (AxSym/SymAx) | Just (sym1, con1, ind1, cos1) <- co1_is_axiom_maybe , Just (sym2, con2, ind2, cos2) <- co2_is_axiom_maybe , con1 == con2 @@ -851,16 +980,16 @@ opt_trans_rule is co1 co2 , all (`elemVarSet` pivot_tvs) qtvs = fireTransRule "TrPushAxSym" co1 co2 $ if sym2 - -- TrPushAxSym - then liftCoSubstWith role qtvs (opt_transList is cos1 (map mkSymCo cos2)) lhs - -- TrPushSymAx - else liftCoSubstWith role qtvs (opt_transList is (map mkSymCo cos1) cos2) rhs + -- TrPushAxSym (AxSym) + then liftCoSubstWith role qtvs (opt_transList opts is cos1 (map mkSymCo cos2)) lhs + -- TrPushSymAx (SymAx) + else liftCoSubstWith role qtvs (opt_transList opts is (map mkSymCo cos1) cos2) rhs where co1_is_axiom_maybe = isAxiom_maybe co1 co2_is_axiom_maybe = isAxiom_maybe co2 role = coercionRole co1 -- should be the same as coercionRole co2! -opt_trans_rule _ co1 co2 -- Identity rule +opt_trans_rule _ _ co1 co2 -- Identity rule | let ty1 = coercionLKind co1 r = coercionRole co1 ty2 = coercionRKind co2 @@ -868,10 +997,11 @@ opt_trans_rule _ co1 co2 -- Identity rule = fireTransRule "RedTypeDirRefl" co1 co2 $ mkReflCo r ty2 -opt_trans_rule _ _ _ = Nothing +opt_trans_rule _ _ _ _ = Nothing -- See Note [EtaAppCo] -opt_trans_rule_app :: InScopeSet +opt_trans_rule_app :: OptCoParams + -> InScopeSet -> Coercion -- original left-hand coercion (printing only) -> Coercion -- original right-hand coercion (printing only) -> Coercion -- left-hand coercion "function" @@ -879,14 +1009,14 @@ opt_trans_rule_app :: InScopeSet -> Coercion -- right-hand coercion "function" -> [Coercion] -- right-hand coercion "args" -> Maybe Coercion -opt_trans_rule_app is orig_co1 orig_co2 co1a co1bs co2a co2bs +opt_trans_rule_app opts is orig_co1 orig_co2 co1a co1bs co2a co2bs | AppCo co1aa co1ab <- co1a , Just (co2aa, co2ab) <- etaAppCo_maybe co2a - = opt_trans_rule_app is orig_co1 orig_co2 co1aa (co1ab:co1bs) co2aa (co2ab:co2bs) + = opt_trans_rule_app opts is orig_co1 orig_co2 co1aa (co1ab:co1bs) co2aa (co2ab:co2bs) | AppCo co2aa co2ab <- co2a , Just (co1aa, co1ab) <- etaAppCo_maybe co1a - = opt_trans_rule_app is orig_co1 orig_co2 co1aa (co1ab:co1bs) co2aa (co2ab:co2bs) + = opt_trans_rule_app opts is orig_co1 orig_co2 co1aa (co1ab:co1bs) co2aa (co2ab:co2bs) | otherwise = assert (co1bs `equalLength` co2bs) $ @@ -907,12 +1037,224 @@ opt_trans_rule_app is orig_co1 orig_co2 co1a co1bs co2a co2bs co2bs' = zipWith3 mkGReflLeftCo rt2bs lt2bs kcobs co2bs'' = zipWith mkTransCo co2bs' co2bs in - mkAppCos (opt_trans is co1a co2a') - (zipWith (opt_trans is) co1bs co2bs'') + mkAppCos (opt_trans opts is co1a co2a') + (zipWith (opt_trans opts is) co1bs co2bs'') fireTransRule :: String -> Coercion -> Coercion -> Coercion -> Maybe Coercion fireTransRule _rule _co1 _co2 res - = Just res + = -- pprTrace _rule + -- (vcat [ text "co1:" <+> ppr _co1 + -- , text "co2:" <+> ppr _co2 + -- , text "res:" <+> ppr res ]) $ + Just res + +------ +-- Optimize directed coercions + +-- N.B.: The reason we return (Type, DCoercion) and not just DCoercion is that we +-- sometimes need the substituted LHS type (see opt_trans_dco). + +opt_phantom_dco :: OptCoParams -> LiftingContext -> Role -> Type -> DCoercion -> (Type, NormalDCo) +opt_phantom_dco opts env r l_ty dco = opt_univ DCo opts env False (PhantomProv kco) Phantom l_ty r_ty + where + kco = DehydrateCo (mkKindCo $ mkHydrateDCo r l_ty dco r_ty) + r_ty = followDCo r l_ty dco + -- A naive attempt at removing this entirely causes issues in test "type_in_type_hole_fits". + +opt_dco4_wrap :: String -> OptCoParams -> LiftingContext -> ReprFlag -> Role -> Type -> DCoercion -> (Type, NormalDCo) +opt_dco4_wrap str opts lc rep r l_ty dco = wrap ("opt_dco4 " ++ str) go opts lc False rep r dco + where + go opts lc _sym repr r dco = opt_dco4 opts lc repr r l_ty dco + +opt_dco2 :: OptCoParams + -> LiftingContext + -> Role -- ^ The role of the input coercion + -> Type + -> DCoercion -> (Type, NormalDCo) +opt_dco2 opts env Phantom ty dco = opt_phantom_dco opts env Phantom ty dco +opt_dco2 opts env r ty dco = opt_dco3 opts env Nothing r ty dco + +opt_dco3 :: OptCoParams -> LiftingContext -> Maybe Role -> Role -> Type -> DCoercion -> (Type, NormalDCo) +opt_dco3 opts env (Just Phantom) r ty dco = opt_phantom_dco opts env r ty dco +opt_dco3 opts env (Just Representational) r ty dco = opt_dco4_wrap "opt_dco3 R" opts env True r ty dco +opt_dco3 opts env _ r ty dco = opt_dco4_wrap "opt_dco3 _" opts env False r ty dco + +opt_dco4 :: OptCoParams -> LiftingContext -> ReprFlag -> Role -> Type -> DCoercion -> (Type, NormalDCo) +opt_dco4 opts env rep r l_ty dco = case dco of + + ReflDCo + -> lifted_dco + GReflRightDCo kco + | isGReflCo kco || isGReflCo kco' + -> lifted_dco + | otherwise + -> (l_ty', mkGReflRightDCo kco') + where + kco' = opt_co4 opts env False False Nominal kco + GReflLeftDCo kco + | isGReflCo kco || isGReflCo kco' + -> lifted_dco + | otherwise + -> (l_ty', mkGReflLeftDCo kco') + where + kco' = opt_co4 opts env False False Nominal kco + + TyConAppDCo dcos + | Just (tc, l_tys) <- splitTyConApp_maybe l_ty + -> let + (arg_ltys, arg_dcos) = + case (rep, r) of + (True, Nominal) -> + unzip $ + zipWith3 + (\ mb_r' -> opt_dco3 opts env mb_r' Nominal) + (map Just (tyConRoleListRepresentational tc)) + l_tys + dcos + (False, Nominal) -> + unzip $ + zipWith (opt_dco4 opts env False Nominal) l_tys dcos + (_, Representational) -> + unzip $ + zipWith3 + (opt_dco2 opts env) + (tyConRoleListRepresentational tc) + l_tys + dcos + (_, Phantom) -> pprPanic "opt_dco4 sees a phantom!" (ppr dco) + in (mkTyConApp tc arg_ltys, mkTyConAppDCo arg_dcos) + + | otherwise + -> pprPanic "opt_dco4: TyConAppDCo where ty is not a TyConApp" $ + vcat [ text "dco =" <+> ppr dco + , text "l_ty =" <+> ppr l_ty ] + + AppDCo dco1 dco2 + | Just (l_ty1, l_ty2) <- splitAppTy_maybe l_ty + , let + (l_ty1', l_dco1) = opt_dco4 opts env rep r l_ty1 dco1 + (l_ty2', l_dco2) = opt_dco4 opts env False Nominal l_ty2 dco2 + -> (mkAppTy l_ty1' l_ty2', mkAppDCo l_dco1 l_dco2) + | otherwise + -> pprPanic "opt_dco4: AppDCo where ty is not an AppTy" $ + vcat [ text "dco =" <+> ppr dco + , text "l_ty =" <+> ppr l_ty ] + + ForAllDCo dco_tcv k_dco body_dco + | ForAllTy (Bndr ty_tv af) body_ty <- coreFullView l_ty + -> case optForAllDCoBndr opts env False dco_tcv k_dco of + (env', dco_tcv', k_dco') -> + -- SLD TODO: can this be simplified? I made too many mistakes writing this... + let body_ty' = substTyWithInScope (lcInScopeSet env') [ty_tv] [mkTyVarTy dco_tcv'] body_ty + (body_ty'', body_dco') = opt_dco4_wrap "ForAllDCo" opts env' rep r body_ty' body_dco + forall_ty = mkForAllTy (Bndr dco_tcv' af) body_ty'' + forall_dco = mkForAllDCo dco_tcv' k_dco' body_dco' + forall_ty' = followDCo r forall_ty forall_dco + in (forall_ty, wrapRole_dco rep r forall_ty forall_dco forall_ty') + | otherwise + -> pprPanic "opt_dco4: ForAllDCo where ty is not a ForAllTy" $ + vcat [ text "dco =" <+> ppr dco + , text "l_ty =" <+> ppr l_ty ] + + CoVarDCo cv + -> let co' = opt_co4 opts env False rep r (CoVarCo cv) + in (coercionLKind co', mkDehydrateCo co') + + AxiomInstDCo {} + -> (l_ty', rep_dco) + StepsDCo {} + -> (l_ty', rep_dco) + + UnivDCo prov rhs_ty + -> opt_univ DCo opts env False prov r' l_ty rhs_ty + + TransDCo dco1 dco2 -> + let + (l_ty', dco1') = opt_dco4 opts env rep r l_ty dco1 + + -- Follow the original directed coercion, + -- to avoid applying the substitution twice. + mid_ty = followDCo r l_ty dco1 + (mid_ty', dco2') = opt_dco4 opts env rep r mid_ty dco2 + in + (l_ty', opt_trans_dco opts (lcInScopeSet env) r' l_ty' dco1' mid_ty' dco2') + + SubDCo dco -> + assert (r == Representational) $ + opt_dco4_wrap "SubDCo" opts env True Nominal l_ty dco + + DehydrateCo co -> + let co' = opt_co4_wrap "DehydrateCo" opts env False rep r co + in (coercionLKind co', mkDehydrateCo co') + + where + lifted_dco = let lifted_co = liftCoSubst r' env l_ty + in ( coercionLKind lifted_co, mkDehydrateCo lifted_co ) + l_ty' = substTyUnchecked (lcSubstLeft env) l_ty + r' = chooseRole rep r + rep_dco = wrapRole_dco rep r l_ty' dco (followDCo r l_ty' dco) + +--------------------------------------------------------- +-- Transitivity for directed coercions. + +opt_trans_dco :: OptCoParams -> InScopeSet -> Role -> Type -> NormalDCo -> Type -> NormalDCo -> NormalDCo +opt_trans_dco opts is r l_ty dco1 mid_ty dco2 + | isReflDCo dco1 = dco2 + -- optimize when dco1 is a Refl DCo + | otherwise = opt_trans1_dco opts is r l_ty dco1 mid_ty dco2 + +opt_trans1_dco :: OptCoParams -> InScopeSet -> Role -> Type -> NormalNonIdDCo -> Type -> NormalDCo -> NormalDCo +-- First arg is not the identity +opt_trans1_dco opts is r l_ty dco1 mid_ty dco2 + | isReflDCo dco2 = dco1 + -- optimize when co2 is a Refl Co + | otherwise = opt_trans2_dco opts is r l_ty dco1 mid_ty dco2 + +opt_trans2_dco :: OptCoParams -> InScopeSet -> Role -> Type -> NormalNonIdDCo -> Type -> NormalNonIdDCo -> NormalDCo +-- Neither arg is the identity +opt_trans2_dco opts is r l_ty (TransDCo dco1a dco1b) mid_ty dco2 + -- Don't know whether the sub-coercions are the identity + = let inner_ty = followDCo r l_ty dco1a + in opt_trans_dco opts is r l_ty dco1a inner_ty + (opt_trans_dco opts is r inner_ty dco1b mid_ty dco2) + + +opt_trans2_dco opts is r l_ty dco1 mid_ty dco2 + | Just co <- opt_trans_rule_dco opts is r l_ty dco1 mid_ty dco2 + = co + +opt_trans2_dco opts is r l_ty dco1 mid_ty (TransDCo dco2a dco2b) + | Just dco1_2a <- opt_trans_rule_dco opts is r l_ty dco1 mid_ty dco2a + = if isReflDCo dco1_2a + then dco2b + else + let inner_ty = followDCo r mid_ty dco1_2a + in opt_trans1_dco opts is r mid_ty dco1_2a inner_ty dco2b + +opt_trans2_dco _ _ _ _ dco1 _ dco2 + = mkTransDCo dco1 dco2 + +opt_trans_rule_dco :: OptCoParams -> InScopeSet -> Role -> Type -> NormalNonIdDCo -> Type -> NormalNonIdDCo -> Maybe NormalDCo + +-- Handle undirected coercions. +opt_trans_rule_dco opts is _ _ (DehydrateCo co1) _ (DehydrateCo co2) + = DehydrateCo <$> opt_trans_rule opts is co1 co2 + +opt_trans_rule_dco _ _ r l_ty dco1 mid_ty dco2 + | let r_ty = followDCo r mid_ty dco2 + , l_ty `eqType` r_ty + = fireTransRule_dco "RedTypeDirRefl" dco1 dco2 $ + mkReflDCo + +opt_trans_rule_dco _ _ _ _ _ _ _ = Nothing + +fireTransRule_dco :: String -> DCoercion -> DCoercion -> DCoercion -> Maybe DCoercion +fireTransRule_dco _rule _dco1 _dco2 res + = --pprTrace _rule + -- (vcat [ text "dco1:" <+> ppr _dco1 + -- , text "dco2:" <+> ppr _dco2 + -- , text "res:" <+> ppr res ]) $ + Just res {- Note [Push transitivity inside axioms] @@ -1092,12 +1434,21 @@ wrapSym sym co | sym = mkSymCo co | otherwise = co -- | Conditionally set a role to be representational -wrapRole :: ReprFlag +wrapRole :: HasDebugCallStack + => ReprFlag -> Role -- ^ current role -> Coercion -> Coercion wrapRole False _ = id wrapRole True current = downgradeRole Representational current +wrapRole_dco :: HasDebugCallStack + => ReprFlag + -> Role -- ^ current role + -> Type -> DCoercion -> Type + -> DCoercion +wrapRole_dco False _ _ dco _ = dco +wrapRole_dco True current l_ty dco r_ty = downgradeDCoToRepresentational current l_ty dco r_ty + -- | If we require a representational role, return that. Otherwise, -- return the "default" role provided. chooseRole :: ReprFlag @@ -1112,6 +1463,7 @@ isAxiom_maybe (SymCo co) | Just (sym, con, ind, cos) <- isAxiom_maybe co = Just (not sym, con, ind, cos) isAxiom_maybe (AxiomInstCo con ind cos) + | isNewTyCon (coAxiomTyCon con) -- Adam Gundry's special sauce = Just (False, con, ind, cos) isAxiom_maybe _ = Nothing @@ -1294,7 +1646,19 @@ and these two imply -} -optForAllCoBndr :: LiftingContext -> Bool +optForAllCoBndr :: OptCoParams + -> LiftingContext -> Bool -> TyCoVar -> Coercion -> (LiftingContext, TyCoVar, Coercion) -optForAllCoBndr env sym - = substForAllCoBndrUsingLC sym (opt_co4_wrap env sym False Nominal) env +optForAllCoBndr opts env sym + = substForAllCoBndrUsingLC sym + (substTyUnchecked (lcSubstLeft env)) + (opt_co4_wrap "optForAllCoBndr" opts env sym False Nominal) env + +optForAllDCoBndr :: OptCoParams + -> LiftingContext -> Bool + -> TyCoVar -> DCoercion -> (LiftingContext, TyCoVar, DCoercion) +optForAllDCoBndr opts env sym tv + = substForAllDCoBndrUsingLC sym + (substTyUnchecked (lcSubstLeft env)) + (snd . opt_dco4_wrap "optForAllDCoBndr" opts env False Nominal (tyVarKind tv)) env + tv diff --git a/compiler/GHC/Core/FVs.hs b/compiler/GHC/Core/FVs.hs index bddd6d89de..3219ef887c 100644 --- a/compiler/GHC/Core/FVs.hs +++ b/compiler/GHC/Core/FVs.hs @@ -394,7 +394,8 @@ orphNamesOfCo (FunCo { fco_mult = co_mult, fco_arg = co1, fco_res = co2 }) `unionNameSet` orphNamesOfCo co2 orphNamesOfCo (CoVarCo _) = emptyNameSet orphNamesOfCo (AxiomInstCo con _ cos) = orphNamesOfCoCon con `unionNameSet` orphNamesOfCos cos -orphNamesOfCo (UnivCo p _ t1 t2) = orphNamesOfProv p `unionNameSet` orphNamesOfType t1 +orphNamesOfCo (HydrateDCo _ t1 dco _) = orphNamesOfType t1 `unionNameSet` orphNamesOfDCo dco +orphNamesOfCo (UnivCo p _ t1 t2) = orphNamesOfProv orphNamesOfCo p `unionNameSet` orphNamesOfType t1 `unionNameSet` orphNamesOfType t2 orphNamesOfCo (SymCo co) = orphNamesOfCo co orphNamesOfCo (TransCo co1 co2) = orphNamesOfCo co1 `unionNameSet` orphNamesOfCo co2 @@ -406,15 +407,33 @@ orphNamesOfCo (SubCo co) = orphNamesOfCo co orphNamesOfCo (AxiomRuleCo _ cs) = orphNamesOfCos cs orphNamesOfCo (HoleCo _) = emptyNameSet -orphNamesOfProv :: UnivCoProvenance -> NameSet -orphNamesOfProv (PhantomProv co) = orphNamesOfCo co -orphNamesOfProv (ProofIrrelProv co) = orphNamesOfCo co -orphNamesOfProv (PluginProv _) = emptyNameSet -orphNamesOfProv (CorePrepProv _) = emptyNameSet +orphNamesOfDCo :: DCoercion -> NameSet +orphNamesOfDCo ReflDCo = emptyNameSet +orphNamesOfDCo (GReflRightDCo co) = orphNamesOfCo co +orphNamesOfDCo (GReflLeftDCo co) = orphNamesOfCo co +orphNamesOfDCo (TyConAppDCo cos) = orphNamesOfDCos cos +orphNamesOfDCo (AppDCo co1 co2) = orphNamesOfDCo co1 `unionNameSet` orphNamesOfDCo co2 +orphNamesOfDCo (ForAllDCo _ kind_dco co) = orphNamesOfDCo kind_dco `unionNameSet` orphNamesOfDCo co +orphNamesOfDCo (CoVarDCo _) = emptyNameSet +orphNamesOfDCo (AxiomInstDCo con) = orphNamesOfCoCon con +orphNamesOfDCo StepsDCo{} = emptyNameSet +orphNamesOfDCo (TransDCo co1 co2) = orphNamesOfDCo co1 `unionNameSet` orphNamesOfDCo co2 +orphNamesOfDCo (DehydrateCo co) = orphNamesOfCo co +orphNamesOfDCo (UnivDCo p rhs) = orphNamesOfProv orphNamesOfDCo p `unionNameSet` orphNamesOfType rhs +orphNamesOfDCo (SubDCo dco) = orphNamesOfDCo dco + +orphNamesOfProv :: (co -> NameSet) -> UnivCoProvenance co -> NameSet +orphNamesOfProv orph_names (PhantomProv co) = orph_names co +orphNamesOfProv orph_names (ProofIrrelProv co) = orph_names co +orphNamesOfProv _ (PluginProv _) = emptyNameSet +orphNamesOfProv _ (CorePrepProv _) = emptyNameSet orphNamesOfCos :: [Coercion] -> NameSet orphNamesOfCos = orphNamesOfThings orphNamesOfCo +orphNamesOfDCos :: [DCoercion] -> NameSet +orphNamesOfDCos = orphNamesOfThings orphNamesOfDCo + orphNamesOfCoCon :: CoAxiom br -> NameSet orphNamesOfCoCon (CoAxiom { co_ax_tc = tc, co_ax_branches = branches }) = orphNamesOfTyCon tc `unionNameSet` orphNamesOfCoAxBranches branches diff --git a/compiler/GHC/Core/FamInstEnv.hs b/compiler/GHC/Core/FamInstEnv.hs index 0a0389d71b..1d8b05c99d 100644 --- a/compiler/GHC/Core/FamInstEnv.hs +++ b/compiler/GHC/Core/FamInstEnv.hs @@ -1,7 +1,6 @@ {-# LANGUAGE DeriveFunctor #-} {-# LANGUAGE GADTs #-} {-# LANGUAGE ScopedTypeVariables #-} -{-# LANGUAGE TupleSections #-} -- (c) The University of Glasgow 2006 -- @@ -24,7 +23,7 @@ module GHC.Core.FamInstEnv ( FamInstMatch(..), lookupFamInstEnv, lookupFamInstEnvConflicts, lookupFamInstEnvByTyCon, - isDominatedBy, apartnessCheck, compatibleBranches, + isDominatedBy, apartnessCheck, compatibleBranches, chooseBranch, -- Injectivity InjectivityCheckResult(..), @@ -33,7 +32,7 @@ module GHC.Core.FamInstEnv ( -- Normalisation topNormaliseType, topNormaliseType_maybe, normaliseType, normaliseTcApp, - topReduceTyFamApp_maybe, reduceTyFamApp_maybe + topReduceTyFamApp_maybe, reduceTyFamApp_maybe, ) where import GHC.Prelude @@ -1152,18 +1151,17 @@ The lookupFamInstEnv function does a nice job for *open* type families, but we also need to handle closed ones when normalising a type: -} -reduceTyFamApp_maybe :: FamInstEnvs - -> Role -- Desired role of result coercion - -> TyCon -> [Type] - -> Maybe Reduction --- Attempt to do a *one-step* reduction of a type-family application +-- | Attempt to do a *one-step* reduction of a type-family application -- but *not* newtypes -- Works on type-synonym families always; data-families only if -- the role we seek is representational -- It does *not* normalise the type arguments first, so this may not -- go as far as you want. If you want normalised type arguments, -- use topReduceTyFamApp_maybe --- +reduceTyFamApp_maybe :: FamInstEnvs + -> Role -- Desired role of result coercion + -> TyCon -> [Type] + -> Maybe Reduction -- The TyCon can be oversaturated. -- Works on both open and closed families -- @@ -1186,18 +1184,18 @@ reduceTyFamApp_maybe envs role tc tys -- NB: Allow multiple matches because of compatible overlap = let co = mkUnbranchedAxInstCo role ax inst_tys inst_cos - in Just $ coercionRedn co + in Just $ mkDehydrateCoercionRedn co | Just ax <- isClosedSynFamilyTyConWithAxiom_maybe tc , Just (ind, inst_tys, inst_cos) <- chooseBranch ax tys = let co = mkAxInstCo role ax ind inst_tys inst_cos - in Just $ coercionRedn co + in Just $ mkDehydrateCoercionRedn co - | Just ax <- isBuiltInSynFamTyCon_maybe tc - , Just (coax,ts,ty) <- sfMatchFam ax tys + | Just ax <- isBuiltInSynFamTyCon_maybe tc + , Just (coax,ts,_) <- sfMatchFam ax tys , role == coaxrRole coax = let co = mkAxiomRuleCo coax (zipWith mkReflCo (coaxrAsmpRoles coax) ts) - in Just $ mkReduction co ty + in Just $ mkDehydrateCoercionRedn co | otherwise = Nothing @@ -1351,21 +1349,20 @@ topNormaliseType_maybe :: FamInstEnvs -> Type -> Maybe Reduction -- Always operates homogeneously: the returned type has the same kind as the -- original type, and the returned coercion is always homogeneous. topNormaliseType_maybe env ty - = do { ((co, mkind_co), nty) <- topNormaliseTypeX stepper combine ty - ; let hredn = mkHetReduction (mkReduction co nty) mkind_co - ; return $ homogeniseHetRedn Representational hredn } + = do { ((dco, mkind_co), nty) <- topNormaliseTypeX stepper combine ty + ; return $ homogeniseRedn (mkReduction dco nty) mkind_co } where stepper = unwrapNewTypeStepper' `composeSteppers` tyFamStepper - combine (c1, mc1) (c2, mc2) = (c1 `mkTransCo` c2, mc1 `mkTransMCo` mc2) + combine (c1, mdc1) (c2, mdc2) = (c1 `mkTransDCo` c2, mdc1 `mkTransMCo` mdc2) - unwrapNewTypeStepper' :: NormaliseStepper (Coercion, MCoercionN) + unwrapNewTypeStepper' :: NormaliseStepper (DCoercion, MCoercionN) unwrapNewTypeStepper' rec_nts tc tys - = (, MRefl) <$> unwrapNewTypeStepper rec_nts tc tys + = (\ co -> (mkDehydrateCo co, MRefl)) <$> unwrapNewTypeStepper rec_nts tc tys -- second coercion below is the kind coercion relating the original type's kind -- to the normalised type's kind - tyFamStepper :: NormaliseStepper (Coercion, MCoercionN) + tyFamStepper :: NormaliseStepper (DCoercion, MCoercionN) tyFamStepper rec_nts tc tys -- Try to step a type/data family = case topReduceTyFamApp_maybe env tc tys of Just (HetReduction (Reduction co rhs) res_co) @@ -1385,13 +1382,13 @@ topReduceTyFamApp_maybe envs fam_tc arg_tys , Just redn <- reduceTyFamApp_maybe envs role fam_tc ntys = Just $ mkHetReduction - (mkTyConAppCo role fam_tc args_cos `mkTransRedn` redn) + (mkTyConAppRedn fam_tc args_redns `mkTransRedn` redn) res_co | otherwise = Nothing where role = Representational - ArgsReductions (Reductions args_cos ntys) res_co + ArgsReductions args_redns@(Reductions _ ntys) res_co = initNormM envs role (tyCoVarsOfTypes arg_tys) $ normalise_tc_args fam_tc arg_tys @@ -1427,16 +1424,16 @@ normalise_tc_app tc tys = -- A type-family application do { env <- getEnv ; role <- getRole - ; ArgsReductions redns@(Reductions args_cos ntys) res_co <- normalise_tc_args tc tys + ; ArgsReductions redns@(Reductions _ ntys) res_co <- normalise_tc_args tc tys ; case reduceTyFamApp_maybe env role tc ntys of Just redn1 -> do { redn2 <- normalise_reduction redn1 - ; let redn3 = mkTyConAppCo role tc args_cos `mkTransRedn` redn2 - ; return $ assemble_result role redn3 res_co } + ; let redn3 = mkTyConAppRedn tc redns `mkTransRedn` redn2 + ; return $ homogeniseRedn redn3 res_co } _ -> -- No unique matching family instance exists; -- we do not do anything return $ - assemble_result role (mkTyConAppRedn role tc redns) res_co } + homogeniseRedn (mkTyConAppRedn tc redns) res_co } | otherwise = -- A synonym with no type families in the RHS; or data type etc @@ -1444,16 +1441,10 @@ normalise_tc_app tc tys do { ArgsReductions redns res_co <- normalise_tc_args tc tys ; role <- getRole ; return $ - assemble_result role (mkTyConAppRedn role tc redns) res_co } - - where - assemble_result :: Role -- r, ambient role in NormM monad - -> Reduction -- orig_ty ~r nty, possibly heterogeneous (nty possibly of changed kind) - -> MCoercionN -- typeKind(orig_ty) ~N typeKind(nty) - -> Reduction -- orig_ty ~r nty_casted - -- where nty_casted has same kind as orig_ty - assemble_result r redn kind_co - = mkCoherenceRightMRedn r redn (mkSymMCo kind_co) + homogeniseRedn (mkTyConAppRedn_MightBeSynonym role tc tys redns) res_co } + -- NB: we assume "tys" satisfy the hydration invariant from + -- Note [Following a directed coercion] in GHC.Core.Coercion, + -- because the "normalise" functions all only deal with fully zonked types. normalise_tc_args :: TyCon -> [Type] -> NormM ArgsReductions normalise_tc_args tc tys @@ -1475,16 +1466,17 @@ normalise_type ty go :: Type -> NormM Reduction go (TyConApp tc tys) = normalise_tc_app tc tys go ty@(LitTy {}) - = do { r <- getRole - ; return $ mkReflRedn r ty } + = return $ mkReflRedn ty go (AppTy ty1 ty2) = go_app_tys ty1 [ty2] go (FunTy { ft_af = vis, ft_mult = w, ft_arg = ty1, ft_res = ty2 }) = do { arg_redn <- go ty1 ; res_redn <- go ty2 ; w_redn <- withRole Nominal $ go w - ; r <- getRole - ; return $ mkFunRedn r vis w_redn arg_redn res_redn } + ; return $ mkFunRedn vis w_redn mkReflDCo mkReflDCo arg_redn res_redn + -- NB: normalise_type is homogeneous, so we can use ReflDCo + -- for the kind coercions. + } go (ForAllTy (Bndr tcvar vis) ty) = do { (lc', tv', k_redn) <- normalise_var_bndr tcvar ; redn <- withLC lc' $ normalise_type ty @@ -1494,15 +1486,14 @@ normalise_type ty = do { redn <- go ty ; lc <- getLC ; let co' = substRightCo lc co - ; return $ mkCastRedn2 Nominal ty co redn co' + ; return $ mkCastRedn2 co redn co' -- ^^^^^^^^^^^ uses castCoercionKind2 } go (CoercionTy co) = do { lc <- getLC - ; r <- getRole ; let kco = liftCoSubst Nominal lc (coercionType co) co' = substRightCo lc co - ; return $ mkProofIrrelRedn r kco co co' } + ; return $ mkProofIrrelRedn co (mkDehydrateCo kco) co' } go_app_tys :: Type -- function -> [Type] -- args @@ -1510,7 +1501,7 @@ normalise_type ty -- cf. GHC.Tc.Solver.Rewrite.rewrite_app_ty_args go_app_tys (AppTy ty1 ty2) tys = go_app_tys ty1 (ty2 : tys) go_app_tys fun_ty arg_tys - = do { fun_redn@(Reduction fun_co nfun) <- go fun_ty + = do { fun_redn@(Reduction _ nfun) <- go fun_ty ; case tcSplitTyConApp_maybe nfun of Just (tc, xis) -> do { redn <- go (mkTyConApp tc (xis ++ arg_tys)) @@ -1518,15 +1509,14 @@ normalise_type ty -- but that's a much more performance-sensitive function. -- This type normalisation is not called in a loop. ; return $ - mkAppCos fun_co (map mkNomReflCo arg_tys) `mkTransRedn` redn } + mkAppRedns fun_redn (mkReflRedns arg_tys) `mkTransRedn` redn } Nothing -> do { ArgsReductions redns res_co <- normalise_args (typeKind nfun) (Inf.repeat Nominal) arg_tys - ; role <- getRole ; return $ - mkCoherenceRightMRedn role + mkCoherenceRightMRedn (mkAppRedns fun_redn redns) (mkSymMCo res_co) } } @@ -1542,7 +1532,7 @@ normalise_args :: Kind -- of the function -- cf. GHC.Tc.Solver.Rewrite.rewrite_args_slow normalise_args fun_ki roles args = do { normed_args <- zipWithM normalise1 (Inf.toList roles) args - ; return $ simplifyArgsWorker ki_binders inner_ki fvs roles normed_args } + ; return $ simplifyArgsWorker ki_binders inner_ki fvs roles args normed_args } where (ki_binders, inner_ki) = splitPiTys fun_ki fvs = tyCoVarsOfTypes args @@ -1556,21 +1546,25 @@ normalise_tyvar tv do { lc <- getLC ; r <- getRole ; return $ case liftCoSubstTyVar lc r tv of - Just co -> coercionRedn co - Nothing -> mkReflRedn r (mkTyVarTy tv) } + Just co -> mkDehydrateCoercionRedn co + Nothing -> mkReflRedn (mkTyVarTy tv) } normalise_reduction :: Reduction -> NormM Reduction -normalise_reduction (Reduction co ty) +normalise_reduction redn@(Reduction _ ty) = do { redn' <- normalise_type ty - ; return $ co `mkTransRedn` redn' } + ; return $ redn `mkTransRedn` redn' } normalise_var_bndr :: TyCoVar -> NormM (LiftingContext, TyCoVar, Reduction) normalise_var_bndr tcvar -- works for both tvar and covar = do { lc1 <- getLC ; env <- getEnv - ; let callback lc ki = runNormM (normalise_type ki) env lc Nominal - ; return $ liftCoSubstVarBndrUsing reductionCoercion callback lc1 tcvar } + ; let + mk_co (lhs, redn) = mkHydrateReductionDCoercion Nominal lhs redn + do_normalise ki = do { redn <- normalise_type ki; return (ki, redn) } + callback lc ki = runNormM (do_normalise ki) env lc Nominal + (lc, tcv, (_, redn)) = liftCoSubstVarBndrUsing mk_co callback lc1 tcvar + ; return (lc, tcv, redn) } -- | a monad for the normalisation functions, reading 'FamInstEnvs', -- a 'LiftingContext', and a 'Role'. diff --git a/compiler/GHC/Core/FamInstEnv.hs-boot b/compiler/GHC/Core/FamInstEnv.hs-boot new file mode 100644 index 0000000000..6679d4bae7 --- /dev/null +++ b/compiler/GHC/Core/FamInstEnv.hs-boot @@ -0,0 +1,9 @@ +module GHC.Core.FamInstEnv where + +import GHC.Core.Coercion.Axiom (CoAxiom, BranchIndex, Branched) +import GHC.Core.TyCo.Rep (Coercion) +import GHC.Core.Type (Type) +import Data.Maybe (Maybe) + +chooseBranch :: CoAxiom Branched -> [Type] + -> Maybe (BranchIndex, [Type], [Coercion]) diff --git a/compiler/GHC/Core/Lint.hs b/compiler/GHC/Core/Lint.hs index 7bb1eb43aa..449774299b 100644 --- a/compiler/GHC/Core/Lint.hs +++ b/compiler/GHC/Core/Lint.hs @@ -1,3 +1,5 @@ +{-# LANGUAGE DeriveFunctor #-} +{-# LANGUAGE GADTs #-} {-# LANGUAGE MultiWayIf #-} {-# LANGUAGE ScopedTypeVariables #-} {-# LANGUAGE PatternSynonyms #-} @@ -1751,11 +1753,20 @@ lintValueType ty 2 (text "has kind:" <+> ppr sk) ; return ty' } + +------------------- checkTyCon :: TyCon -> LintM () checkTyCon tc = checkL (not (isTcTyCon tc)) (text "Found TcTyCon:" <+> ppr tc) ------------------- +checkTyCoVarInScope :: String -> Subst -> TyCoVar -> LintM () +checkTyCoVarInScope what subst tcv + = checkL (tcv `isInScope` subst) $ + hang (text "The" <+> text what <+> text "variable" <+> pprBndr LetBind tcv) + 2 (text "is out of scope") + +------------------- lintType :: Type -> LintM LintedType -- If you edit this function, you may need to update the GHC formalism @@ -1772,12 +1783,9 @@ lintType (TyVarTy tv) -- In GHCi we may lint an expression with a free -- type variable. Then it won't be in the -- substitution, but it should be in scope - Nothing | tv `isInScope` subst - -> return (TyVarTy tv) - | otherwise - -> failWithL $ - hang (text "The type variable" <+> pprBndr LetBind tv) - 2 (text "is out of scope") + Nothing -> + do { checkTyCoVarInScope "type" subst tv + ; return (TyVarTy tv) } } lintType ty@(AppTy t1 t2) @@ -2125,18 +2133,6 @@ which is what used to happen. But that proved tricky and error prone (#17923), so now we return the coercion. -} - --- lints a coercion, confirming that its lh kind and its rh kind are both * --- also ensures that the role is Nominal -lintStarCoercion :: InCoercion -> LintM LintedCoercion -lintStarCoercion g - = do { g' <- lintCoercion g - ; let Pair t1 t2 = coercionKind g' - ; checkValueType t1 (text "the kind of the left type in" <+> ppr g) - ; checkValueType t2 (text "the kind of the right type in" <+> ppr g) - ; lintRole g Nominal (coercionRole g) - ; return g' } - lintCoercion :: InCoercion -> LintM LintedCoercion -- If you edit this function, you may need to update the GHC formalism -- See Note [GHC Formalism] @@ -2150,18 +2146,12 @@ lintCoercion (CoVarCo cv) = do { subst <- getSubst ; case lookupCoVar subst cv of Just linted_co -> return linted_co ; - Nothing - | cv `isInScope` subst - -> return (CoVarCo cv) - | otherwise - -> - -- lintCoBndr always extends the substitution - failWithL $ - hang (text "The coercion variable" <+> pprBndr LetBind cv) - 2 (text "is out of scope") + Nothing -> + -- lintCoBndr always extends the substitition + do { checkTyCoVarInScope "coercion" subst cv + ; return (CoVarCo cv) } } - lintCoercion (Refl ty) = do { ty' <- lintType ty ; return (Refl ty') } @@ -2229,7 +2219,13 @@ lintCoercion co@(ForAllCo tcv kind_co body_co) ; lintTyCoBndr tcv $ \tcv' -> do { body_co' <- lintCoercion body_co ; ensureEqTys (varType tcv') (coercionLKind kind_co') $ - text "Kind mis-match in ForallCo" <+> ppr co + vcat [ text "Kind mis-match in ForallCo" <+> ppr co + , text "Type variable type:" <+> ppr (varType tcv') + , text " Coercion LHS type:" <+> ppr (coercionLKind kind_co') + , text "Type variable:" <+> ppr tcv + , text " Linted tyvar:" <+> ppr tcv' + , text "Kind coercion:" <+> ppr kind_co + , text " Linted kco:" <+> ppr kind_co ] -- Assuming kind_co :: k1 ~ k2 -- Need to check that @@ -2278,13 +2274,27 @@ lintCoercion co@(FunCo { fco_role = r, fco_afl = afl, fco_afr = afr , text "arg_co:" <+> ppr co1 , text "res_co:" <+> ppr co2 ]) +lintCoercion (HydrateDCo r ty dco rty) = + do { ty' <- lintType ty + ; rty' <- lintType rty + ; co <- lintDCoercion r ty' dco + ; let rty = coercionRKind co + ; ensureEqTys rty' rty $ + vcat [ text "Mismatch of cached RHS type in HydrateDCo" + , text "dco:" <+> ppr dco + , text "stored RHS:" <+> ppr rty' + , text "computed RHS:" <+> ppr rty + , text "LHS:" <+> ppr ty + , text "role:" <+> ppr r ] + ; return co } + -- See Note [Bad unsafe coercion] -lintCoercion co@(UnivCo prov r ty1 ty2) +lintCoercion (UnivCo prov r ty1 ty2) = do { ty1' <- lintType ty1 ; ty2' <- lintType ty2 ; let k1 = typeKind ty1' k2 = typeKind ty2' - ; prov' <- lint_prov k1 k2 prov + ; prov' <- lintProv Co r ty1' ty2' prov ; when (r /= Phantom && isTYPEorCONSTRAINT k1 && isTYPEorCONSTRAINT k2) @@ -2343,27 +2353,6 @@ lintCoercion co@(UnivCo prov r ty1 ty2) _ -> return () } - lint_prov k1 k2 (PhantomProv kco) - = do { kco' <- lintStarCoercion kco - ; lintRole co Phantom r - ; check_kinds kco' k1 k2 - ; return (PhantomProv kco') } - - lint_prov k1 k2 (ProofIrrelProv kco) - = do { lintL (isCoercionTy ty1) (mkBadProofIrrelMsg ty1 co) - ; lintL (isCoercionTy ty2) (mkBadProofIrrelMsg ty2 co) - ; kco' <- lintStarCoercion kco - ; check_kinds kco k1 k2 - ; return (ProofIrrelProv kco') } - - lint_prov _ _ prov@(PluginProv _) = return prov - lint_prov _ _ prov@(CorePrepProv _) = return prov - - check_kinds kco k1 k2 - = do { let Pair k1' k2' = coercionKind kco - ; ensureEqTys k1 k1' (mkBadUnivCoMsg CLeft co) - ; ensureEqTys k2 k2' (mkBadUnivCoMsg CRight co) } - lintCoercion (SymCo co) = do { co' <- lintCoercion co @@ -2530,6 +2519,206 @@ lintCoercion (HoleCo h) = do { addErrL $ text "Unfilled coercion hole:" <+> ppr h ; lintCoercion (CoVarCo (coHoleCoVar h)) } +lintDCoercion :: Role -> LintedType -> DCoercion -> LintM LintedCoercion +lintDCoercion r l_ty dco = case dco of + + CoVarDCo cv + | not (isCoVar cv) + -> failWithL (hang (text "Bad CoVarDCo:" <+> ppr cv) + 2 (text "With offending type:" <+> ppr (varType cv))) + | otherwise + -> do { lintRole dco r (coVarRole cv) + ; cv_ty_l <- lintType $ coVarLType cv + ; ensureEqTys l_ty cv_ty_l + (hang (text "lintDCoercion: CoVarDCo LHS mis-match:" <+> ppr cv) + 2 (vcat [text "Expected type:" <+> ppr l_ty + ,text " Actual type:" <+> ppr cv_ty_l])) + ; subst <- getSubst + ; case lookupCoVar subst cv of + Just linted_co + -> return linted_co + Nothing + | cv `isInScope` subst + -> return (CoVarCo cv) + | otherwise + -> -- lintCoBndr always extends the substitition + failWithL $ + hang (text "The coercion variable" <+> pprBndr LetBind cv) + 2 (text "is out of scope in this directed coercion") + } + + ReflDCo -> + -- N.B.: the role might well not be Nominal. + return (mkReflCo r l_ty) + + GReflRightDCo co -> + do { co' <- lintCoercion co + ; return (GRefl r l_ty (coToMCo co')) } + + GReflLeftDCo co -> + do { sym_co' <- lintCoercion (mkSymCo co) + ; return (GRefl r l_ty (coToMCo sym_co')) } + + SubDCo dco -> + do { lintRole dco Representational r + ; co <- lintDCoercion Nominal l_ty dco + ; return (SubCo co) } + + TyConAppDCo dcos + | Just (tc, l_tys) <- splitTyConApp_maybe l_ty + -> do { checkTyCon tc + ; checkL (dcos `equalLength` l_tys) $ + vcat [ text "mismatched number of arguments in TyConAppDCo" + , text "args:" <+> ppr l_tys + , text "dcos:" <+> ppr dcos ] + ; cos <- zipWith3M lintDCoercion (tyConRoleListX r tc) l_tys dcos + ; lintCoercion $ mkTyConAppCo r tc cos } + | otherwise + -> failWithL (text "TyConAppDCo where LHS type is not a TyCon:" <+> ppr l_ty) + + AppDCo dco1 dco2 +{- | TyConAppDCo {} <- dco1 + -> failWithL (text "TyConAppDCo to the left of AppDCo:" <+> ppr dco) + | TyConApp {} <- l_ty + , isReflDCo dco1 + -> failWithL (text "ReflDCo (TyConApp ...) to the left of AppDCo:" <+> ppr dco) +-} + | Just (l_ty1, l_ty2) <- splitAppTy_maybe l_ty + -> do { co1' <- lintDCoercion r l_ty1 dco1 + ; let + r2 + | Phantom <- r + = Phantom + | otherwise + = Nominal + ; co2' <- lintDCoercion r2 l_ty2 dco2 + ; return (mkAppCo co1' co2') } + | otherwise + -> failWithL (text "AppDCo where type is not an AppTy:" <+> ppr l_ty) + + ForAllDCo tcv kco body_dco + | not (isTyCoVar tcv) + -> failWithL (text "Non tyco binder in ForAllDCo:" <+> ppr dco) + | otherwise + -> do { let l_ki = tyVarKind tcv + ; kco' <- lintStarDCoercion Nominal l_ki kco + ; lintTyCoBndr tcv $ \tcv' -> + case splitForAllTyCoVar_maybe l_ty of + Nothing -> failWithL (text "ForAllDCo where LHS type is not a ForAllTy: " <+> ppr l_ty <+> ppr dco) + Just (tcv'', body_ty) -> + do { in_scope <- getInScope + -- AMG TODO: is there a cleaner way of doing this? + ; let body_ty' = substTyWithInScope in_scope [tcv''] [mkTyVarTy tcv'] body_ty + ; lintForAllBody tcv' body_ty' + ; body_co <- lintDCoercion r body_ty' body_dco + ; let rhs_ty = coercionRKind body_co + ; lintForAllBody tcv' rhs_ty -- AMG TODO: check anything else about rhs_ty? + ; let co' = ForAllCo tcv' kco' body_co + -- AMG TODO: if CoVar, check occurs only in Refl/GRefl? + ; pure co' + } } + + AxiomInstDCo ax -> + do { (co, _ty) <- expandAxiomInstDCo (\ prop msg v -> lintL prop msg *> v) failWithL + r l_ty ax + ; return co } + + StepsDCo 0 + -> return (mkReflCo r l_ty) + StepsDCo n -> + do { (co, ty) <- expandOneStepDCo (\ prop msg v -> lintL prop msg *> v) failWithL + r l_ty + ; co' <- lintDCoercion r ty (StepsDCo (n-1)) + ; lintCoercion $ co `mkTransCo` co' } + + UnivDCo prov r_ty -> + do { r_ty' <- lintType r_ty + ; prov' <- lintProv DCo r l_ty r_ty prov + ; return (UnivCo prov' r l_ty r_ty') } + + TransDCo dco1 dco2 -> + do { co1' <- lintDCoercion r l_ty dco1 + ; let mid_ty = coercionRKind co1' + ; co2' <- lintDCoercion r mid_ty dco2 + ; return (TransCo co1' co2') } + + DehydrateCo co -> + do { co' <- lintCoercion co + ; let co_ty_l = coercionLKind co' + co_r = coercionRole co' + + ; checkL (r == co_r) $ + hang (text "lintDCoercion: DehydrateCo role mismatch:" <+> ppr co) + 2 (vcat [text "Expected role:" <+> ppr r + ,text " Actual role:" <+> ppr co_r]) + ; ensureEqTys l_ty co_ty_l + (hang (text "lintDCoercion: DehydrateCo LHS mis-match:" <+> ppr co) + 2 (vcat [text "Expected type:" <+> ppr l_ty + ,text " Actual type:" <+> ppr co_ty_l])) + ; return co' } + +-- | Lint the provenance of a universal coercion (or directed coercion). +lintProv :: forall co + . CoOrDCo co + -> Role + -> LintedType + -> LintedType + -> UnivCoProvenance co + -> LintM (UnivCoProvenance LintedCoercion) +lintProv co_or_dco r ty1 ty2 prov = case prov of + PhantomProv kco -> + do { kco' <- lint_star kco + ; lintRole prov Phantom r + ; check_kinds kco' + ; return (PhantomProv kco') } + + ProofIrrelProv kco -> + do { lintL (isCoercionTy ty1) (mkBadProofIrrelMsg ty1 prov) + ; lintL (isCoercionTy ty2) (mkBadProofIrrelMsg ty2 prov) + ; kco' <- lint_star kco + ; check_kinds kco' + ; return (ProofIrrelProv kco') } + + PluginProv str -> + return $ PluginProv str + CorePrepProv homo -> + return $ CorePrepProv homo + + where + k1, k2 :: LintedKind + k1 = typeKind ty1 + k2 = typeKind ty2 + + lint_star :: co -> LintM LintedCoercion + lint_star + = case co_or_dco of + Co -> lintStarCoercion + DCo -> lintStarDCoercion r k1 + + check_kinds :: Coercion -> LintM () + check_kinds kco + = do { let Pair k1' k2' = coercionKind kco + ; ensureEqTys k1 k1' (mkBadUnivCoMsg CLeft prov) + ; ensureEqTys k2 k2' (mkBadUnivCoMsg CRight prov) } + +-- | Lints a kind coercion, confirming that its LHS kind and its RHS kind are both +-- @Type@, and ensures that its role is 'Nominal'. +lintStarCoercion :: InCoercion -> LintM LintedCoercion +lintStarCoercion g = checkStarCoercion (coercionRole g) =<< lintCoercion g + +-- | Like 'lintStarCoercion' but for a directed coercion. +lintStarDCoercion :: Role -> LintedKind -> DCoercion -> LintM LintedCoercion +lintStarDCoercion r l_ki g = checkStarCoercion r =<< lintDCoercion Nominal l_ki g + +-- | Performs the checks required by 'lintStarCoercion'/'lintStarDCoercion', +-- after the kind coercion has been linted on its own. +checkStarCoercion :: Role -> Coercion -> LintM LintedCoercion +checkStarCoercion r g + = do { lintRole g Nominal r + ; let Pair k1 k2 = coercionKind g + ; checkValueType k1 (text "the kind of the left type in" <+> ppr g) + ; checkValueType k2 (text "the kind of the right type in" <+> ppr g) + ; return g } {- Note [Conflict checking with AxiomInstCo] @@ -3313,13 +3502,14 @@ ensureSubMult actual_mult described_mult err_msg = do | otherwise = m `eqType` n lintRole :: Outputable thing - => thing -- where the role appeared - -> Role -- expected - -> Role -- actual - -> LintM () + => thing -- where the role appeared + -> Role -- expected + -> Role -- actual + -> LintM () lintRole co r1 r2 = lintL (r1 == r2) (text "Role incompatibility: expected" <+> ppr r1 <> comma <+> + text ": expected" <+> ppr r1 <> comma <+> text "got" <+> ppr r2 $$ text "in" <+> ppr co) @@ -3550,16 +3740,16 @@ mk_cast_err thing_str co_str pp_thing co from_ty thing_ty from_msg = text "From-" <> co_msg enclosed_msg = text "enclosed" <+> text thing_str -mkBadUnivCoMsg :: LeftOrRight -> Coercion -> SDoc -mkBadUnivCoMsg lr co +mkBadUnivCoMsg :: LeftOrRight -> UnivCoProvenance co -> SDoc +mkBadUnivCoMsg lr prov = text "Kind mismatch on the" <+> pprLeftOrRight lr <+> - text "side of a UnivCo:" <+> ppr co + text "side of a UnivCo:" <+> ppr prov -mkBadProofIrrelMsg :: Type -> Coercion -> SDoc -mkBadProofIrrelMsg ty co +mkBadProofIrrelMsg :: Outputable prov => Type -> prov -> SDoc +mkBadProofIrrelMsg ty prov = hang (text "Found a non-coercion in a proof-irrelevance UnivCo:") 2 (vcat [ text "type:" <+> ppr ty - , text "co:" <+> ppr co ]) + , text "prov:" <+> ppr prov ]) mkBadTyVarMsg :: Var -> SDoc mkBadTyVarMsg tv diff --git a/compiler/GHC/Core/Opt/Pipeline.hs b/compiler/GHC/Core/Opt/Pipeline.hs index 0761691f84..7e626bb374 100644 --- a/compiler/GHC/Core/Opt/Pipeline.hs +++ b/compiler/GHC/Core/Opt/Pipeline.hs @@ -199,7 +199,7 @@ getCoreToDo dflags hpt_rule_base extra_vars runWhen (profiling && gopt Opt_ProfLateInlineCcs dflags) $ CoreAddLateCcs core_todo = - [ + [ -- We want to do the static argument transform before full laziness as it -- may expose extra opportunities to float things outwards. However, to fix -- up the output of the transformation we need at do at least one simplify diff --git a/compiler/GHC/Core/Opt/Simplify/Iteration.hs b/compiler/GHC/Core/Opt/Simplify/Iteration.hs index 1ecfa632e1..794b33b1fa 100644 --- a/compiler/GHC/Core/Opt/Simplify/Iteration.hs +++ b/compiler/GHC/Core/Opt/Simplify/Iteration.hs @@ -3254,9 +3254,11 @@ improveSeq :: (FamInstEnv, FamInstEnv) -> SimplEnv -> SimplM (SimplEnv, OutExpr, OutId) -- Note [Improving seq] improveSeq fam_envs env scrut case_bndr case_bndr1 [Alt DEFAULT _ _] - | Just (Reduction co ty2) <- topNormaliseType_maybe fam_envs (idType case_bndr1) + | let ty1 = idType case_bndr1 + , Just redn@(Reduction _ ty2) <- topNormaliseType_maybe fam_envs ty1 = do { case_bndr2 <- newId (fsLit "nt") ManyTy ty2 - ; let rhs = DoneEx (Var case_bndr2 `Cast` mkSymCo co) Nothing + ; let co = mkHydrateReductionDCoercion Representational ty1 redn + rhs = DoneEx (Var case_bndr2 `Cast` mkSymCo co) Nothing env2 = extendIdSubst env case_bndr rhs ; return (env2, scrut `Cast` co, case_bndr2) } diff --git a/compiler/GHC/Core/Reduction.hs b/compiler/GHC/Core/Reduction.hs index a4f1df4f70..bfa2b09523 100644 --- a/compiler/GHC/Core/Reduction.hs +++ b/compiler/GHC/Core/Reduction.hs @@ -7,18 +7,21 @@ module GHC.Core.Reduction -- * Reductions Reduction(..), ReductionN, ReductionR, HetReduction(..), Reductions(..), - mkReduction, mkReductions, mkHetReduction, coercionRedn, - reductionOriginalType, - downgradeRedn, mkSubRedn, + mkReduction, mkReductions, mkHetReduction, mkDehydrateCoercionRedn, + mkHydrateReductionDCoercion, + mkSubRedn, mkTransRedn, mkCoherenceRightRedn, mkCoherenceRightMRedn, mkCastRedn1, mkCastRedn2, mkReflRedn, mkGReflRightRedn, mkGReflRightMRedn, mkGReflLeftRedn, mkGReflLeftMRedn, mkAppRedn, mkAppRedns, mkFunRedn, mkForAllRedn, mkHomoForAllRedn, mkTyConAppRedn, mkClassPredRedn, + mkTyConAppRedn_MightBeSynonym, mkProofIrrelRedn, mkReflCoRedn, - homogeniseHetRedn, + homogeniseHetRedn, homogeniseRedn, unzipRedns, + mkReflRedns, + mkReflDCos, -- * Rewriting type arguments ArgsReductions(..), @@ -28,15 +31,14 @@ module GHC.Core.Reduction import GHC.Prelude -import GHC.Core.Class ( Class(classTyCon) ) +import GHC.Core.Class ( Class(..) ) import GHC.Core.Coercion import GHC.Core.Predicate ( mkClassPred ) -import GHC.Core.TyCon ( TyCon ) +import GHC.Core.TyCon import GHC.Core.Type import GHC.Data.Pair ( Pair(Pair) ) import GHC.Data.List.Infinite ( Infinite (..) ) -import qualified GHC.Data.List.Infinite as Inf import GHC.Types.Var ( VarBndr(..), setTyVarKind ) import GHC.Types.Var.Env ( mkInScopeSet ) @@ -46,6 +48,8 @@ import GHC.Utils.Misc ( HasDebugCallStack, equalLength ) import GHC.Utils.Outputable import GHC.Utils.Panic ( assertPpr ) +import Data.List ( zipWith4 ) + {- %************************************************************************ %* * @@ -55,170 +59,119 @@ import GHC.Utils.Panic ( assertPpr ) Note [The Reduction type] ~~~~~~~~~~~~~~~~~~~~~~~~~ -Many functions in the type-checker rewrite a type, using Given type equalitie -or type-family reductions, and return a Reduction, which is just a pair of the -coercion and the RHS type of the coercion: - data Reduction = Reduction Coercion !Type +Many functions in the type-checker rewrite a type, using Given type equalities +or type-family reductions, and return a Reduction: + + data Reduction = Reduction DCoercion !Type + +When we rewrite ty at role r, producing Reduction dco xi, we guarantee that +dco :: ty ~r xi, up to zonking. + +In particular, if ty is fully zonked, we can call followDCo, and we should have + + followDCo r ty dco ~ xi (up to zonking) -The order of the arguments to the constructor serves as a reminder -of what the Type is. In - Reduction co ty -`ty` appears to the right of `co`, reminding us that we must have: - co :: unrewritten_ty ~ ty +The order of the arguments to the constructor serves as a reminder: + + ty ~rewrite~> Reduction dco xi + +the rewritten type appears on the right, reminding us that we must have: + + dco :: ty ~r xi Example functions that use this datatype: + GHC.Core.FamInstEnv.topNormaliseType_maybe :: FamInstEnvs -> Type -> Maybe Reduction GHC.Tc.Solver.Rewrite.rewrite :: CtEvidence -> TcType -> TcS Reduction Having Reduction as a data type, with a strict Type field, rather than using -a pair (Coercion,Type) gives several advantages (see #20161) +a tuple (with all fields lazy), gives several advantages (see #20161) * The strictness in Type improved performance in rewriting of type families (around 2.5% improvement in T9872), * Compared to the situation before, it gives improved consistency around orientation of rewritings, as a Reduction is always left-to-right (the coercion's RHS type is always the type stored in the 'Reduction'). No more 'mkSymCo's needed to convert between left-to-right and right-to-left. - -One could imagine storing the LHS type of the coercion in the Reduction as well, -but in fact `reductionOriginalType` is very seldom used, so it's not worth it. -} -- | A 'Reduction' is the result of an operation that rewrites a type @ty_in@. --- The 'Reduction' includes the rewritten type @ty_out@ and a 'Coercion' @co@ --- such that @co :: ty_in ~ ty_out@, where the role of the coercion is determined --- by the context. That is, the LHS type of the coercion is the original type --- @ty_in@, while its RHS type is the rewritten type @ty_out@. +-- The 'Reduction' includes: +-- +-- - a directed coercion @dco@, +-- - the rewritten type @ty_out@ -- --- A Reduction is always homogeneous, unless it is wrapped inside a 'HetReduction', --- which separately stores the kind coercion. +-- such that @dco :: ty_in ~ ty_out@, where the role @r@ of the coercion +-- is determined by the context. -- -- See Note [The Reduction type]. data Reduction = Reduction - { reductionCoercion :: Coercion - , reductionReducedType :: !Type + { reductionDCoercion :: DCoercion + , reductionReducedType :: !Type } --- N.B. the 'Coercion' field must be lazy: see for instance GHC.Tc.Solver.Rewrite.rewrite_tyvar2 --- which returns an error in the 'Coercion' field when dealing with a Derived constraint --- (which is OK as this Coercion gets ignored later). --- We might want to revisit the strictness once Deriveds are removed. +-- NB: the DCoercion field is left lazy, as we might not have any need +-- to look at it. --- | Stores a heterogeneous reduction. --- --- The stored kind coercion must relate the kinds of the --- stored reduction. That is, in @HetReduction (Reduction co xi) kco@, --- we must have: --- --- > co :: ty ~ xi --- > kco :: typeKind ty ~ typeKind xi -data HetReduction = - HetReduction - Reduction - MCoercionN - -- N.B. strictness annotations don't seem to make a difference here - --- | Create a heterogeneous reduction. --- --- Pre-condition: the provided kind coercion (second argument) --- relates the kinds of the stored reduction. --- That is, if the coercion stored in the 'Reduction' is of the form --- --- > co :: ty ~ xi --- --- Then the kind coercion supplied must be of the form: --- --- > kco :: typeKind ty ~ typeKind xi -mkHetReduction :: Reduction -- ^ heterogeneous reduction - -> MCoercionN -- ^ kind coercion - -> HetReduction -mkHetReduction redn mco = HetReduction redn mco -{-# INLINE mkHetReduction #-} +-- | A 'Reduction' in which the 'Coercion' has 'Nominal' role. +type ReductionN = Reduction --- | Homogenise a heterogeneous reduction. --- --- Given @HetReduction (Reduction co xi) kco@, with --- --- > co :: ty ~ xi --- > kco :: typeKind(ty) ~ typeKind(xi) --- --- this returns the homogeneous reduction: --- --- > hco :: ty ~ ( xi |> sym kco ) -homogeniseHetRedn :: Role -> HetReduction -> Reduction -homogeniseHetRedn role (HetReduction redn kco) - = mkCoherenceRightMRedn role redn (mkSymMCo kco) -{-# INLINE homogeniseHetRedn #-} +-- | A 'Reduction' in which the 'Coercion' has 'Representational' role. +type ReductionR = Reduction --- | Create a 'Reduction' from a pair of a 'Coercion' and a 'Type. --- --- Pre-condition: the RHS type of the coercion matches the provided type --- (perhaps up to zonking). +-- | Create a 'Reduction' from a pair of a 'DCoercion' and a 'Type. -- --- Use 'coercionRedn' when you only have the coercion. -mkReduction :: Coercion -> Type -> Reduction -mkReduction co ty = Reduction co ty +-- Use 'mkDehydrateCoercionRedn' when you only have a 'Coercion'. +mkReduction :: DCoercion -> Type -> Reduction +mkReduction co rty = Reduction co rty {-# INLINE mkReduction #-} instance Outputable Reduction where ppr redn = braces $ vcat - [ text "reductionOriginalType:" <+> ppr (reductionOriginalType redn) - , text " reductionReducedType:" <+> ppr (reductionReducedType redn) - , text " reductionCoercion:" <+> ppr (reductionCoercion redn) + [ text " reductionReducedType:" <+> ppr (reductionReducedType redn) + , text " reductionDCoercion:" <+> ppr (reductionDCoercion redn) ] --- | A 'Reduction' in which the 'Coercion' has 'Nominal' role. -type ReductionN = Reduction +-- | Turn a 'Coercion' into a 'Reduction' by dehydrating. +-- +-- Prefer using 'mkReduction' wherever possible to avoid doing these indirections. +mkDehydrateCoercionRedn :: Coercion -> Reduction +mkDehydrateCoercionRedn co = + Reduction (mkDehydrateCo co) (coercionRKind co) +{-# INLINE mkDehydrateCoercionRedn #-} --- | A 'Reduction' in which the 'Coercion' has 'Representational' role. -type ReductionR = Reduction +-- | Hydrate the 'DCoercion' stored inside a 'Reduction' into a full-fledged 'Coercion'. +mkHydrateReductionDCoercion :: HasDebugCallStack + => Role + -> Type -- ^ LHS type (must not contain metavariables) + -> Reduction + -> Coercion +mkHydrateReductionDCoercion r lty (Reduction dco rty) = mkHydrateDCo r lty dco rty +{-# INLINE mkHydrateReductionDCoercion #-} --- | Get the original, unreduced type corresponding to a 'Reduction'. --- --- This is obtained by computing the LHS kind of the stored coercion, --- which may be slow. -reductionOriginalType :: Reduction -> Type -reductionOriginalType = coercionLKind . reductionCoercion -{-# INLINE reductionOriginalType #-} - --- | Turn a 'Coercion' into a 'Reduction' --- by inspecting the RHS type of the coercion. --- --- Prefer using 'mkReduction' when you already know --- the RHS type of the coercion, to avoid computing it anew. -coercionRedn :: Coercion -> Reduction -coercionRedn co = Reduction co (coercionRKind co) -{-# INLINE coercionRedn #-} - --- | Downgrade the role of the coercion stored in the 'Reduction'. -downgradeRedn :: Role -- ^ desired role - -> Role -- ^ current role - -> Reduction - -> Reduction -downgradeRedn new_role old_role redn@(Reduction co _) - = redn { reductionCoercion = downgradeRole new_role old_role co } -{-# INLINE downgradeRedn #-} - --- | Downgrade the role of the coercion stored in the 'Reduction', +-- | Downgrade the role of the directed coercion stored in the 'Reduction', -- from 'Nominal' to 'Representational'. -mkSubRedn :: Reduction -> Reduction -mkSubRedn redn@(Reduction co _) = redn { reductionCoercion = mkSubCo co } +mkSubRedn :: HasDebugCallStack => Type -> Reduction -> Reduction +mkSubRedn lhs redn@(Reduction dco rhs) + = redn { reductionDCoercion = mkSubDCo lhs dco rhs } {-# INLINE mkSubRedn #-} --- | Compose a reduction with a coercion on the left. +-- | Compose two reductions. -- --- Pre-condition: the provided coercion's RHS type must match the LHS type --- of the coercion that is stored in the reduction. -mkTransRedn :: Coercion -> Reduction -> Reduction -mkTransRedn co1 redn@(Reduction co2 _) - = redn { reductionCoercion = co1 `mkTransCo` co2 } +-- Assumes that forming a composite is valid, i.e. the RHS type of +-- the first directed coercion equals, up to zonking, +-- the LHS type of the second directed coercion. +mkTransRedn :: Reduction -> Reduction -> Reduction +mkTransRedn (Reduction dco1 _) (Reduction dco2 ty2) + = Reduction (dco1 `mkTransDCo` dco2) ty2 {-# INLINE mkTransRedn #-} -- | The reflexive reduction. -mkReflRedn :: Role -> Type -> Reduction -mkReflRedn r ty = mkReduction (mkReflCo r ty) ty +mkReflRedn :: Type -> Reduction +mkReflRedn ty = mkReduction mkReflDCo ty +{-# INLINE mkReflRedn #-} -- | Create a 'Reduction' from a kind cast, in which -- the casted type is the rewritten type. @@ -226,10 +179,10 @@ mkReflRedn r ty = mkReduction (mkReflCo r ty) ty -- Given @ty :: k1@, @mco :: k1 ~ k2@, -- produces the 'Reduction' @ty ~res_co~> (ty |> mco)@ -- at the given 'Role'. -mkGReflRightRedn :: Role -> Type -> CoercionN -> Reduction -mkGReflRightRedn role ty co +mkGReflRightRedn :: Type -> CoercionN -> Reduction +mkGReflRightRedn ty co = mkReduction - (mkGReflRightCo role ty co) + (mkGReflRightDCo co) (mkCastTy ty co) {-# INLINE mkGReflRightRedn #-} @@ -239,11 +192,13 @@ mkGReflRightRedn role ty co -- Given @ty :: k1@, @mco :: k1 ~ k2@, -- produces the 'Reduction' @ty ~res_co~> (ty |> mco)@ -- at the given 'Role'. -mkGReflRightMRedn :: Role -> Type -> MCoercionN -> Reduction -mkGReflRightMRedn role ty mco +mkGReflRightMRedn :: Type -> MCoercionN -> Reduction +mkGReflRightMRedn ty MRefl + = mkReflRedn ty +mkGReflRightMRedn ty (MCo kco) = mkReduction - (mkGReflRightMCo role ty mco) - (mkCastTyMCo ty mco) + (mkGReflRightDCo kco) + (mkCastTy ty kco) {-# INLINE mkGReflRightMRedn #-} -- | Create a 'Reduction' from a kind cast, in which @@ -252,10 +207,10 @@ mkGReflRightMRedn role ty mco -- Given @ty :: k1@, @mco :: k1 ~ k2@, -- produces the 'Reduction' @(ty |> mco) ~res_co~> ty@ -- at the given 'Role'. -mkGReflLeftRedn :: Role -> Type -> CoercionN -> Reduction -mkGReflLeftRedn role ty co +mkGReflLeftRedn :: Type -> CoercionN -> Reduction +mkGReflLeftRedn ty co = mkReduction - (mkGReflLeftCo role ty co) + (mkGReflLeftDCo co) ty {-# INLINE mkGReflLeftRedn #-} @@ -265,10 +220,12 @@ mkGReflLeftRedn role ty co -- Given @ty :: k1@, @mco :: k1 ~ k2@, -- produces the 'Reduction' @(ty |> mco) ~res_co~> ty@ -- at the given 'Role'. -mkGReflLeftMRedn :: Role -> Type -> MCoercionN -> Reduction -mkGReflLeftMRedn role ty mco +mkGReflLeftMRedn :: Type -> MCoercionN -> Reduction +mkGReflLeftMRedn ty MRefl + = mkReflRedn ty +mkGReflLeftMRedn ty (MCo kco) = mkReduction - (mkGReflLeftMCo role ty mco) + (mkGReflLeftDCo kco) ty {-# INLINE mkGReflLeftMRedn #-} @@ -278,10 +235,10 @@ mkGReflLeftMRedn role ty mco -- with LHS kind @k2@, produce a new 'Reduction' @ty1 ~co2~> ( ty2 |> kco )@ -- of the given 'Role' (which must match the role of the coercion stored -- in the 'Reduction' argument). -mkCoherenceRightRedn :: Role -> Reduction -> CoercionN -> Reduction -mkCoherenceRightRedn r (Reduction co1 ty2) kco +mkCoherenceRightRedn :: Reduction -> CoercionN -> Reduction +mkCoherenceRightRedn (Reduction co1 ty2) kco = mkReduction - (mkCoherenceRightCo r ty2 kco co1) + (mkCoherenceRightDCo kco co1) (mkCastTy ty2 kco) {-# INLINE mkCoherenceRightRedn #-} @@ -291,11 +248,12 @@ mkCoherenceRightRedn r (Reduction co1 ty2) kco -- with LHS kind @k2@, produce a new 'Reduction' @ty1 ~co2~> ( ty2 |> mco )@ -- of the given 'Role' (which must match the role of the coercion stored -- in the 'Reduction' argument). -mkCoherenceRightMRedn :: Role -> Reduction -> MCoercionN -> Reduction -mkCoherenceRightMRedn r (Reduction co1 ty2) kco +mkCoherenceRightMRedn :: Reduction -> MCoercionN -> Reduction +mkCoherenceRightMRedn redn MRefl = redn +mkCoherenceRightMRedn (Reduction co1 ty2) (MCo kco) = mkReduction - (mkCoherenceRightMCo r ty2 kco co1) - (mkCastTyMCo ty2 kco) + (mkCoherenceRightDCo kco co1) + (mkCastTy ty2 kco) {-# INLINE mkCoherenceRightMRedn #-} -- | Apply a cast to a 'Reduction', casting both the original and the reduced type. @@ -307,16 +265,14 @@ mkCoherenceRightMRedn r (Reduction co1 ty2) kco -- -- Pre-condition: the 'Type' passed in is the same as the LHS type -- of the coercion stored in the 'Reduction'. -mkCastRedn1 :: Role - -> Type -- ^ original type - -> CoercionN -- ^ coercion to cast with - -> Reduction -- ^ rewritten type, with rewriting coercion +mkCastRedn1 :: CoercionN -- ^ coercion to cast with + -> Reduction -- ^ rewritten type, with rewriting coercion -> Reduction -mkCastRedn1 r ty cast_co (Reduction co xi) +mkCastRedn1 cast_co (Reduction dco xi) -- co :: ty ~r ty' -- return_co :: (ty |> cast_co) ~r (ty' |> cast_co) = mkReduction - (castCoercionKind1 co r ty xi cast_co) + (castDCoercionKind1 dco cast_co) (mkCastTy xi cast_co) {-# INLINE mkCastRedn1 #-} @@ -327,15 +283,13 @@ mkCastRedn1 r ty cast_co (Reduction co xi) -- -- Pre-condition: the 'Type' passed in is the same as the LHS type -- of the coercion stored in the 'Reduction'. -mkCastRedn2 :: Role - -> Type -- ^ original type - -> CoercionN -- ^ coercion to cast with on the left +mkCastRedn2 :: CoercionN -- ^ coercion to cast with on the left -> Reduction -- ^ rewritten type, with rewriting coercion -> CoercionN -- ^ coercion to cast with on the right -> Reduction -mkCastRedn2 r ty cast_co (Reduction nco nty) cast_co' +mkCastRedn2 cast_co (Reduction nco nty) cast_co' = mkReduction - (castCoercionKind2 nco r ty nty cast_co cast_co') + (castDCoercionKind2 nco cast_co cast_co') (mkCastTy nty cast_co') {-# INLINE mkCastRedn2 #-} @@ -343,26 +297,31 @@ mkCastRedn2 r ty cast_co (Reduction nco nty) cast_co' -- -- Combines 'mkAppCo' and 'mkAppTy`. mkAppRedn :: Reduction -> Reduction -> Reduction -mkAppRedn (Reduction co1 ty1) (Reduction co2 ty2) - = mkReduction (mkAppCo co1 co2) (mkAppTy ty1 ty2) +mkAppRedn (Reduction co1 rty1) (Reduction co2 rty2) + = mkReduction + (mkAppDCo co1 co2) + (mkAppTy rty1 rty2) {-# INLINE mkAppRedn #-} -- | Create a function 'Reduction'. -- -- Combines 'mkFunCo' and 'mkFunTy'. -mkFunRedn :: Role - -> FunTyFlag +mkFunRedn :: FunTyFlag -> ReductionN -- ^ multiplicity reduction + -> DCoercionN -- ^ argument 'RuntimeRep' coercion + -> DCoercionN -- ^ result 'RuntimeRep' coercion -> Reduction -- ^ argument reduction -> Reduction -- ^ result reduction -> Reduction -mkFunRedn r af - (Reduction w_co w_ty) - (Reduction arg_co arg_ty) - (Reduction res_co res_ty) +mkFunRedn af + (Reduction w_co w_rty) + arg_repco + res_repco + (Reduction arg_co arg_rty) + (Reduction res_co res_rty) = mkReduction - (mkFunCo r af w_co arg_co res_co) - (mkFunTy af w_ty arg_ty res_ty) + (mkFunDCo af w_co arg_repco res_repco arg_co res_co) + (mkFunTy af w_rty arg_rty res_rty) {-# INLINE mkFunRedn #-} -- | Create a 'Reduction' associated to a Π type, @@ -374,48 +333,44 @@ mkForAllRedn :: ForAllTyFlag -> ReductionN -- ^ kind reduction -> Reduction -- ^ body reduction -> Reduction -mkForAllRedn vis tv1 (Reduction h ki') (Reduction co ty) +mkForAllRedn vis tv1 (Reduction h rki) (Reduction co rty) = mkReduction - (mkForAllCo tv1 h co) - (mkForAllTy (Bndr tv2 vis) ty) + (mkForAllDCo tv1 h co) + (mkForAllTy (Bndr tv2 vis) rty) where - tv2 = setTyVarKind tv1 ki' + tv2 = setTyVarKind tv1 rki {-# INLINE mkForAllRedn #-} -- | Create a 'Reduction' of a quantified type from a -- 'Reduction' of the body. -- -- Combines 'mkHomoForAllCos' and 'mkForAllTys'. -mkHomoForAllRedn :: [TyVarBinder] -> Reduction -> Reduction -mkHomoForAllRedn bndrs (Reduction co ty) +mkHomoForAllRedn :: [TyVarBinder] -> Type -> Reduction -> Reduction +mkHomoForAllRedn bndrs ty1 (Reduction co ty2) = mkReduction - (mkHomoForAllCos (binderVars bndrs) co) - (mkForAllTys bndrs ty) + (mkHomoForAllDCos (binderVars bndrs) (typeTypeOrConstraint ty1) co) + (mkForAllTys bndrs ty2) {-# INLINE mkHomoForAllRedn #-} -- | Create a 'Reduction' from a coercion between coercions. -- -- Combines 'mkProofIrrelCo' and 'mkCoercionTy'. -mkProofIrrelRedn :: Role -- ^ role of the created coercion, "r" - -> CoercionN -- ^ co :: phi1 ~N phi2 - -> Coercion -- ^ g1 :: phi1 - -> Coercion -- ^ g2 :: phi2 - -> Reduction -- ^ res_co :: g1 ~r g2 -mkProofIrrelRedn role co g1 g2 +mkProofIrrelRedn :: Coercion -- ^ lhs_co + -> DCoercionN -- ^ dco :: lhs_co ~ rhs_co + -> Coercion -- ^ rhs_co + -> Reduction +mkProofIrrelRedn _g1 co g2 = mkReduction - (mkProofIrrelCo role co g1 g2) - (mkCoercionTy g2) + (mkProofIrrelDCo co rhs_co) + rhs_co + where + rhs_co = mkCoercionTy g2 {-# INLINE mkProofIrrelRedn #-} --- | Create a reflexive 'Reduction' whose RHS is the given 'Coercion', +-- | Create a reflexive 'Reduction' whose LHS and RHS is the given 'Coercion', -- with the specified 'Role'. -mkReflCoRedn :: Role -> Coercion -> Reduction -mkReflCoRedn role co - = mkReduction - (mkReflCo role co_ty) - co_ty - where - co_ty = mkCoercionTy co +mkReflCoRedn :: Coercion -> Reduction +mkReflCoRedn co = mkReduction mkReflDCo (mkCoercionTy co) {-# INLINE mkReflCoRedn #-} -- | A collection of 'Reduction's where the coercions and the types are stored separately. @@ -425,36 +380,72 @@ mkReflCoRedn role co -- This datatype is used in 'mkAppRedns', 'mkClassPredRedns' and 'mkTyConAppRedn', -- which expect separate types and coercions. -- --- Invariant: the two stored lists are of the same length, --- and the RHS type of each coercion is the corresponding type. -data Reductions = Reductions [Coercion] [Type] +-- Invariant: given @Reductions lhs_tys dcos rhs_tys@, and an ambient role @r@, +-- we can obtain the @rhs_tys@ by following the directed coercions starting from the repsective +-- @lhs_tys@. Equivalently, @zipWith (followDCo r) lhs_tys dcos@ is equal (up to zonking) to @rhs_tys@. +data Reductions = Reductions [DCoercion] [Type] + +instance Outputable Reductions where + ppr (Reductions dcos rtys) = parens (text "Reductions" <+> ppr dcos <+> ppr rtys) -- | Create 'Reductions' from individual lists of coercions and types. -- -- The lists should be of the same length, and the RHS type of each coercion -- should match the specified type in the other list. -mkReductions :: [Coercion] -> [Type] -> Reductions -mkReductions cos tys = Reductions cos tys +mkReductions :: [DCoercion] -> [Type] -> Reductions +mkReductions cos tys2 = Reductions cos tys2 {-# INLINE mkReductions #-} +mkReflRedns :: [Type] -> Reductions +mkReflRedns tys = mkReductions (mkReflDCos tys) tys +{-# INLINE mkReflRedns #-} + +mkReflDCos :: [Type] -> [DCoercion] +mkReflDCos tys = replicate (length tys) mkReflDCo +{-# INLINE mkReflDCos #-} + -- | Combines 'mkAppCos' and 'mkAppTys'. mkAppRedns :: Reduction -> Reductions -> Reduction -mkAppRedns (Reduction co ty) (Reductions cos tys) - = mkReduction (mkAppCos co cos) (mkAppTys ty tys) +mkAppRedns (Reduction co ty2) (Reductions cos tys2) + = mkReduction (mkAppDCos co cos) (mkAppTys ty2 tys2) {-# INLINE mkAppRedns #-} -- | 'TyConAppCo' for 'Reduction's: combines 'mkTyConAppCo' and `mkTyConApp`. -mkTyConAppRedn :: Role -> TyCon -> Reductions -> Reduction -mkTyConAppRedn role tc (Reductions cos tys) - = mkReduction (mkTyConAppCo role tc cos) (mkTyConApp tc tys) +-- +-- Use this when you know the 'TyCon' is not a type synonym. If it might be, +-- use 'mkTyConAppRedn_MightBeSynonym'. +mkTyConAppRedn :: TyCon -> Reductions -> Reduction +mkTyConAppRedn tc (Reductions cos tys2) + = mkReduction (mkTyConAppDCo cos) (mkTyConApp tc tys2) {-# INLINE mkTyConAppRedn #-} +-- | 'TyConAppCo' for 'Reduction's: combines 'mkTyConAppCo' and `mkTyConApp`. +-- +-- Use 'mkTyConAppRedn' if the 'TyCon' is definitely not a type synonym. +mkTyConAppRedn_MightBeSynonym :: Role -> TyCon -> [Type] -> Reductions -> Reduction +mkTyConAppRedn_MightBeSynonym role tc tys1 redns@(Reductions dcos tys2) + -- 'mkTyConAppCo' handles synomyms by using substitution lifting. + -- We don't have that for directed coercions, so we use hydrate/dehydrate + -- so that we can call 'liftCoSubst'. + -- In the future, it might be desirable to implement substitution lifting + -- for directed coercions to avoid this (and a similar issue in simplifyArgsWorker). + | ExpandsSyn tv_dco_prs rhs_ty leftover_dcos <- expandSynTyCon_maybe tc dcos + , let tv_co_prs = zipWith4 hydrate (tyConRoleListX role tc) tys1 tv_dco_prs tys2 + = mkReduction + (mkAppDCos (mkDehydrateCo $ liftCoSubst role (mkLiftingContext tv_co_prs) rhs_ty) leftover_dcos) + (mkTyConApp tc tys2) + | otherwise = mkTyConAppRedn tc redns + where + hydrate r l (tv,dco) t = (tv, mkHydrateDCo r l dco t) + {-# INLINE hydrate #-} +{-# INLINE mkTyConAppRedn_MightBeSynonym #-} + -- | Reduce the arguments of a 'Class' 'TyCon'. mkClassPredRedn :: Class -> Reductions -> Reduction -mkClassPredRedn cls (Reductions cos tys) +mkClassPredRedn cls (Reductions cos tys2) = mkReduction - (mkTyConAppCo Nominal (classTyCon cls) cos) - (mkClassPred cls tys) + (mkTyConAppDCo cos) + (mkClassPred cls tys2) {-# INLINE mkClassPredRedn #-} -- | Obtain 'Reductions' from a list of 'Reduction's by unzipping. @@ -471,7 +462,7 @@ unzipRedns = foldr accRedn (Reductions [] []) -- -- unzipRedns <$> zipWithM f tys roles -- --- - GHC.Tc.Solver.Monad.breakTyEqCycle_maybe, with two calls of the form: +-- - GHC.Tc.Solver.Monad.breakTyVarCycle_maybe, with two calls of the form: -- -- unzipRedns <$> mapM f tys -- @@ -479,6 +470,67 @@ unzipRedns = foldr accRedn (Reductions [] []) -- but the above locations aren't performance critical, so it was deemed -- to not be worth it. +-- | Stores a heterogeneous reduction. +-- +-- The stored kind coercion must relate the kinds of the +-- stored reduction. That is, in @HetReduction (Reduction co xi) kco@, +-- we must have: +-- +-- > co :: ty ~ xi +-- > kco :: typeKind ty ~ typeKind xi +data HetReduction = + HetReduction + Reduction + MCoercionN + -- N.B. strictness annotations don't seem to make a difference here + +-- | Create a heterogeneous reduction. +-- +-- Pre-condition: the provided kind coercion (second argument) +-- relates the kinds of the stored reduction. +-- That is, if the coercion stored in the 'Reduction' is of the form +-- +-- > co :: ty ~ xi +-- +-- Then the kind coercion supplied must be of the form: +-- +-- > kco :: typeKind ty ~ typeKind xi +mkHetReduction :: Reduction -- ^ heterogeneous reduction + -> MCoercionN -- ^ kind coercion + -> HetReduction +mkHetReduction redn mco = HetReduction redn mco +{-# INLINE mkHetReduction #-} + +-- | Homogenise a heterogeneous reduction. +-- +-- Given @HetReduction (Reduction co xi) kco@, with +-- +-- > co :: ty ~ xi +-- > kco :: typeKind(ty) ~ typeKind(xi) +-- +-- this returns the homogeneous reduction: +-- +-- > hco :: ty ~ ( xi |> sym kco ) +homogeniseHetRedn :: HetReduction -> Reduction +homogeniseHetRedn (HetReduction redn kco) + = mkCoherenceRightMRedn redn (mkSymMCo kco) +{-# INLINE homogeniseHetRedn #-} + +-- | Homogenise a reduction. +-- +-- Given @redn = Reduction co xi@ and kind coercion @kco@, with +-- +-- > co :: ty ~ xi +-- > kco :: typeKind(ty) ~ typeKind(xi) +-- +-- this returns the homogeneous reduction: +-- +-- > hco :: ty ~ ( xi |> sym kco ) +homogeniseRedn :: Reduction -> MCoercionN -> Reduction +homogeniseRedn redn mco + = mkCoherenceRightMRedn redn (mkSymMCo mco) +{-# INLINE homogeniseRedn #-} + {- %************************************************************************ %* * @@ -779,6 +831,9 @@ data ArgsReductions = -- The strictness annotations and UNPACK pragma here are crucial -- to getting good performance in simplifyArgsWorker's tight loop. +instance Outputable ArgsReductions where + ppr (ArgsReductions redns kco) = parens (text "ArgsReductions" <+> ppr redns <+> ppr kco) + -- This is shared between the rewriter and the normaliser in GHC.Core.FamInstEnv. -- See Note [simplifyArgsWorker] {-# INLINE simplifyArgsWorker #-} @@ -791,6 +846,7 @@ simplifyArgsWorker :: HasDebugCallStack -- list of binders can be shorter or longer than the list of args -> TyCoVarSet -- free vars of the args -> Infinite Role-- list of roles, r + -> [Type] -- original type arguments ty_i -> [Reduction] -- rewritten type arguments, arg_i -- each comes with the coercion used to rewrite it, -- arg_co_i :: ty_i ~ arg_i @@ -804,10 +860,10 @@ simplifyArgsWorker :: HasDebugCallStack -- function is all about. That is, (f xi_1 ... xi_n), where xi_i are the returned arguments, -- *is* well kinded. simplifyArgsWorker orig_ki_binders orig_inner_ki orig_fvs - orig_roles orig_simplified_args + orig_roles tys redns = go orig_lc orig_ki_binders orig_inner_ki - orig_roles orig_simplified_args + orig_roles (zip tys redns) where orig_lc = emptyLiftingContext $ mkInScopeSet orig_fvs @@ -815,7 +871,7 @@ simplifyArgsWorker orig_ki_binders orig_inner_ki orig_fvs -> [PiTyBinder] -- Unsubsted binders of function's kind -> Kind -- Unsubsted result kind of function (not a Pi-type) -> Infinite Role -- Roles at which to rewrite these ... - -> [Reduction] -- rewritten arguments, with their rewriting coercions + -> [(Type, Reduction)] -- rewritten arguments, with their rewriting coercions -> ArgsReductions go !lc binders inner_ki _ [] -- The !lc makes the function strict in the lifting context @@ -828,7 +884,7 @@ simplifyArgsWorker orig_ki_binders orig_inner_ki orig_fvs kind_co | noFreeVarsOfType final_kind = MRefl | otherwise = MCo $ liftCoSubst Nominal lc final_kind - go lc (binder:binders) inner_ki (Inf role roles) (arg_redn:arg_redns) + go lc (binder:binders) inner_ki (Inf role roles) ((orig_ty,arg_redn):arg_redns) = -- We rewrite an argument ty with arg_redn = Reduction arg_co arg -- By Note [Rewriting] in GHC.Tc.Solver.Rewrite invariant (F2), -- typeKind(ty) = typeKind(arg). @@ -841,10 +897,11 @@ simplifyArgsWorker orig_ki_binders orig_inner_ki orig_fvs -- significantly in optimized builds; see #18502 let !kind_co = liftCoSubst Nominal lc (piTyBinderType binder) !(Reduction casted_co casted_xi) - = mkCoherenceRightRedn role arg_redn kind_co + = mkCoherenceRightRedn arg_redn kind_co -- now, extend the lifting context with the new binding !new_lc | Just tv <- namedPiTyBinder_maybe binder - = extendLiftingContextAndInScope lc tv casted_co + = extendLiftingContextAndInScope lc tv + $ mkHydrateDCo role orig_ty casted_co casted_xi | otherwise = lc !(ArgsReductions (Reductions cos xis) final_kind_co) @@ -854,14 +911,14 @@ simplifyArgsWorker orig_ki_binders orig_inner_ki orig_fvs final_kind_co -- See Note [Last case in simplifyArgsWorker] - go lc [] inner_ki roles arg_redns + go lc [] inner_ki roles arg_tys_and_redns = let co1 = liftCoSubst Nominal lc inner_ki + (orig_tys, arg_redns) = unzip arg_tys_and_redns co1_kind = coercionKind co1 - unrewritten_tys = map reductionOriginalType arg_redns - (arg_cos, res_co) = decomposePiCos co1 co1_kind unrewritten_tys - casted_args = assertPpr (equalLength arg_redns arg_cos) + (arg_cos, res_co) = decomposePiCos co1 co1_kind orig_tys + casted_redns = assertPpr (equalLength arg_redns arg_cos) (ppr arg_redns $$ ppr arg_cos) - $ zipWith3 mkCoherenceRightRedn (Inf.toList roles) arg_redns arg_cos + $ zipWith mkCoherenceRightRedn arg_redns arg_cos -- In general decomposePiCos can return fewer cos than tys, -- but not here; because we're well typed, there will be enough -- binders. Note that decomposePiCos does substitutions, so even @@ -873,6 +930,6 @@ simplifyArgsWorker orig_ki_binders orig_inner_ki orig_fvs (bndrs, new_inner) = splitPiTys rewritten_kind ArgsReductions redns_out res_co_out - = go zapped_lc bndrs new_inner roles casted_args + = go zapped_lc bndrs new_inner roles (zip orig_tys casted_redns) in ArgsReductions redns_out (res_co `mkTransMCoR` res_co_out) diff --git a/compiler/GHC/Core/SimpleOpt.hs b/compiler/GHC/Core/SimpleOpt.hs index b751b10206..8d80a072a4 100644 --- a/compiler/GHC/Core/SimpleOpt.hs +++ b/compiler/GHC/Core/SimpleOpt.hs @@ -98,8 +98,9 @@ data SimpleOpts = SimpleOpts defaultSimpleOpts :: SimpleOpts defaultSimpleOpts = SimpleOpts { so_uf_opts = defaultUnfoldingOpts - , so_co_opts = OptCoercionOpts { optCoercionEnabled = False } , so_eta_red = False + , so_co_opts = OptCoercionOpts { optCoercionOpts = Nothing } + -- Nothing <=> no coercion optimisation } simpleOptExpr :: HasDebugCallStack => SimpleOpts -> CoreExpr -> CoreExpr diff --git a/compiler/GHC/Core/TyCo/FVs.hs b/compiler/GHC/Core/TyCo/FVs.hs index aa9c04c46b..e81b711171 100644 --- a/compiler/GHC/Core/TyCo/FVs.hs +++ b/compiler/GHC/Core/TyCo/FVs.hs @@ -13,22 +13,28 @@ module GHC.Core.TyCo.FVs shallowTyCoVarsOfTyVarEnv, shallowTyCoVarsOfCoVarEnv, shallowTyCoVarsOfCo, shallowTyCoVarsOfCos, + shallowTyCoVarsOfDCo, shallowTyCoVarsOfDCos, tyCoVarsOfCo, tyCoVarsOfCos, tyCoVarsOfMCo, + tyCoVarsOfDCo, coVarsOfType, coVarsOfTypes, coVarsOfCo, coVarsOfCos, tyCoVarsOfCoDSet, tyCoFVsOfCo, tyCoFVsOfCos, tyCoVarsOfCoList, + tyCoVarsOfDCoList, almostDevoidCoVarOfCo, + almostDevoidCoVarOfDCo, -- Injective free vars injectiveVarsOfType, injectiveVarsOfTypes, isInjectiveInType, invisibleVarsOfType, invisibleVarsOfTypes, -- Any and No Free vars - anyFreeVarsOfType, anyFreeVarsOfTypes, anyFreeVarsOfCo, - noFreeVarsOfType, noFreeVarsOfTypes, noFreeVarsOfCo, + anyFreeVarsOfType, anyFreeVarsOfTypes, + anyFreeVarsOfCo, anyFreeVarsOfDCo, + noFreeVarsOfType, noFreeVarsOfTypes, + noFreeVarsOfCo, noFreeVarsOfDCo, -- * Free type constructors tyConsOfType, tyConsOfTypes, @@ -309,11 +315,15 @@ tyCoVarsOfMCo (MCo co) = tyCoVarsOfCo co tyCoVarsOfCos :: [Coercion] -> TyCoVarSet tyCoVarsOfCos cos = runTyCoVars (deep_cos cos) +tyCoVarsOfDCo :: DCoercion -> TyCoVarSet +tyCoVarsOfDCo co = runTyCoVars (deep_dco co) + deep_ty :: Type -> Endo TyCoVarSet deep_tys :: [Type] -> Endo TyCoVarSet deep_co :: Coercion -> Endo TyCoVarSet deep_cos :: [Coercion] -> Endo TyCoVarSet -(deep_ty, deep_tys, deep_co, deep_cos) = foldTyCo deepTcvFolder emptyVarSet +deep_dco :: DCoercion -> Endo TyCoVarSet +(deep_ty, deep_tys, deep_co, deep_cos, deep_dco, _) = foldTyCo deepTcvFolder emptyVarSet deepTcvFolder :: TyCoFolder TyCoVarSet (Endo TyCoVarSet) deepTcvFolder = TyCoFolder { tcf_view = noView @@ -353,6 +363,12 @@ shallowTyCoVarsOfCo co = runTyCoVars (shallow_co co) shallowTyCoVarsOfCos :: [Coercion] -> TyCoVarSet shallowTyCoVarsOfCos cos = runTyCoVars (shallow_cos cos) +shallowTyCoVarsOfDCo :: DCoercion -> TyCoVarSet +shallowTyCoVarsOfDCo dco = runTyCoVars (shallow_dco dco) + +shallowTyCoVarsOfDCos :: [DCoercion] -> TyCoVarSet +shallowTyCoVarsOfDCos dcos = runTyCoVars (shallow_dcos dcos) + -- | Returns free variables of types, including kind variables as -- a non-deterministic set. For type synonyms it does /not/ expand the -- synonym. @@ -371,7 +387,9 @@ shallow_ty :: Type -> Endo TyCoVarSet shallow_tys :: [Type] -> Endo TyCoVarSet shallow_co :: Coercion -> Endo TyCoVarSet shallow_cos :: [Coercion] -> Endo TyCoVarSet -(shallow_ty, shallow_tys, shallow_co, shallow_cos) = foldTyCo shallowTcvFolder emptyVarSet +shallow_dco :: DCoercion -> Endo TyCoVarSet +shallow_dcos :: [DCoercion] -> Endo TyCoVarSet +(shallow_ty, shallow_tys, shallow_co, shallow_cos, shallow_dco, shallow_dcos) = foldTyCo shallowTcvFolder emptyVarSet shallowTcvFolder :: TyCoFolder TyCoVarSet (Endo TyCoVarSet) shallowTcvFolder = TyCoFolder { tcf_view = noView @@ -420,7 +438,7 @@ deep_cv_ty :: Type -> Endo CoVarSet deep_cv_tys :: [Type] -> Endo CoVarSet deep_cv_co :: Coercion -> Endo CoVarSet deep_cv_cos :: [Coercion] -> Endo CoVarSet -(deep_cv_ty, deep_cv_tys, deep_cv_co, deep_cv_cos) = foldTyCo deepCoVarFolder emptyVarSet +(deep_cv_ty, deep_cv_tys, deep_cv_co, deep_cv_cos, _, _) = foldTyCo deepCoVarFolder emptyVarSet deepCoVarFolder :: TyCoFolder TyCoVarSet (Endo CoVarSet) deepCoVarFolder = TyCoFolder { tcf_view = noView @@ -617,6 +635,9 @@ tyCoVarsOfCoList :: Coercion -> [TyCoVar] -- See Note [Free variables of types] tyCoVarsOfCoList co = fvVarList $ tyCoFVsOfCo co +tyCoVarsOfDCoList :: DCoercion -> [TyCoVar] +tyCoVarsOfDCoList co = fvVarList $ tyCoFVsOfDCo co + tyCoFVsOfMCo :: MCoercion -> FV tyCoFVsOfMCo MRefl = emptyFV tyCoFVsOfMCo (MCo co) = tyCoFVsOfCo co @@ -641,9 +662,12 @@ tyCoFVsOfCo (HoleCo h) fv_cand in_scope acc = tyCoFVsOfCoVar (coHoleCoVar h) fv_cand in_scope acc -- See Note [CoercionHoles and coercion free variables] tyCoFVsOfCo (AxiomInstCo _ _ cos) fv_cand in_scope acc = tyCoFVsOfCos cos fv_cand in_scope acc +tyCoFVsOfCo (HydrateDCo _ t1 dco _) fv_cand in_scope acc + = (tyCoFVsOfType t1 `unionFV` tyCoFVsOfDCo dco) fv_cand in_scope acc tyCoFVsOfCo (UnivCo p _ t1 t2) fv_cand in_scope acc - = (tyCoFVsOfProv p `unionFV` tyCoFVsOfType t1 - `unionFV` tyCoFVsOfType t2) fv_cand in_scope acc + = (tyCoFVsOfProv tyCoFVsOfCo p + `unionFV` tyCoFVsOfType t1 + `unionFV` tyCoFVsOfType t2) fv_cand in_scope acc tyCoFVsOfCo (SymCo co) fv_cand in_scope acc = tyCoFVsOfCo co fv_cand in_scope acc tyCoFVsOfCo (TransCo co1 co2) fv_cand in_scope acc = (tyCoFVsOfCo co1 `unionFV` tyCoFVsOfCo co2) fv_cand in_scope acc tyCoFVsOfCo (SelCo _ co) fv_cand in_scope acc = tyCoFVsOfCo co fv_cand in_scope acc @@ -657,16 +681,35 @@ tyCoFVsOfCoVar :: CoVar -> FV tyCoFVsOfCoVar v fv_cand in_scope acc = (unitFV v `unionFV` tyCoFVsOfType (varType v)) fv_cand in_scope acc -tyCoFVsOfProv :: UnivCoProvenance -> FV -tyCoFVsOfProv (PhantomProv co) fv_cand in_scope acc = tyCoFVsOfCo co fv_cand in_scope acc -tyCoFVsOfProv (ProofIrrelProv co) fv_cand in_scope acc = tyCoFVsOfCo co fv_cand in_scope acc -tyCoFVsOfProv (PluginProv _) fv_cand in_scope acc = emptyFV fv_cand in_scope acc -tyCoFVsOfProv (CorePrepProv _) fv_cand in_scope acc = emptyFV fv_cand in_scope acc +tyCoFVsOfProv :: (co -> FV) -> UnivCoProvenance co -> FV +tyCoFVsOfProv tyCoFVs_of_co (PhantomProv co) fv_cand in_scope acc = tyCoFVs_of_co co fv_cand in_scope acc +tyCoFVsOfProv tyCoFVs_of_co (ProofIrrelProv co) fv_cand in_scope acc = tyCoFVs_of_co co fv_cand in_scope acc +tyCoFVsOfProv _ (PluginProv _) fv_cand in_scope acc = emptyFV fv_cand in_scope acc +tyCoFVsOfProv _ (CorePrepProv _) fv_cand in_scope acc = emptyFV fv_cand in_scope acc tyCoFVsOfCos :: [Coercion] -> FV tyCoFVsOfCos [] fv_cand in_scope acc = emptyFV fv_cand in_scope acc tyCoFVsOfCos (co:cos) fv_cand in_scope acc = (tyCoFVsOfCo co `unionFV` tyCoFVsOfCos cos) fv_cand in_scope acc +tyCoFVsOfDCos :: [DCoercion] -> FV +tyCoFVsOfDCos [] fv_cand in_scope acc = emptyFV fv_cand in_scope acc +tyCoFVsOfDCos (co:cos) fv_cand in_scope acc = (tyCoFVsOfDCo co `unionFV` tyCoFVsOfDCos cos) fv_cand in_scope acc + +tyCoFVsOfDCo :: DCoercion -> FV +tyCoFVsOfDCo ReflDCo fv_cand in_scope acc = emptyFV fv_cand in_scope acc +tyCoFVsOfDCo (GReflRightDCo co) fv_cand in_scope acc = tyCoFVsOfCo co fv_cand in_scope acc +tyCoFVsOfDCo (GReflLeftDCo co) fv_cand in_scope acc = tyCoFVsOfCo co fv_cand in_scope acc +tyCoFVsOfDCo (TyConAppDCo dcos) fv_cand in_scope acc = tyCoFVsOfDCos dcos fv_cand in_scope acc +tyCoFVsOfDCo (AppDCo dco1 dco2) fv_cand in_scope acc = (tyCoFVsOfDCo dco1 `unionFV` tyCoFVsOfDCo dco2) fv_cand in_scope acc +tyCoFVsOfDCo (ForAllDCo tv kind_dco co) fv_cand in_scope acc + = (tyCoFVsVarBndr tv (tyCoFVsOfDCo co) `unionFV` tyCoFVsOfDCo kind_dco) fv_cand in_scope acc +tyCoFVsOfDCo (CoVarDCo v) fv_cand in_scope acc = tyCoFVsOfCoVar v fv_cand in_scope acc +tyCoFVsOfDCo AxiomInstDCo{} fv_cand in_scope acc = emptyFV fv_cand in_scope acc +tyCoFVsOfDCo StepsDCo{} fv_cand in_scope acc = emptyFV fv_cand in_scope acc +tyCoFVsOfDCo (TransDCo dco1 dco2) fv_cand in_scope acc = (tyCoFVsOfDCo dco1 `unionFV` tyCoFVsOfDCo dco2) fv_cand in_scope acc +tyCoFVsOfDCo (DehydrateCo co) fv_cand in_scope acc = tyCoFVsOfCo co fv_cand in_scope acc +tyCoFVsOfDCo (UnivDCo p rhs) fv_cand in_scope acc = (tyCoFVsOfProv tyCoFVsOfDCo p `unionFV` tyCoFVsOfType rhs) fv_cand in_scope acc +tyCoFVsOfDCo (SubDCo dco) fv_cand in_scope acc = tyCoFVsOfDCo dco fv_cand in_scope acc ----- Whether a covar is /Almost Devoid/ in a type or coercion ---- @@ -677,6 +720,10 @@ almostDevoidCoVarOfCo :: CoVar -> Coercion -> Bool almostDevoidCoVarOfCo cv co = almost_devoid_co_var_of_co co cv +almostDevoidCoVarOfDCo :: CoVar -> DCoercion -> Bool +almostDevoidCoVarOfDCo cv dco = + almost_devoid_co_var_of_dco dco cv + almost_devoid_co_var_of_co :: Coercion -> CoVar -> Bool almost_devoid_co_var_of_co (Refl {}) _ = True -- covar is allowed in Refl and almost_devoid_co_var_of_co (GRefl {}) _ = True -- GRefl, so we don't look into @@ -697,8 +744,11 @@ almost_devoid_co_var_of_co (CoVarCo v) cv = v /= cv almost_devoid_co_var_of_co (HoleCo h) cv = (coHoleCoVar h) /= cv almost_devoid_co_var_of_co (AxiomInstCo _ _ cos) cv = almost_devoid_co_var_of_cos cos cv +almost_devoid_co_var_of_co (HydrateDCo _ t1 dco _) cv + = almost_devoid_co_var_of_type t1 cv + && almost_devoid_co_var_of_dco dco cv almost_devoid_co_var_of_co (UnivCo p _ t1 t2) cv - = almost_devoid_co_var_of_prov p cv + = almost_devoid_co_var_of_prov almost_devoid_co_var_of_co p cv && almost_devoid_co_var_of_type t1 cv && almost_devoid_co_var_of_type t2 cv almost_devoid_co_var_of_co (SymCo co) cv @@ -726,13 +776,46 @@ almost_devoid_co_var_of_cos (co:cos) cv = almost_devoid_co_var_of_co co cv && almost_devoid_co_var_of_cos cos cv -almost_devoid_co_var_of_prov :: UnivCoProvenance -> CoVar -> Bool -almost_devoid_co_var_of_prov (PhantomProv co) cv - = almost_devoid_co_var_of_co co cv -almost_devoid_co_var_of_prov (ProofIrrelProv co) cv +almost_devoid_co_var_of_dcos :: [DCoercion] -> CoVar -> Bool +almost_devoid_co_var_of_dcos [] _ = True +almost_devoid_co_var_of_dcos (co:cos) cv + = almost_devoid_co_var_of_dco co cv + && almost_devoid_co_var_of_dcos cos cv + +almost_devoid_co_var_of_dco :: DCoercion -> CoVar -> Bool +almost_devoid_co_var_of_dco ReflDCo _ = True +almost_devoid_co_var_of_dco GReflRightDCo{} _ = True -- GRefl, so we don't look into + -- the coercions +almost_devoid_co_var_of_dco GReflLeftDCo{} _ = True +almost_devoid_co_var_of_dco (TyConAppDCo cos) cv + = almost_devoid_co_var_of_dcos cos cv +almost_devoid_co_var_of_dco (AppDCo co arg) cv + = almost_devoid_co_var_of_dco co cv + && almost_devoid_co_var_of_dco arg cv +almost_devoid_co_var_of_dco (ForAllDCo v kind_co co) cv + = almost_devoid_co_var_of_dco kind_co cv + && (v == cv || almost_devoid_co_var_of_dco co cv) +almost_devoid_co_var_of_dco (CoVarDCo v) cv = v /= cv +almost_devoid_co_var_of_dco AxiomInstDCo{} _ = True +almost_devoid_co_var_of_dco StepsDCo{} _ = True +almost_devoid_co_var_of_dco (TransDCo co1 co2) cv + = almost_devoid_co_var_of_dco co1 cv + && almost_devoid_co_var_of_dco co2 cv +almost_devoid_co_var_of_dco (DehydrateCo co) cv = almost_devoid_co_var_of_co co cv -almost_devoid_co_var_of_prov (PluginProv _) _ = True -almost_devoid_co_var_of_prov (CorePrepProv _) _ = True +almost_devoid_co_var_of_dco (UnivDCo prov rhs) cv + = almost_devoid_co_var_of_prov almost_devoid_co_var_of_dco prov cv + && almost_devoid_co_var_of_type rhs cv +almost_devoid_co_var_of_dco (SubDCo dco) cv + = almost_devoid_co_var_of_dco dco cv + +almost_devoid_co_var_of_prov :: (co -> CoVar -> Bool) -> UnivCoProvenance co -> CoVar -> Bool +almost_devoid_co_var_of_prov almost_devoid_co (PhantomProv co) cv + = almost_devoid_co co cv +almost_devoid_co_var_of_prov almost_devoid_co (ProofIrrelProv co) cv + = almost_devoid_co co cv +almost_devoid_co_var_of_prov _ (PluginProv _) _ = True +almost_devoid_co_var_of_prov _ (CorePrepProv _) _ = True almost_devoid_co_var_of_type :: Type -> CoVar -> Bool almost_devoid_co_var_of_type (TyVarTy _) _ = True @@ -953,27 +1036,35 @@ afvFolder check_fv = TyCoFolder { tcf_view = noView anyFreeVarsOfType :: (TyCoVar -> Bool) -> Type -> Bool anyFreeVarsOfType check_fv ty = DM.getAny (f ty) - where (f, _, _, _) = foldTyCo (afvFolder check_fv) emptyVarSet + where (f, _, _, _, _, _) = foldTyCo (afvFolder check_fv) emptyVarSet anyFreeVarsOfTypes :: (TyCoVar -> Bool) -> [Type] -> Bool anyFreeVarsOfTypes check_fv tys = DM.getAny (f tys) - where (_, f, _, _) = foldTyCo (afvFolder check_fv) emptyVarSet + where (_, f, _, _, _, _) = foldTyCo (afvFolder check_fv) emptyVarSet anyFreeVarsOfCo :: (TyCoVar -> Bool) -> Coercion -> Bool anyFreeVarsOfCo check_fv co = DM.getAny (f co) - where (_, _, f, _) = foldTyCo (afvFolder check_fv) emptyVarSet + where (_, _, f, _, _, _) = foldTyCo (afvFolder check_fv) emptyVarSet + +anyFreeVarsOfDCo :: (TyCoVar -> Bool) -> DCoercion -> Bool +anyFreeVarsOfDCo check_fv co = DM.getAny (f co) + where (_, _, _, _, f, _) = foldTyCo (afvFolder check_fv) emptyVarSet noFreeVarsOfType :: Type -> Bool noFreeVarsOfType ty = not $ DM.getAny (f ty) - where (f, _, _, _) = foldTyCo (afvFolder (const True)) emptyVarSet + where (f, _, _, _, _, _) = foldTyCo (afvFolder (const True)) emptyVarSet noFreeVarsOfTypes :: [Type] -> Bool noFreeVarsOfTypes tys = not $ DM.getAny (f tys) - where (_, f, _, _) = foldTyCo (afvFolder (const True)) emptyVarSet + where (_, f, _, _, _, _) = foldTyCo (afvFolder (const True)) emptyVarSet noFreeVarsOfCo :: Coercion -> Bool noFreeVarsOfCo co = not $ DM.getAny (f co) - where (_, _, f, _) = foldTyCo (afvFolder (const True)) emptyVarSet + where (_, _, f, _, _, _) = foldTyCo (afvFolder (const True)) emptyVarSet + +noFreeVarsOfDCo :: DCoercion -> Bool +noFreeVarsOfDCo dco = not $ DM.getAny (f dco) + where (_, _, _, _, f, _) = foldTyCo (afvFolder (const True)) emptyVarSet {- ********************************************************************* @@ -1113,7 +1204,8 @@ tyConsOfType ty go_co (FunCo { fco_mult = m, fco_arg = a, fco_res = r }) = go_co m `unionUniqSets` go_co a `unionUniqSets` go_co r go_co (AxiomInstCo ax _ args) = go_ax ax `unionUniqSets` go_cos args - go_co (UnivCo p _ t1 t2) = go_prov p `unionUniqSets` go t1 `unionUniqSets` go t2 + go_co (UnivCo p _ t1 t2) = go_prov go_co p `unionUniqSets` go t1 `unionUniqSets` go t2 + go_co (HydrateDCo _ t1 dco _) = go t1 `unionUniqSets` go_dco dco go_co (CoVarCo {}) = emptyUniqSet go_co (HoleCo {}) = emptyUniqSet go_co (SymCo co) = go_co co @@ -1128,14 +1220,29 @@ tyConsOfType ty go_mco MRefl = emptyUniqSet go_mco (MCo co) = go_co co - go_prov (PhantomProv co) = go_co co - go_prov (ProofIrrelProv co) = go_co co - go_prov (PluginProv _) = emptyUniqSet - go_prov (CorePrepProv _) = emptyUniqSet + go_dco ReflDCo = emptyUniqSet + go_dco (GReflRightDCo co) = go_co co + go_dco (GReflLeftDCo co) = go_co co + go_dco (TyConAppDCo args) = go_dcos args + go_dco (AppDCo co arg) = go_dco co `unionUniqSets` go_dco arg + go_dco (ForAllDCo _ kind_dco co) = go_dco kind_dco `unionUniqSets` go_dco co + go_dco (AxiomInstDCo ax) = go_ax ax + go_dco StepsDCo{} = emptyUniqSet + go_dco (CoVarDCo {}) = emptyUniqSet + go_dco (TransDCo co1 co2) = go_dco co1 `unionUniqSets` go_dco co2 + go_dco (DehydrateCo co) = go_co co + go_dco (UnivDCo p rhs) = go_prov go_dco p `unionUniqSets` go rhs + go_dco (SubDCo dco) = go_dco dco + + go_prov get_tycons (PhantomProv co) = get_tycons co + go_prov get_tycons (ProofIrrelProv co) = get_tycons co + go_prov _ (PluginProv _) = emptyUniqSet + go_prov _ (CorePrepProv _) = emptyUniqSet -- this last case can happen from the tyConsOfType used from -- checkTauTvUpdate go_cos cos = foldr (unionUniqSets . go_co) emptyUniqSet cos + go_dcos dcos = foldr (unionUniqSets . go_dco) emptyUniqSet dcos go_tc tc = unitUniqSet tc go_ax ax = go_tc $ coAxiomTyCon ax @@ -1318,7 +1425,11 @@ occCheckExpand vs_to_avoid ty go_co cxt (AxiomInstCo ax ind args) = do { args' <- mapM (go_co cxt) args ; return (AxiomInstCo ax ind args') } - go_co cxt (UnivCo p r ty1 ty2) = do { p' <- go_prov cxt p + go_co ctx (HydrateDCo r ty1 dco ty2)= do { ty1' <- go ctx ty1 + ; dco' <- go_dco ctx dco + ; ty2' <- go ctx ty2 + ; return (HydrateDCo r ty1' dco' ty2') } + go_co cxt (UnivCo p r ty1 ty2) = do { p' <- go_prov (go_co cxt) p ; ty1' <- go cxt ty1 ; ty2' <- go cxt ty2 ; return (UnivCo p' r ty1' ty2') } @@ -1342,8 +1453,38 @@ occCheckExpand vs_to_avoid ty ; return (AxiomRuleCo ax cs') } ------------------ - go_prov cxt (PhantomProv co) = PhantomProv <$> go_co cxt co - go_prov cxt (ProofIrrelProv co) = ProofIrrelProv <$> go_co cxt co - go_prov _ p@(PluginProv _) = return p - go_prov _ p@(CorePrepProv _) = return p + go_dco _ ReflDCo = pure ReflDCo + go_dco cxt (GReflRightDCo co) = GReflRightDCo <$> go_co cxt co + go_dco cxt (GReflLeftDCo co) = GReflLeftDCo <$> go_co cxt co + go_dco cxt (TyConAppDCo args) = do { args' <- mapM (go_dco cxt) args + ; return (TyConAppDCo args') } + go_dco cxt (AppDCo co arg) = do { co' <- go_dco cxt co + ; arg' <- go_dco cxt arg + ; return (AppDCo co' arg') } + go_dco cxt@(as, env) (ForAllDCo tv kind_dco body_co) + = do { kind_dco' <- go_dco cxt kind_dco + ; tv_kind' <- go cxt (varType tv) + ; let tv' = setVarType tv $ tv_kind' + env' = extendVarEnv env tv tv' + as' = as `delVarSet` tv + ; body' <- go_dco (as', env') body_co + ; return (ForAllDCo tv' kind_dco' body') } + go_dco (as,env) co@(CoVarDCo c) + | Just c' <- lookupVarEnv env c = return (CoVarDCo c') + | bad_var_occ as c = Nothing + | otherwise = return co + + go_dco _ dco@AxiomInstDCo{} = pure dco + go_dco _ dco@StepsDCo{} = pure dco + go_dco cxt (TransDCo co1 co2) = do { co1' <- go_dco cxt co1 + ; co2' <- go_dco cxt co2 + ; return (TransDCo co1' co2') } + go_dco ctx (UnivDCo prov rhs) = UnivDCo <$> go_prov (go_dco ctx) prov <*> go ctx rhs + go_dco ctx (SubDCo dco) = SubDCo <$> go_dco ctx dco + go_dco cxt (DehydrateCo co) = DehydrateCo <$> go_co cxt co + ------------------ + go_prov prov_go (PhantomProv co) = PhantomProv <$> prov_go co + go_prov prov_go (ProofIrrelProv co) = ProofIrrelProv <$> prov_go co + go_prov _ p@(PluginProv _) = return p + go_prov _ p@(CorePrepProv _) = return p diff --git a/compiler/GHC/Core/TyCo/Ppr.hs b/compiler/GHC/Core/TyCo/Ppr.hs index ce97294a94..2c0838f586 100644 --- a/compiler/GHC/Core/TyCo/Ppr.hs +++ b/compiler/GHC/Core/TyCo/Ppr.hs @@ -20,6 +20,7 @@ module GHC.Core.TyCo.Ppr -- * Pretty-printing coercions pprCo, pprParendCo, + pprDCo, debugPprType, ) where @@ -28,7 +29,8 @@ import GHC.Prelude import {-# SOURCE #-} GHC.CoreToIface ( toIfaceTypeX, toIfaceTyLit, toIfaceForAllBndrs - , toIfaceTyCon, toIfaceTcArgs, toIfaceCoercionX ) + , toIfaceTyCon, toIfaceTcArgs + , toIfaceCoercionX, toIfaceDCoercionX ) import {-# SOURCE #-} GHC.Core.DataCon ( dataConFullSig , dataConUserTyVarBinders, DataCon ) @@ -126,6 +128,9 @@ pprCo, pprParendCo :: Coercion -> SDoc pprCo co = getPprStyle $ \ sty -> pprIfaceCoercion (tidyToIfaceCoSty co sty) pprParendCo co = getPprStyle $ \ sty -> pprParendIfaceCoercion (tidyToIfaceCoSty co sty) +pprDCo :: DCoercion -> SDoc +pprDCo co = getPprStyle $ \ sty -> pprIfaceDCoercion (tidyToIfaceDCoSty co sty) + tidyToIfaceCoSty :: Coercion -> PprStyle -> IfaceCoercion tidyToIfaceCoSty co sty | userStyle sty = tidyToIfaceCo co @@ -143,6 +148,27 @@ tidyToIfaceCo co = toIfaceCoercionX (mkVarSet free_tcvs) (tidyCo env co) where env = tidyFreeTyCoVars emptyTidyEnv free_tcvs free_tcvs = scopedSort $ tyCoVarsOfCoList co + +tidyToIfaceDCoSty :: DCoercion -> PprStyle -> IfaceDCoercion +tidyToIfaceDCoSty co sty + | userStyle sty = tidyToIfaceDCo co + | otherwise = toIfaceDCoercionX (tyCoVarsOfDCo co) co + -- in latter case, don't tidy, as we'll be printing uniques. + +tidyToIfaceDCo :: DCoercion -> IfaceDCoercion +-- It's vital to tidy before converting to an IfaceType +-- or nested binders will become indistinguishable! +-- +-- Also for the free type variables, tell toIfaceDCoercionX to +-- leave them as IfaceFreeCoVarDCo. This is super-important +-- for debug printing. +tidyToIfaceDCo co = toIfaceDCoercionX (mkVarSet free_tcvs) (tidyDCo env co) + where + env = tidyFreeTyCoVars emptyTidyEnv free_tcvs + free_tcvs = scopedSort $ tyCoVarsOfDCoList co + + + ------------ pprClassPred :: Class -> [Type] -> SDoc pprClassPred clas tys = pprTypeApp (classTyCon clas) tys diff --git a/compiler/GHC/Core/TyCo/Ppr.hs-boot b/compiler/GHC/Core/TyCo/Ppr.hs-boot index c031db2f9a..0c32fbfbc8 100644 --- a/compiler/GHC/Core/TyCo/Ppr.hs-boot +++ b/compiler/GHC/Core/TyCo/Ppr.hs-boot @@ -1,12 +1,14 @@ module GHC.Core.TyCo.Ppr where import {-# SOURCE #-} GHC.Types.Var ( TyVar ) -import {-# SOURCE #-} GHC.Core.TyCo.Rep (Type, Kind, Coercion, TyLit) +import {-# SOURCE #-} GHC.Core.TyCo.Rep (Type, Kind, Coercion, DCoercion, TyLit) import GHC.Utils.Outputable ( SDoc ) pprType :: Type -> SDoc debugPprType :: Type -> SDoc pprKind :: Kind -> SDoc pprCo :: Coercion -> SDoc +pprParendCo :: Coercion -> SDoc +pprDCo :: DCoercion -> SDoc pprTyLit :: TyLit -> SDoc pprTyVar :: TyVar -> SDoc diff --git a/compiler/GHC/Core/TyCo/Rep.hs b/compiler/GHC/Core/TyCo/Rep.hs index 245a1c507b..11e4b6db79 100644 --- a/compiler/GHC/Core/TyCo/Rep.hs +++ b/compiler/GHC/Core/TyCo/Rep.hs @@ -1,5 +1,6 @@ {-# LANGUAGE DeriveDataTypeable #-} +{-# LANGUAGE GADTs #-} {-# OPTIONS_HADDOCK not-home #-} @@ -42,6 +43,9 @@ module GHC.Core.TyCo.Rep ( CoercionN, CoercionR, CoercionP, KindCoercion, MCoercion(..), MCoercionR, MCoercionN, + DCoercion(..), DCoercionN, KindDCoercion, + CoOrDCo(..), + -- * Functions over types mkNakedTyConTy, mkTyVarTy, mkTyVarTys, mkTyCoVarTy, mkTyCoVarTys, @@ -61,7 +65,7 @@ module GHC.Core.TyCo.Rep ( TyCoFolder(..), foldTyCo, noView, -- * Sizes - typeSize, typesSize, coercionSize, provSize, + typeSize, typesSize, coercionSize, dcoercionSize, provSize, -- * Multiplicities Scaled(..), scaledMult, scaledThing, mapScaledType, Mult @@ -69,7 +73,7 @@ module GHC.Core.TyCo.Rep ( import GHC.Prelude -import {-# SOURCE #-} GHC.Core.TyCo.Ppr ( pprType, pprCo, pprTyLit ) +import {-# SOURCE #-} GHC.Core.TyCo.Ppr ( pprType, pprCo, pprParendCo, pprDCo, pprTyLit ) import {-# SOURCE #-} GHC.Builtin.Types import {-# SOURCE #-} GHC.Core.Type( chooseFunTyFlag, typeKind, typeTypeOrConstraint ) @@ -882,9 +886,23 @@ data Coercion -- The number coercions should match exactly the expectations -- of the CoAxiomRule (i.e., the rule is fully saturated). - | UnivCo UnivCoProvenance Role Type Type + | UnivCo (UnivCoProvenance Coercion) Role Type Type -- :: _ -> "e" -> _ -> _ -> e + -- | Embed a directed coercion into a coercion, by specifying + -- the LHS type and role of the directed coercion. + -- + -- The RHS type is also cached, as we often already know the RHS, + -- which avoids us computing it anew using 'followDCo'. + -- + -- See Note [Directed coercions] + | HydrateDCo + Role -- ^ `r` + Type -- ^ `lhs`: LHS type of the directed coercion + DCoercion + Type -- ^ Cached RHS type of the directed coercion. + -- Can be computed from `r` and `lhs` using 'followDCo'. + | SymCo Coercion -- :: e -> e | TransCo Coercion Coercion -- :: e -> e -> e @@ -980,7 +998,7 @@ type MCoercionN = MCoercion instance Outputable MCoercion where ppr MRefl = text "MRefl" - ppr (MCo co) = text "MCo" <+> ppr co + ppr (MCo co) = text "MCo" <+> pprParendCo co {- Note [Refl invariant] ~~~~~~~~~~~~~~~~~~~~~~~~ @@ -1402,6 +1420,152 @@ A more nuanced treatment might be able to relax this condition somewhat, by checking if t1 and/or t2 use their bound variables in nominal ways. If not, having w be representational is OK. +Note [Directed coercions] +~~~~~~~~~~~~~~~~~~~~~~~~~ +A directed coercion is a compact representation of a coercion, used to avoid +storing a large amount of extra types in coercions in the rewriter. + +Recall that a coercion always contains enough information for us to be +able to retrieve its role and its left and right hand side types. + +Examples: + + Refl ty + coercionRole: Nominal + coercionLKind: ty + coercionRKind: ty + + TyConAppCo r tc cos + coercionRole: r + coercionLKind: mkTyConApp tc (map coercionLKind cos) + coercionRKind: mkTyConApp tc (map coercionRKind cos) + +In practice, this means that when rewriting type family applications, +coercions end up storing large amounts of extra information: + + type family a + b where + Zero + b = b + Succ a + b = Succ (a + b) + +Reducing 5 + 0 gives rise to a coercion of the form + + +[1] <Succ (Succ (Succ (Succ Zero)))> <Zero> + ; (Succ (+[1] <Succ (Succ (Succ Zero))> <Zero> + ; (Succ (+[1] <Succ (Succ Zero)> <Zero> + ; (Succ (+[1] <Succ Zero> <Zero> + ; (Succ (+[1] <Zero> <Zero> + ; (Succ (+[0] <Zero>)))))))))) + +Compare this to the corresponding directed coercion, where we don't store +so many types: + + Steps 1 + ; (TyConApp (Steps 1 + ; (TyConApp (Steps 1 + ; (TyConApp (Steps 1 + ; (TyConApp (Steps 1 + ; (TyConApp (Steps 1)))))))))) + +To achieve this, we sacrifice being able to query what the LHS type of a +directed coercion is. Instead, this information must be provided as an +input. More specifically, when we have: + + dco :: lhs ~r rhs + +We understand that the role `r` and the LHS type `lhs` are **inputs**, +from which we are able to compute the RHS type `rhs`. +(This is what the function followDCo does.) +This allows us to get away with storing less information in a directed +coercion than in an undirected coercion, while still retaining the ability +to run Core Lint on our program. +-} + +type DCoercionN = DCoercion +type KindDCoercion = DCoercionN + +-- | A directed coercion is a more compact representation of a coercion, +-- which is used in the rewriter to avoid producing quadratically large +-- coercions. +-- +-- For a directed coercion @dco :: lhs ~r rhs@, we think of the role @r@ +-- and the LHS type @lhs@ as /inputs/. Only once this context is given +-- are we able to compute the RHS type @rhs@. +-- +-- See Note [Directed coercions]. +data DCoercion + + -- | 'ReflCo' for 'DCoercion'. + = ReflDCo + + -- | 'GReflCo' for 'DCoercion'. + | GReflRightDCo CoercionN + + -- | @GReflLeftDCo mco@ corresponds to @SymCo (GReflCo mco)@. + -- + -- We need this alongside @GReflRightDCo@ because we don't have + -- symmetry for directed coercions. + | GReflLeftDCo CoercionN + -- SLD TODO: remove GReflLeftDCo? We could use @GReflRightDCo (mkSymMCo mco)@. + + -- | 'TyConAppCo' for 'DCoercion'. + -- + -- NB: we use 'TyConAppDCo' for functions too, + -- unlike coercions which have 'TyConAppCo' and 'FunCo'. + | TyConAppDCo [DCoercion] + + -- | 'AppCo' for 'DCoercion'. + | AppDCo DCoercion DCoercionN + + -- | 'ForAllCo' for 'DCoercion'. + | ForAllDCo TyCoVar KindDCoercion DCoercion + + -- | 'CoVarCo' for 'DCoercion'. + | CoVarDCo CoVar + + -- | 'AxiomInstCo' for 'DCoercion', but specialised + -- to open type family coercion axioms. + -- + -- For newtypes and closed type families, we use the more + -- compact 'StepsDCo'. + | AxiomInstDCo (CoAxiom Branched) + + -- | @StepsDCo n@ means: \"take n successive reduction steps\", + -- where a reduction step could be using a closed type family equation + -- or using a newtype axiom. + | StepsDCo !Int + + -- | 'UnivCo' for 'DCoercion'. We only need to store the RHS type, + -- as the LHS type and role will be provided by context. + | UnivDCo + (UnivCoProvenance DCoercion) + Type -- ^ RHS type + + -- | 'TransCo' for 'DCoercion'. + | TransDCo DCoercion DCoercion + + -- | 'SubCo' for 'DCoercion'. + | SubDCo DCoercion + + -- | Embed a coercion inside a directed coercion, e.g. \"forget\" + -- that we can compute its LHS type and role without context. + | DehydrateCo Coercion + + deriving Data.Data + +instance Outputable DCoercion where + ppr = pprDCo + +-- | A convenient GADT for handling 'Coercion' and 'DCoercion' +-- at the same time. +data CoOrDCo co_or_dco where + Co :: CoOrDCo Coercion + DCo :: CoOrDCo DCoercion + +instance Outputable (CoOrDCo co_or_dco) where + ppr Co = text "Co" + ppr DCo = text "DCo" + +{- %************************************************************************ %* * @@ -1425,25 +1589,25 @@ role and kind, which is done in the UnivCo constructor. -- It is reasonable to consider each constructor of 'UnivCoProvenance' -- as a totally independent coercion form; their only commonality is -- that they don't tell you what types they coercion between. (That info --- is in the 'UnivCo' constructor of 'Coercion'. -data UnivCoProvenance - = PhantomProv KindCoercion -- ^ See Note [Phantom coercions]. Only in Phantom - -- roled coercions +-- is in the 'UnivCo' constructor of 'Coercion'). +data UnivCoProvenance kco + = PhantomProv kco -- ^ See Note [Phantom coercions]. Only in Phantom + -- roled coercions - | ProofIrrelProv KindCoercion -- ^ From the fact that any two coercions are - -- considered equivalent. See Note [ProofIrrelProv]. - -- Can be used in Nominal or Representational coercions + | ProofIrrelProv kco -- ^ From the fact that any two coercions are + -- considered equivalent. See Note [ProofIrrelProv]. + -- Can be used in Nominal or Representational coercions | PluginProv String -- ^ From a plugin, which asserts that this coercion -- is sound. The string is for the use of the plugin. - | CorePrepProv -- See Note [Unsafe coercions] in GHC.Core.CoreToStg.Prep + | CorePrepProv -- ^ See Note [Unsafe coercions] in GHC.Core.CoreToStg.Prep Bool -- True <=> the UnivCo must be homogeneously kinded -- False <=> allow hetero-kinded, e.g. Int ~ Int# deriving Data.Data -instance Outputable UnivCoProvenance where +instance Outputable (UnivCoProvenance kco) where ppr (PhantomProv _) = text "(phantom)" ppr (ProofIrrelProv _) = text "(proof irrel.)" ppr (PluginProv str) = parens (text "plugin" <+> brackets (text str)) @@ -1708,14 +1872,17 @@ data TyCoFolder env a } {-# INLINE foldTyCo #-} -- See Note [Specialising foldType] -foldTyCo :: Monoid a => TyCoFolder env a -> env - -> (Type -> a, [Type] -> a, Coercion -> a, [Coercion] -> a) +foldTyCo :: forall env a. Monoid a => TyCoFolder env a -> env + -> ( Type -> a, [Type] -> a + , Coercion -> a, [Coercion] -> a + , DCoercion -> a, [DCoercion] -> a + ) foldTyCo (TyCoFolder { tcf_view = view , tcf_tyvar = tyvar , tcf_tycobinder = tycobinder , tcf_covar = covar , tcf_hole = cohole }) env - = (go_ty env, go_tys env, go_co env, go_cos env) + = (go_ty env, go_tys env, go_co env, go_cos env, go_dco env, go_dcos env) where go_ty env ty | Just ty' <- view ty = go_ty env ty' go_ty env (TyVarTy tv) = tyvar env tv @@ -1738,38 +1905,61 @@ foldTyCo (TyCoFolder { tcf_view = view go_cos _ [] = mempty go_cos env (c:cs) = go_co env c `mappend` go_cos env cs - go_co env (Refl ty) = go_ty env ty - go_co env (GRefl _ ty MRefl) = go_ty env ty - go_co env (GRefl _ ty (MCo co)) = go_ty env ty `mappend` go_co env co - go_co env (TyConAppCo _ _ args) = go_cos env args - go_co env (AppCo c1 c2) = go_co env c1 `mappend` go_co env c2 - go_co env (CoVarCo cv) = covar env cv - go_co env (AxiomInstCo _ _ args) = go_cos env args - go_co env (HoleCo hole) = cohole env hole - go_co env (UnivCo p _ t1 t2) = go_prov env p `mappend` go_ty env t1 - `mappend` go_ty env t2 - go_co env (SymCo co) = go_co env co - go_co env (TransCo c1 c2) = go_co env c1 `mappend` go_co env c2 - go_co env (AxiomRuleCo _ cos) = go_cos env cos - go_co env (SelCo _ co) = go_co env co - go_co env (LRCo _ co) = go_co env co - go_co env (InstCo co arg) = go_co env co `mappend` go_co env arg - go_co env (KindCo co) = go_co env co - go_co env (SubCo co) = go_co env co - - go_co env (FunCo { fco_mult = cw, fco_arg = c1, fco_res = c2 }) - = go_co env cw `mappend` go_co env c1 `mappend` go_co env c2 - - go_co env (ForAllCo tv kind_co co) - = go_co env kind_co `mappend` go_ty env (varType tv) - `mappend` go_co env' co + go_co env (Refl ty) = go_ty env ty + go_co env (GRefl _ ty MRefl) = go_ty env ty + go_co env (GRefl _ ty (MCo co)) = go_ty env ty `mappend` go_co env co + go_co env (TyConAppCo _ _ args) = go_cos env args + go_co env (AppCo c1 c2) = go_co env c1 `mappend` go_co env c2 + go_co env (FunCo _ _ _ cw c1 c2) = go_co env cw `mappend` + go_co env c1 `mappend` + go_co env c2 + go_co env (CoVarCo cv) = covar env cv + go_co env (AxiomInstCo _ _ args) = go_cos env args + go_co env (HoleCo hole) = cohole env hole + go_co env (HydrateDCo _ t1 dco _t2) = go_ty env t1 `mappend` go_dco env dco + go_co env (UnivCo p _ t1 t2) = go_prov go_co env p + `mappend` go_ty env t1 + `mappend` go_ty env t2 + go_co env (SymCo co) = go_co env co + go_co env (TransCo co1 co2) = go_co env co1 `mappend` go_co env co2 + go_co env (AxiomRuleCo _ cos) = go_cos env cos + go_co env (SelCo _ co) = go_co env co + go_co env (LRCo _ co) = go_co env co + go_co env (InstCo co arg) = go_co env co `mappend` go_co env arg + go_co env (KindCo co) = go_co env co + go_co env (SubCo co) = go_co env co + go_co env (ForAllCo tv kind_co co) = go_co env kind_co + `mappend` go_ty env (varType tv) + `mappend` go_co env' co + where + !env' = tycobinder env tv Inferred + + go_dcos _ [] = mempty + go_dcos env (c:cs) = go_dco env c `mappend` go_dcos env cs + + go_dco _ ReflDCo = mempty + go_dco env (GReflRightDCo co) = go_co env co + go_dco env (GReflLeftDCo co) = go_co env co + go_dco env (TyConAppDCo args) = go_dcos env args + go_dco env (AppDCo c1 c2) = go_dco env c1 `mappend` go_dco env c2 + go_dco env (CoVarDCo cv) = covar env cv + go_dco _ AxiomInstDCo{} = mempty + go_dco _ StepsDCo{} = mempty + go_dco env (TransDCo co1 co2) = go_dco env co1 `mappend` go_dco env co2 + go_dco env (SubDCo dco) = go_dco env dco + go_dco env (DehydrateCo co) = go_co env co + go_dco env (ForAllDCo tv kind_dco co) = go_dco env kind_dco + `mappend` go_ty env (varType tv) + `mappend` go_dco env' co where - env' = tycobinder env tv Inferred + !env' = tycobinder env tv Inferred + go_dco env (UnivDCo prov t2) = go_prov go_dco env prov `mappend` go_ty env t2 - go_prov env (PhantomProv co) = go_co env co - go_prov env (ProofIrrelProv co) = go_co env co - go_prov _ (PluginProv _) = mempty - go_prov _ (CorePrepProv _) = mempty + go_prov :: (env ->co -> a) -> env -> UnivCoProvenance co -> a + go_prov do_fold env (PhantomProv co) = do_fold env co + go_prov do_fold env (ProofIrrelProv co) = do_fold env co + go_prov _ _ (PluginProv _) = mempty + go_prov _ _ (CorePrepProv _) = mempty -- | A view function that looks through nothing. noView :: Type -> Maybe Type @@ -1821,7 +2011,8 @@ coercionSize (FunCo _ _ _ w c1 c2) = 1 + coercionSize c1 + coercionSize c2 coercionSize (CoVarCo _) = 1 coercionSize (HoleCo _) = 1 coercionSize (AxiomInstCo _ _ args) = 1 + sum (map coercionSize args) -coercionSize (UnivCo p _ t1 t2) = 1 + provSize p + typeSize t1 + typeSize t2 +coercionSize (HydrateDCo _ t1 dco t2) = 1 + typeSize t1 + dcoercionSize dco + typeSize t2 +coercionSize (UnivCo p _ t1 t2) = 1 + provSize coercionSize p + typeSize t1 + typeSize t2 coercionSize (SymCo co) = 1 + coercionSize co coercionSize (TransCo co1 co2) = 1 + coercionSize co1 + coercionSize co2 coercionSize (SelCo _ co) = 1 + coercionSize co @@ -1831,11 +2022,26 @@ coercionSize (KindCo co) = 1 + coercionSize co coercionSize (SubCo co) = 1 + coercionSize co coercionSize (AxiomRuleCo _ cs) = 1 + sum (map coercionSize cs) -provSize :: UnivCoProvenance -> Int -provSize (PhantomProv co) = 1 + coercionSize co -provSize (ProofIrrelProv co) = 1 + coercionSize co -provSize (PluginProv _) = 1 -provSize (CorePrepProv _) = 1 +dcoercionSize :: DCoercion -> Int +dcoercionSize ReflDCo = 1 +dcoercionSize (GReflRightDCo co) = 1 + coercionSize co +dcoercionSize (GReflLeftDCo co) = 1 + coercionSize co +dcoercionSize (TyConAppDCo args) = 1 + sum (map dcoercionSize args) +dcoercionSize (AppDCo co arg) = dcoercionSize co + dcoercionSize arg +dcoercionSize (ForAllDCo _ h co) = 1 + dcoercionSize co + dcoercionSize h +dcoercionSize (CoVarDCo _) = 1 +dcoercionSize AxiomInstDCo{} = 1 +dcoercionSize StepsDCo{} = 1 +dcoercionSize (TransDCo co1 co2) = 1 + dcoercionSize co1 + dcoercionSize co2 +dcoercionSize (SubDCo co) = 1 + dcoercionSize co +dcoercionSize (DehydrateCo co) = 1 + coercionSize co +dcoercionSize (UnivDCo prov rhs) = 1 + provSize dcoercionSize prov + typeSize rhs + +provSize :: (co -> Int) -> UnivCoProvenance co -> Int +provSize co_size (PhantomProv co) = 1 + co_size co +provSize co_size (ProofIrrelProv co) = 1 + co_size co +provSize _ (PluginProv _) = 1 +provSize _ (CorePrepProv _) = 1 {- ************************************************************************ diff --git a/compiler/GHC/Core/TyCo/Rep.hs-boot b/compiler/GHC/Core/TyCo/Rep.hs-boot index 9b82d3cfa5..714b6371f1 100644 --- a/compiler/GHC/Core/TyCo/Rep.hs-boot +++ b/compiler/GHC/Core/TyCo/Rep.hs-boot @@ -9,8 +9,9 @@ import {-# SOURCE #-} GHC.Core.TyCon ( TyCon ) data Type data Coercion data FunSel +data DCoercion data CoSel -data UnivCoProvenance +data UnivCoProvenance co data TyLit data MCoercion diff --git a/compiler/GHC/Core/TyCo/Subst.hs b/compiler/GHC/Core/TyCo/Subst.hs index 4224bd127b..ee25e16f75 100644 --- a/compiler/GHC/Core/TyCo/Subst.hs +++ b/compiler/GHC/Core/TyCo/Subst.hs @@ -6,6 +6,7 @@ Type and Coercion - friends' interface {-# LANGUAGE BangPatterns #-} +{-# LANGUAGE GADTs #-} -- | Substitution into types and coercions. module GHC.Core.TyCo.Subst @@ -35,17 +36,19 @@ module GHC.Core.TyCo.Subst substTyUnchecked, substTysUnchecked, substScaledTysUnchecked, substThetaUnchecked, substTyWithUnchecked, substScaledTyUnchecked, substCoUnchecked, substCoWithUnchecked, + substDCoUnchecked, substTyWithInScope, substTys, substScaledTys, substTheta, lookupTyVar, substCo, substCos, substCoVar, substCoVars, lookupCoVar, + substDCo, cloneTyVarBndr, cloneTyVarBndrs, substVarBndr, substVarBndrs, substTyVarBndr, substTyVarBndrs, substCoVarBndr, substTyVar, substTyVars, substTyVarToTyVar, substTyCoVars, - substTyCoBndr, substForAllCoBndr, + substTyCoBndr, substForAllDCoBndr, substForAllCoBndr, substVarBndrUsing, substForAllCoBndrUsing, checkValidSubst, isValidTCvSubst, ) where @@ -61,7 +64,11 @@ import {-# SOURCE #-} GHC.Core.Coercion , mkAxiomInstCo, mkAppCo, mkGReflCo , mkInstCo, mkLRCo, mkTyConAppCo , mkCoercionType - , coercionKind, coercionLKind, coVarKindsTypesRole ) + , mkTyConAppDCo + , mkAppDCo, mkForAllDCo, mkReflDCo, mkTransDCo + , mkGReflRightDCo, mkGReflLeftDCo + , mkHydrateDCo, mkDehydrateCo, mkUnivDCo + , coercionKind, coercionLKind, coVarKindsTypesRole) import {-# SOURCE #-} GHC.Core.TyCo.Ppr ( pprTyVar ) import {-# SOURCE #-} GHC.Core.Ppr ( ) import {-# SOURCE #-} GHC.Core ( CoreExpr ) @@ -682,8 +689,8 @@ isValidTCvSubst (Subst in_scope _ tenv cenv) = -- | This checks if the substitution satisfies the invariant from -- Note [The substitution invariant]. -checkValidSubst :: HasDebugCallStack => Subst -> [Type] -> [Coercion] -> a -> a -checkValidSubst subst@(Subst in_scope _ tenv cenv) tys cos a +checkValidSubst :: HasDebugCallStack => Subst -> [Type] -> [Coercion] -> [DCoercion] -> a -> a +checkValidSubst subst@(Subst in_scope _ tenv cenv) tys cos dcos a = assertPpr (isValidTCvSubst subst) (text "in_scope" <+> ppr in_scope $$ text "tenv" <+> ppr tenv $$ @@ -691,13 +698,15 @@ checkValidSubst subst@(Subst in_scope _ tenv cenv) tys cos a text "cenv" <+> ppr cenv $$ text "cenvFVs" <+> ppr (shallowTyCoVarsOfCoVarEnv cenv) $$ text "tys" <+> ppr tys $$ - text "cos" <+> ppr cos) $ + text "cos" <+> ppr cos $$ + text "dcos" <+> ppr dcos) $ assertPpr tysCosFVsInScope (text "in_scope" <+> ppr in_scope $$ text "tenv" <+> ppr tenv $$ text "cenv" <+> ppr cenv $$ text "tys" <+> ppr tys $$ text "cos" <+> ppr cos $$ + text "dcos" <+> ppr dcos $$ text "needInScope" <+> ppr needInScope) a where @@ -705,7 +714,8 @@ checkValidSubst subst@(Subst in_scope _ tenv cenv) tys cos a -- It's OK to use nonDetKeysUFM here, because we only use this list to -- remove some elements from a set needInScope = (shallowTyCoVarsOfTypes tys `unionVarSet` - shallowTyCoVarsOfCos cos) + shallowTyCoVarsOfCos cos `unionVarSet` + shallowTyCoVarsOfDCos dcos) `delListFromUniqSet_Directly` substDomain tysCosFVsInScope = needInScope `varSetInScope` in_scope @@ -716,7 +726,7 @@ checkValidSubst subst@(Subst in_scope _ tenv cenv) tys cos a substTy :: HasDebugCallStack => Subst -> Type -> Type substTy subst ty | isEmptyTCvSubst subst = ty - | otherwise = checkValidSubst subst [ty] [] $ + | otherwise = checkValidSubst subst [ty] [] [] $ subst_ty subst ty -- | Substitute within a 'Type' disabling the sanity checks. @@ -741,12 +751,12 @@ substScaledTyUnchecked subst scaled_ty = mapScaledType (substTyUnchecked subst) substTys :: HasDebugCallStack => Subst -> [Type] -> [Type] substTys subst tys | isEmptyTCvSubst subst = tys - | otherwise = checkValidSubst subst tys [] $ map (subst_ty subst) tys + | otherwise = checkValidSubst subst tys [] [] $ map (subst_ty subst) tys substScaledTys :: HasDebugCallStack => Subst -> [Scaled Type] -> [Scaled Type] substScaledTys subst scaled_tys | isEmptyTCvSubst subst = scaled_tys - | otherwise = checkValidSubst subst (map scaledMult scaled_tys ++ map scaledThing scaled_tys) [] $ + | otherwise = checkValidSubst subst (map scaledMult scaled_tys ++ map scaledThing scaled_tys) [] [] $ map (mapScaledType (subst_ty subst)) scaled_tys -- | Substitute within several 'Type's disabling the sanity checks. @@ -846,13 +856,31 @@ lookupTyVar (Subst _ _ tenv _) tv = assert (isTyVar tv ) lookupVarEnv tenv tv +-- | Substitute within a 'DCoercion' +-- The substitution has to satisfy the invariants described in +-- Note [The substitution invariant]. +substDCo :: HasDebugCallStack => Subst -> DCoercion -> DCoercion +substDCo subst dco + | isEmptyTCvSubst subst = dco + | otherwise = checkValidSubst subst [] [] [dco] $ subst_dco subst dco + +-- | Substitute within a 'DCoercion' disabling sanity checks. +-- The problems that the sanity checks in substCo catch are described in +-- Note [The substitution invariant]. +-- The goal of #11371 is to migrate all the calls of substDCoUnchecked to +-- substDCo and remove this function. Please don't use in new code. +substDCoUnchecked :: Subst -> DCoercion -> DCoercion +substDCoUnchecked subst co + | isEmptyTCvSubst subst = co + | otherwise = subst_dco subst co + -- | Substitute within a 'Coercion' -- The substitution has to satisfy the invariants described in -- Note [The substitution invariant]. substCo :: HasDebugCallStack => Subst -> Coercion -> Coercion substCo subst co | isEmptyTCvSubst subst = co - | otherwise = checkValidSubst subst [] [co] $ subst_co subst co + | otherwise = checkValidSubst subst [] [co] [] $ subst_co subst co -- | Substitute within a 'Coercion' disabling sanity checks. -- The problems that the sanity checks in substCo catch are described in @@ -870,18 +898,23 @@ substCoUnchecked subst co substCos :: HasDebugCallStack => Subst -> [Coercion] -> [Coercion] substCos subst cos | isEmptyTCvSubst subst = cos - | otherwise = checkValidSubst subst [] cos $ map (subst_co subst) cos + | otherwise = checkValidSubst subst [] cos [] $ map (subst_co subst) cos subst_co :: Subst -> Coercion -> Coercion -subst_co subst co - = go co +subst_co = fst . subst_co_dco + +subst_dco :: Subst -> DCoercion -> DCoercion +subst_dco = snd . subst_co_dco + +subst_co_dco :: Subst -> (Coercion -> Coercion, DCoercion -> DCoercion) +subst_co_dco subst = (go, go_dco) where go_ty :: Type -> Type go_ty = subst_ty subst go_mco :: MCoercion -> MCoercion go_mco MRefl = MRefl - go_mco (MCo co) = MCo (go co) + go_mco (MCo co) = MCo $! go co go :: Coercion -> Coercion go (Refl ty) = mkNomReflCo $! (go_ty ty) @@ -896,7 +929,10 @@ subst_co subst co go (FunCo r afl afr w co1 co2) = ((mkFunCo2 r afl afr $! go w) $! go co1) $! go co2 go (CoVarCo cv) = substCoVar subst cv go (AxiomInstCo con ind cos) = mkAxiomInstCo con ind $! map go cos - go (UnivCo p r t1 t2) = (((mkUnivCo $! go_prov p) $! r) $! + go (HydrateDCo r ty dco rty) = (((mkHydrateDCo $! r) $! go_ty ty) $! go_dco dco) $! go_ty rty + -- Here we can either substitute the RHS or recompute it from the rest of the information. + + go (UnivCo p r t1 t2) = (((mkUnivCo $! go_prov go p) $! r) $! (go_ty t1)) $! (go_ty t2) go (SymCo co) = mkSymCo $! (go co) go (TransCo co1 co2) = (mkTransCo $! (go co1)) $! (go co2) @@ -909,10 +945,30 @@ subst_co subst co in cs1 `seqList` AxiomRuleCo c cs1 go (HoleCo h) = HoleCo $! go_hole h - go_prov (PhantomProv kco) = PhantomProv (go kco) - go_prov (ProofIrrelProv kco) = ProofIrrelProv (go kco) - go_prov p@(PluginProv _) = p - go_prov p@(CorePrepProv _) = p + go_dco :: DCoercion -> DCoercion + go_dco ReflDCo = mkReflDCo + go_dco (GReflRightDCo co) = mkGReflRightDCo $! go co + go_dco (GReflLeftDCo co) = mkGReflLeftDCo $! go co + go_dco (TyConAppDCo args) = let args' = map go_dco args + in args' `seqList` mkTyConAppDCo args' + go_dco (AppDCo co arg) = (mkAppDCo $! go_dco co) $! go_dco arg + go_dco (CoVarDCo cv) = mkDehydrateCo $! substCoVar subst cv + go_dco dco@AxiomInstDCo{} = dco + go_dco dco@StepsDCo{} = dco + go_dco (TransDCo co1 co2) = (mkTransDCo $! go_dco co1) $! go_dco co2 + go_dco (DehydrateCo co) = mkDehydrateCo $! go co + go_dco (ForAllDCo tv kind_dco co) + = case substForAllDCoBndrUnchecked subst tv kind_dco of + (subst', tv', kind_dco') -> + ((mkForAllDCo $! tv') $! kind_dco') $! subst_dco subst' co + go_dco (UnivDCo prov rhs) = (mkUnivDCo (go_prov go_dco prov)) $! go_ty rhs + go_dco (SubDCo dco) = SubDCo $ go_dco dco + + go_prov :: (co -> co) -> UnivCoProvenance co -> UnivCoProvenance co + go_prov do_subst (PhantomProv kco) = PhantomProv $! do_subst kco + go_prov do_subst (ProofIrrelProv kco) = ProofIrrelProv $! do_subst kco + go_prov _ p@(PluginProv _) = p + go_prov _ p@(CorePrepProv _) = p -- See Note [Substituting in a coercion hole] go_hole h@(CoercionHole { ch_co_var = cv }) @@ -921,7 +977,12 @@ subst_co subst co substForAllCoBndr :: Subst -> TyCoVar -> KindCoercion -> (Subst, TyCoVar, Coercion) substForAllCoBndr subst - = substForAllCoBndrUsing False (substCo subst) subst + = substForAllCoBndrUsing Co False (substTy subst) (substCo subst) subst + +substForAllDCoBndr :: Subst -> TyCoVar -> KindDCoercion + -> (Subst, TyCoVar, DCoercion) +substForAllDCoBndr subst + = substForAllCoBndrUsing DCo False (substTy subst) (substDCo subst) subst -- | Like 'substForAllCoBndr', but disables sanity checks. -- The problems that the sanity checks in substCo catch are described in @@ -931,65 +992,94 @@ substForAllCoBndr subst substForAllCoBndrUnchecked :: Subst -> TyCoVar -> KindCoercion -> (Subst, TyCoVar, Coercion) substForAllCoBndrUnchecked subst - = substForAllCoBndrUsing False (substCoUnchecked subst) subst + = substForAllCoBndrUsing Co False (substTyUnchecked subst) (substCoUnchecked subst) subst + +substForAllDCoBndrUnchecked :: Subst -> TyCoVar -> KindDCoercion + -> (Subst, TyCoVar, DCoercion) +substForAllDCoBndrUnchecked subst + = substForAllCoBndrUsing DCo False (substTyUnchecked subst) (substDCoUnchecked subst) subst + -- See Note [Sym and ForAllCo] -substForAllCoBndrUsing :: Bool -- apply sym to binder? - -> (Coercion -> Coercion) -- transformation to kind co - -> Subst -> TyCoVar -> KindCoercion - -> (Subst, TyCoVar, KindCoercion) -substForAllCoBndrUsing sym sco subst old_var - | isTyVar old_var = substForAllCoTyVarBndrUsing sym sco subst old_var - | otherwise = substForAllCoCoVarBndrUsing sym sco subst old_var - -substForAllCoTyVarBndrUsing :: Bool -- apply sym to binder? - -> (Coercion -> Coercion) -- transformation to kind co - -> Subst -> TyVar -> KindCoercion - -> (Subst, TyVar, KindCoercion) -substForAllCoTyVarBndrUsing sym sco (Subst in_scope idenv tenv cenv) old_var old_kind_co +substForAllCoBndrUsing :: CoOrDCo kco + -> Bool -- apply sym to binder? + -> (Type -> Type) + -> (kco -> kco) -- transformation to kind co + -> Subst -> TyCoVar -> kco + -> (Subst, TyCoVar, kco) +substForAllCoBndrUsing co_or_dco sym sty sco subst old_var + | isTyVar old_var = substForAllCoTyVarBndrUsing co_or_dco sym sty sco subst old_var + | otherwise = substForAllCoCoVarBndrUsing co_or_dco sym sty sco subst old_var + +substForAllCoTyVarBndrUsing :: CoOrDCo kco + -> Bool -- apply sym to binder? + -> (Type -> Type) -- transformation to types + -> (kco -> kco) -- transformation to kind co + -> Subst -> TyVar -> kco + -> (Subst, TyVar, kco) +substForAllCoTyVarBndrUsing co_or_dco sym sty sco (Subst in_scope idenv tenv cenv) old_var old_kind_co = assert (isTyVar old_var ) ( Subst (in_scope `extendInScopeSet` new_var) idenv new_env cenv , new_var, new_kind_co ) where new_env | no_change && not sym = delVarEnv tenv old_var | sym = extendVarEnv tenv old_var $ - TyVarTy new_var `CastTy` new_kind_co + mk_cast (TyVarTy new_var) new_kind_co | otherwise = extendVarEnv tenv old_var (TyVarTy new_var) - no_kind_change = noFreeVarsOfCo old_kind_co + no_kind_change = case co_or_dco of + Co -> noFreeVarsOfCo old_kind_co + DCo -> noFreeVarsOfDCo old_kind_co + mk_cast = case co_or_dco of + Co -> CastTy + DCo -> pprPanic "substForAllCoTyVarBndrUsing DCo Sym" + (vcat [ text "kind_co:" <+> ppr old_kind_co ]) + no_change = no_kind_change && (new_var == old_var) new_kind_co | no_kind_change = old_kind_co | otherwise = sco old_kind_co - new_ki1 = coercionLKind new_kind_co + new_ki1 = case co_or_dco of + Co -> coercionLKind new_kind_co -- We could do substitution to (tyVarKind old_var). We don't do so because -- we already substituted new_kind_co, which contains the kind information -- we want. We don't want to do substitution once more. Also, in most cases, -- new_kind_co is a Refl, in which case coercionKind is really fast. + DCo -> sty (tyVarKind old_var) new_var = uniqAway in_scope (setTyVarKind old_var new_ki1) -substForAllCoCoVarBndrUsing :: Bool -- apply sym to binder? - -> (Coercion -> Coercion) -- transformation to kind co - -> Subst -> CoVar -> KindCoercion - -> (Subst, CoVar, KindCoercion) -substForAllCoCoVarBndrUsing sym sco (Subst in_scope idenv tenv cenv) +substForAllCoCoVarBndrUsing :: CoOrDCo kco + -> Bool -- apply sym to binder? + -> (Type -> Type) -- transformation to types + -> (kco -> kco) -- transformation to kind co + -> Subst -> CoVar -> kco + -> (Subst, CoVar, kco) +substForAllCoCoVarBndrUsing co_or_dco sym sty sco (Subst in_scope idenv tenv cenv) old_var old_kind_co - = assert (isCoVar old_var ) + = assert (isCoVar old_var) ( Subst (in_scope `extendInScopeSet` new_var) idenv tenv new_cenv , new_var, new_kind_co ) where new_cenv | no_change && not sym = delVarEnv cenv old_var | otherwise = extendVarEnv cenv old_var (mkCoVarCo new_var) - no_kind_change = noFreeVarsOfCo old_kind_co + no_kind_change = case co_or_dco of + Co -> noFreeVarsOfCo old_kind_co + DCo -> noFreeVarsOfDCo old_kind_co no_change = no_kind_change && (new_var == old_var) new_kind_co | no_kind_change = old_kind_co | otherwise = sco old_kind_co - Pair h1 h2 = coercionKind new_kind_co + Pair h1 h2 = case co_or_dco of + Co -> coercionKind new_kind_co + DCo -> + let l_ty = sty (varType old_var) + r_ty = pprPanic "substForAllCoCoVarBndrUsing DCo Sym" + (vcat [ text "kind_co:" <+> ppr old_kind_co]) + in Pair l_ty r_ty new_var = uniqAway in_scope $ mkCoVar (varName old_var) new_var_type new_var_type | sym = h2 diff --git a/compiler/GHC/Core/TyCo/Tidy.hs b/compiler/GHC/Core/TyCo/Tidy.hs index bfd7e4c7cc..7e7bdf433d 100644 --- a/compiler/GHC/Core/TyCo/Tidy.hs +++ b/compiler/GHC/Core/TyCo/Tidy.hs @@ -12,6 +12,7 @@ module GHC.Core.TyCo.Tidy tidyTyCoVarOcc, tidyTopType, tidyCo, tidyCos, + tidyDCo, tidyForAllTyBinder, tidyForAllTyBinders ) where @@ -218,8 +219,13 @@ tidyTopType ty = tidyType emptyTidyEnv ty -- -- See Note [Strictness in tidyType and friends] tidyCo :: TidyEnv -> Coercion -> Coercion -tidyCo env@(_, subst) co - = go co +tidyCo = fst . tidyCoDCo + +tidyDCo :: TidyEnv -> DCoercion -> DCoercion +tidyDCo = snd . tidyCoDCo + +tidyCoDCo :: TidyEnv -> (Coercion -> Coercion, DCoercion -> DCoercion) +tidyCoDCo env@(_, subst) = (go, go_dco) where go_mco MRefl = MRefl go_mco (MCo co) = MCo $! go co @@ -238,7 +244,8 @@ tidyCo env@(_, subst) co Just cv' -> CoVarCo cv' go (HoleCo h) = HoleCo h go (AxiomInstCo con ind cos) = AxiomInstCo con ind $! strictMap go cos - go (UnivCo p r t1 t2) = (((UnivCo $! (go_prov p)) $! r) $! + go (HydrateDCo r t1 dco rty) = ((HydrateDCo r $! tidyType env t1) $! go_dco dco) $! tidyType env rty + go (UnivCo p r t1 t2) = (((UnivCo $! (go_prov go p)) $! r) $! tidyType env t1) $! tidyType env t2 go (SymCo co) = SymCo $! go co go (TransCo co1 co2) = (TransCo $! go co1) $! go co2 @@ -249,10 +256,30 @@ tidyCo env@(_, subst) co go (SubCo co) = SubCo $! go co go (AxiomRuleCo ax cos) = AxiomRuleCo ax $ strictMap go cos - go_prov (PhantomProv co) = PhantomProv $! go co - go_prov (ProofIrrelProv co) = ProofIrrelProv $! go co - go_prov p@(PluginProv _) = p - go_prov p@(CorePrepProv _) = p + go_dco ReflDCo = ReflDCo + go_dco (GReflRightDCo co) = GReflRightDCo $! go co + go_dco (GReflLeftDCo co) = GReflLeftDCo $! go co + go_dco (TyConAppDCo cos) = TyConAppDCo $! strictMap go_dco cos + go_dco (AppDCo co1 co2) = (AppDCo $! go_dco co1) $! go_dco co2 + go_dco (ForAllDCo tv h co) = ((ForAllDCo $! tvp) $! (go_dco h)) $! tidyDCo envp co + where (envp, tvp) = tidyVarBndr env tv + -- the case above duplicates a bit of work in tidying h and the kind + -- of tv. But the alternative is to use coercionKind, which seems worse. + go_dco (CoVarDCo cv) = case lookupVarEnv subst cv of + Nothing -> CoVarDCo cv + Just cv' -> CoVarDCo cv' + go_dco dco@AxiomInstDCo{} = dco + go_dco dco@StepsDCo{} = dco + go_dco (TransDCo co1 co2) = (TransDCo $! go_dco co1) $! go_dco co2 + go_dco (DehydrateCo co) = DehydrateCo $! go co + go_dco (SubDCo dco) = SubDCo $! go_dco dco + go_dco (UnivDCo prov rhs) = (UnivDCo $! go_prov go_dco prov) $! tidyType env rhs + + go_prov :: (co -> co) -> UnivCoProvenance co -> UnivCoProvenance co + go_prov do_tidy (PhantomProv co) = PhantomProv $! do_tidy co + go_prov do_tidy (ProofIrrelProv co) = ProofIrrelProv $! do_tidy co + go_prov _ p@(PluginProv _) = p + go_prov _ p@(CorePrepProv _) = p tidyCos :: TidyEnv -> [Coercion] -> [Coercion] tidyCos env = strictMap (tidyCo env) diff --git a/compiler/GHC/Core/Type.hs b/compiler/GHC/Core/Type.hs index a5dc5a6865..51147f5d60 100644 --- a/compiler/GHC/Core/Type.hs +++ b/compiler/GHC/Core/Type.hs @@ -38,7 +38,6 @@ module GHC.Core.Type ( funTyConAppTy_maybe, funTyFlagTyCon, tyConAppFunTy_maybe, tyConAppFunCo_maybe, mkFunctionType, mkScaledFunctionTys, chooseFunTyFlag, - mkTyConApp, mkTyConTy, tyConAppTyCon_maybe, tyConAppTyConPicky_maybe, tyConAppArgs_maybe, tyConAppTyCon, tyConAppArgs, @@ -276,8 +275,16 @@ import {-# SOURCE #-} GHC.Core.Coercion , mkSymCo, mkTransCo, mkSelCo, mkLRCo, mkInstCo , mkKindCo, mkSubCo, mkFunCo, funRole , decomposePiCos, coercionKind - , coercionRKind, coercionType + , mkTyConAppDCo, mkAppDCo + , mkForAllDCo + , mkTransDCo + , mkReflDCo, mkGReflRightDCo, mkGReflLeftDCo + , mkDehydrateCo + , mkHydrateDCo + , decomposePiCos + , coercionKind, coercionRKind, coercionType , isReflexiveCo, seqCo + , mkUnivDCo , topNormaliseNewType_maybe ) import {-# SOURCE #-} GHC.Tc.Utils.TcType ( isConcreteTyVar ) @@ -557,8 +564,10 @@ expandTypeSynonyms ty = substCoVar subst cv go_co subst (AxiomInstCo ax ind args) = mkAxiomInstCo ax ind (map (go_co subst) args) + go_co subst (HydrateDCo r t1 dco t2) + = mkHydrateDCo r (go subst t1) (go_dco subst dco) (go subst t2) go_co subst (UnivCo p r t1 t2) - = mkUnivCo (go_prov subst p) r (go subst t1) (go subst t2) + = mkUnivCo (go_prov (go_co subst) p) r (go subst t1) (go subst t2) go_co subst (SymCo co) = mkSymCo (go_co subst co) go_co subst (TransCo co1 co2) @@ -578,16 +587,42 @@ expandTypeSynonyms ty go_co _ (HoleCo h) = pprPanic "expandTypeSynonyms hit a hole" (ppr h) - go_prov subst (PhantomProv co) = PhantomProv (go_co subst co) - go_prov subst (ProofIrrelProv co) = ProofIrrelProv (go_co subst co) - go_prov _ p@(PluginProv _) = p - go_prov _ p@(CorePrepProv _) = p + go_dco _ ReflDCo + = mkReflDCo + go_dco subst (GReflRightDCo co) + = mkGReflRightDCo (go_co subst co) + go_dco subst (GReflLeftDCo co) + = mkGReflLeftDCo (go_co subst co) + go_dco subst (TyConAppDCo args) + = mkTyConAppDCo (map (go_dco subst) args) + go_dco subst (AppDCo co arg) + = mkAppDCo (go_dco subst co) (go_dco subst arg) + go_dco subst (ForAllDCo tv kind_dco co) + = let (subst', tv', kind_dco') = go_dcobndr subst tv kind_dco in + mkForAllDCo tv' kind_dco' (go_dco subst' co) + go_dco subst (CoVarDCo cv) + = mkDehydrateCo (substCoVar subst cv) + go_dco _ dco@AxiomInstDCo{} + = dco + go_dco _ dco@StepsDCo{} + = dco + go_dco subst (TransDCo co1 co2) + = mkTransDCo (go_dco subst co1) (go_dco subst co2) + go_dco subst (DehydrateCo co) = mkDehydrateCo (go_co subst co) + go_dco subst (UnivDCo p rhs) = mkUnivDCo (go_prov (go_dco subst) p) (go subst rhs) + go_dco subst (SubDCo dco) = SubDCo (go_dco subst dco) + + go_prov do_subst (PhantomProv co) = PhantomProv $ do_subst co + go_prov do_subst (ProofIrrelProv co) = ProofIrrelProv $ do_subst co + go_prov _ p@(PluginProv _) = p + go_prov _ p@(CorePrepProv _) = p -- the "False" and "const" are to accommodate the type of -- substForAllCoBndrUsing, which is general enough to -- handle coercion optimization (which sometimes swaps the -- order of a coercion) - go_cobndr subst = substForAllCoBndrUsing False (go_co subst) subst + go_cobndr subst = substForAllCoBndrUsing Co False (go subst) (go_co subst) subst + go_dcobndr subst = substForAllCoBndrUsing DCo False (go subst) (go_dco subst) subst {- Notes on type synonyms ~~~~~~~~~~~~~~~~~~~~~~~~~ @@ -960,24 +995,26 @@ mapTyCoX (TyCoMapper { tcm_tyvar = tyvar go_mco _ MRefl = return MRefl go_mco env (MCo co) = MCo <$> (go_co env co) - go_co env (Refl ty) = Refl <$> go_ty env ty - go_co env (GRefl r ty mco) = mkGReflCo r <$> go_ty env ty <*> go_mco env mco - go_co env (AppCo c1 c2) = mkAppCo <$> go_co env c1 <*> go_co env c2 + go_co env (Refl ty) = Refl <$> go_ty env ty + go_co env (GRefl r ty mco) = mkGReflCo r <$> go_ty env ty <*> go_mco env mco + go_co env (AppCo c1 c2) = mkAppCo <$> go_co env c1 <*> go_co env c2 go_co env (FunCo r afl afr cw c1 c2) = mkFunCo2 r afl afr <$> go_co env cw <*> go_co env c1 <*> go_co env c2 - go_co env (CoVarCo cv) = covar env cv - go_co env (HoleCo hole) = cohole env hole - go_co env (UnivCo p r t1 t2) = mkUnivCo <$> go_prov env p <*> pure r - <*> go_ty env t1 <*> go_ty env t2 - go_co env (SymCo co) = mkSymCo <$> go_co env co - go_co env (TransCo c1 c2) = mkTransCo <$> go_co env c1 <*> go_co env c2 - go_co env (AxiomRuleCo r cos) = AxiomRuleCo r <$> go_cos env cos - go_co env (SelCo i co) = mkSelCo i <$> go_co env co - go_co env (LRCo lr co) = mkLRCo lr <$> go_co env co - go_co env (InstCo co arg) = mkInstCo <$> go_co env co <*> go_co env arg - go_co env (KindCo co) = mkKindCo <$> go_co env co - go_co env (SubCo co) = mkSubCo <$> go_co env co - go_co env (AxiomInstCo ax i cos) = mkAxiomInstCo ax i <$> go_cos env cos + go_co env (CoVarCo cv) = covar env cv + go_co env (HoleCo hole) = cohole env hole + go_co env (HydrateDCo r t1 dco t2) = mkHydrateDCo r <$> go_ty env t1 <*> go_dco env dco <*> go_ty env t2 + go_co env (UnivCo p r t1 t2) = mkUnivCo <$> go_prov (go_co env) p <*> pure r + <*> go_ty env t1 <*> go_ty env t2 + go_co env (SymCo co) = mkSymCo <$> go_co env co + go_co env (TransCo c1 c2) = mkTransCo <$> go_co env c1 <*> go_co env c2 + go_co env (AxiomRuleCo r cos) = AxiomRuleCo r <$> go_cos env cos + go_co env (SelCo i co) = mkSelCo i <$> go_co env co + go_co env (LRCo lr co) = mkLRCo lr <$> go_co env co + go_co env (InstCo co arg) = mkInstCo <$> go_co env co <*> go_co env arg + go_co env (KindCo co) = mkKindCo <$> go_co env co + go_co env (SubCo co) = mkSubCo <$> go_co env co + go_co env (AxiomInstCo ax i cos) = mkAxiomInstCo ax i <$> go_cos env cos + go_co env co@(TyConAppCo r tc cos) | isTcTyCon tc = do { tc' <- tycon tc @@ -996,10 +1033,38 @@ mapTyCoX (TyCoMapper { tcm_tyvar = tyvar ; return $ mkForAllCo tv' kind_co' co' } -- See Note [Efficiency for ForAllCo case of mapTyCoX] - go_prov env (PhantomProv co) = PhantomProv <$> go_co env co - go_prov env (ProofIrrelProv co) = ProofIrrelProv <$> go_co env co - go_prov _ p@(PluginProv _) = return p - go_prov _ p@(CorePrepProv _) = return p + go_dcos _ [] = return [] + go_dcos env (co:cos) = (:) <$> go_dco env co <*> go_dcos env cos + + go_dco _ ReflDCo = pure mkReflDCo + go_dco env (GReflRightDCo co) = mkGReflRightDCo <$> go_co env co + go_dco env (GReflLeftDCo co) = mkGReflLeftDCo <$> go_co env co + go_dco env (AppDCo c1 c2) = mkAppDCo <$> go_dco env c1 <*> go_dco env c2 + go_dco env (CoVarDCo cv) = mkDehydrateCo <$> covar env cv + go_dco env (TransDCo c1 c2) = mkTransDCo <$> go_dco env c1 <*> go_dco env c2 + go_dco _ dco@AxiomInstDCo{} = pure dco + go_dco _ dco@StepsDCo{} = pure dco + go_dco env (DehydrateCo co) = mkDehydrateCo <$> go_co env co + go_dco env co@(TyConAppDCo cos) + -- Not a TcTyCon + | null cos -- Avoid allocation in this very + = return co -- common case (E.g. Int, LiftedRep etc) + + | otherwise + = mkTyConAppDCo <$> go_dcos env cos + go_dco env (ForAllDCo tv kind_dco co) + = do { kind_dco' <- go_dco env kind_dco + ; (env', tv') <- tycobinder env tv Inferred + ; co' <- go_dco env' co + ; return $ mkForAllDCo tv' kind_dco' co' } + -- See Note [Efficiency for ForAllCo case of mapTyCoX] + go_dco env (UnivDCo p rhs) = mkUnivDCo <$> go_prov (go_dco env) p <*> go_ty env rhs + go_dco env (SubDCo dco) = SubDCo <$> go_dco env dco + + go_prov go (PhantomProv co) = PhantomProv <$> go co + go_prov go (ProofIrrelProv co) = ProofIrrelProv <$> go co + go_prov _ p@(PluginProv _) = return p + go_prov _ p@(CorePrepProv _) = return p {- ********************************************************************* diff --git a/compiler/GHC/Core/Unify.hs-boot b/compiler/GHC/Core/Unify.hs-boot new file mode 100644 index 0000000000..b08fcf83c9 --- /dev/null +++ b/compiler/GHC/Core/Unify.hs-boot @@ -0,0 +1,9 @@ +module GHC.Core.Unify where + +import GHC.Core.TyCo.Subst (Subst) +import GHC.Core.Type (Type) + + +import Data.Maybe (Maybe) + +tcMatchTys :: [Type] -> [Type] -> Maybe Subst diff --git a/compiler/GHC/Core/Utils.hs b/compiler/GHC/Core/Utils.hs index 565bf698bc..020b956d8f 100644 --- a/compiler/GHC/Core/Utils.hs +++ b/compiler/GHC/Core/Utils.hs @@ -2385,9 +2385,9 @@ isEmptyTy ty normSplitTyConApp_maybe :: FamInstEnvs -> Type -> Maybe (TyCon, [Type], Coercion) normSplitTyConApp_maybe fam_envs ty | let Reduction co ty1 = topNormaliseType_maybe fam_envs ty - `orElse` (mkReflRedn Representational ty) + `orElse` (mkReflRedn ty) , Just (tc, tc_args) <- splitTyConApp_maybe ty1 - = Just (tc, tc_args, co) + = Just (tc, tc_args, mkHydrateDCo Representational ty co ty1) normSplitTyConApp_maybe _ _ = Nothing {- diff --git a/compiler/GHC/CoreToIface.hs b/compiler/GHC/CoreToIface.hs index e6d3fe93b7..9de8e84972 100644 --- a/compiler/GHC/CoreToIface.hs +++ b/compiler/GHC/CoreToIface.hs @@ -24,6 +24,7 @@ module GHC.CoreToIface , tidyToIfaceTcArgs -- * Coercions , toIfaceCoercion, toIfaceCoercionX + , toIfaceDCoercionX -- * Pattern synonyms , patSynToIfaceDecl -- * Expressions @@ -275,10 +276,14 @@ toIfaceCoercion :: Coercion -> IfaceCoercion toIfaceCoercion = toIfaceCoercionX emptyVarSet toIfaceCoercionX :: VarSet -> Coercion -> IfaceCoercion +toIfaceDCoercionX :: VarSet -> DCoercion -> IfaceDCoercion -- (toIfaceCoercionX free ty) -- translates the tyvars in 'free' as IfaceFreeTyVars -toIfaceCoercionX fr co - = go co +toIfaceCoercionX = fst . toIfaceCoercionDCoercion +toIfaceDCoercionX = snd . toIfaceCoercionDCoercion + +toIfaceCoercionDCoercion :: VarSet -> (Coercion -> IfaceCoercion, DCoercion -> IfaceDCoercion) +toIfaceCoercionDCoercion fr = (go, go_dco) where go_mco MRefl = IfaceMRefl go_mco (MCo co) = IfaceMCo $ go co @@ -301,7 +306,8 @@ toIfaceCoercionX fr co go (SubCo co) = IfaceSubCo (go co) go (AxiomRuleCo co cs) = IfaceAxiomRuleCo (coaxrName co) (map go cs) go (AxiomInstCo c i cs) = IfaceAxiomInstCo (coAxiomName c) i (map go cs) - go (UnivCo p r t1 t2) = IfaceUnivCo (go_prov p) r + go (HydrateDCo r t dco _)= IfaceHydrateDCo r (toIfaceTypeX fr t) (go_dco dco) + go (UnivCo p r t1 t2) = IfaceUnivCo (go_prov go p) r (toIfaceTypeX fr t1) (toIfaceTypeX fr t2) go co@(TyConAppCo r tc cos) @@ -317,11 +323,34 @@ toIfaceCoercionX fr co where fr' = fr `delVarSet` tv - go_prov :: UnivCoProvenance -> IfaceUnivCoProv - go_prov (PhantomProv co) = IfacePhantomProv (go co) - go_prov (ProofIrrelProv co) = IfaceProofIrrelProv (go co) - go_prov (PluginProv str) = IfacePluginProv str - go_prov (CorePrepProv b) = IfaceCorePrepProv b + + go_dco ReflDCo = IfaceReflDCo + go_dco (GReflRightDCo co) = IfaceGReflRightDCo (go co) + go_dco (GReflLeftDCo co) = IfaceGReflLeftDCo (go co) + go_dco (CoVarDCo cv) + -- See [TcTyVars in IfaceType] in GHC.Iface.Type + | cv `elemVarSet` fr = IfaceFreeCoVarDCo cv + | otherwise = IfaceCoVarDCo (toIfaceCoVar cv) + go_dco (AppDCo co1 co2) = IfaceAppDCo (go_dco co1) (go_dco co2) + go_dco (TransDCo co1 co2) = IfaceTransDCo (go_dco co1) (go_dco co2) + go_dco (AxiomInstDCo ax) = IfaceAxiomInstDCo (coAxiomName ax) + go_dco (StepsDCo n) = IfaceStepsDCo n + go_dco (TyConAppDCo cos) = IfaceTyConAppDCo (map go_dco cos) + go_dco (SubDCo dco) = IfaceSubDCo (go_dco dco) + go_dco (DehydrateCo co) = IfaceDehydrateCo (go co) + go_dco (ForAllDCo tv k co) = IfaceForAllDCo (toIfaceBndr tv) + (toIfaceDCoercionX fr' k) + (toIfaceDCoercionX fr' co) + where + fr' = fr `delVarSet` tv + + go_dco (UnivDCo p rhs) = IfaceUnivDCo (go_prov go_dco p) (toIfaceTypeX fr rhs) + + go_prov :: (co -> iface_co) -> UnivCoProvenance co -> IfaceUnivCoProv iface_co + go_prov to_iface (PhantomProv co) = IfacePhantomProv (to_iface co) + go_prov to_iface (ProofIrrelProv co) = IfaceProofIrrelProv (to_iface co) + go_prov _ (PluginProv str) = IfacePluginProv str + go_prov _ (CorePrepProv b) = IfaceCorePrepProv b toIfaceTcArgs :: TyCon -> [Type] -> IfaceAppArgs toIfaceTcArgs = toIfaceTcArgsX emptyVarSet diff --git a/compiler/GHC/CoreToIface.hs-boot b/compiler/GHC/CoreToIface.hs-boot index 61b291f324..fbd7436651 100644 --- a/compiler/GHC/CoreToIface.hs-boot +++ b/compiler/GHC/CoreToIface.hs-boot @@ -1,8 +1,9 @@ module GHC.CoreToIface where -import {-# SOURCE #-} GHC.Core.TyCo.Rep ( Type, TyLit, Coercion ) +import {-# SOURCE #-} GHC.Core.TyCo.Rep ( Type, TyLit, Coercion, DCoercion ) import {-# SOURCE #-} GHC.Iface.Type( IfaceType, IfaceTyCon, IfaceBndr - , IfaceCoercion, IfaceTyLit, IfaceAppArgs ) + , IfaceCoercion, IfaceDCoercion + , IfaceTyLit, IfaceAppArgs ) import GHC.Types.Var ( VarBndr, TyCoVar ) import GHC.Types.Var.Env ( TidyEnv ) import GHC.Core.TyCon ( TyCon ) @@ -15,4 +16,5 @@ toIfaceForAllBndrs :: [VarBndr TyCoVar flag] -> [VarBndr IfaceBndr flag] toIfaceTyCon :: TyCon -> IfaceTyCon toIfaceTcArgs :: TyCon -> [Type] -> IfaceAppArgs toIfaceCoercionX :: VarSet -> Coercion -> IfaceCoercion +toIfaceDCoercionX :: VarSet -> DCoercion -> IfaceDCoercion tidyToIfaceTcArgs :: TidyEnv -> TyCon -> [Type] -> IfaceAppArgs diff --git a/compiler/GHC/Driver/Config.hs b/compiler/GHC/Driver/Config.hs index c92da902c9..b63a36335d 100644 --- a/compiler/GHC/Driver/Config.hs +++ b/compiler/GHC/Driver/Config.hs @@ -16,7 +16,15 @@ import GHCi.Message (EvalOpts(..)) -- | Initialise coercion optimiser configuration from DynFlags initOptCoercionOpts :: DynFlags -> OptCoercionOpts initOptCoercionOpts dflags = OptCoercionOpts - { optCoercionEnabled = not (hasNoOptCoercion dflags) + { optCoercionOpts + = if hasNoOptCoercion dflags + then Nothing + else + let dco_method = + if hasKeepDCoercions dflags + then OptDCos { skipDCoOpt = True } + else HydrateDCos + in Just dco_method } -- | Initialise Simple optimiser configuration from DynFlags diff --git a/compiler/GHC/Driver/Flags.hs b/compiler/GHC/Driver/Flags.hs index 2099d7c100..813a723be0 100644 --- a/compiler/GHC/Driver/Flags.hs +++ b/compiler/GHC/Driver/Flags.hs @@ -472,6 +472,7 @@ data GeneralFlag | Opt_G_NoStateHack | Opt_G_NoOptCoercion + | Opt_G_KeepDCoercions deriving (Eq, Show, Enum) -- Check whether a flag should be considered an "optimisation flag" diff --git a/compiler/GHC/Driver/Session.hs b/compiler/GHC/Driver/Session.hs index 84962f7868..150384670d 100644 --- a/compiler/GHC/Driver/Session.hs +++ b/compiler/GHC/Driver/Session.hs @@ -28,7 +28,8 @@ module GHC.Driver.Session ( FatalMessager, FlushOut(..), ProfAuto(..), glasgowExtsFlags, - hasPprDebug, hasNoDebugOutput, hasNoStateHack, hasNoOptCoercion, + hasPprDebug, hasNoDebugOutput, hasNoStateHack, + hasNoOptCoercion, hasKeepDCoercions, dopt, dopt_set, dopt_unset, gopt, gopt_set, gopt_unset, setGeneralFlag', unSetGeneralFlag', wopt, wopt_set, wopt_unset, @@ -1467,6 +1468,8 @@ hasNoStateHack = gopt Opt_G_NoStateHack hasNoOptCoercion :: DynFlags -> Bool hasNoOptCoercion = gopt Opt_G_NoOptCoercion +hasKeepDCoercions :: DynFlags -> Bool +hasKeepDCoercions = gopt Opt_G_KeepDCoercions -- | Test whether a 'DumpFlag' is set dopt :: DumpFlag -> DynFlags -> Bool @@ -2384,6 +2387,8 @@ dynamic_flags_deps = [ (NoArg (setGeneralFlag Opt_G_NoStateHack)) , make_ord_flag defGhcFlag "fno-opt-coercion" (NoArg (setGeneralFlag Opt_G_NoOptCoercion)) + , make_ord_flag defGhcFlag "fkeep-dcoercions" + (NoArg (setGeneralFlag Opt_G_KeepDCoercions)) , make_ord_flag defGhcFlag "with-rtsopts" (HasArg setRtsOpts) , make_ord_flag defGhcFlag "rtsopts" @@ -4086,6 +4091,7 @@ optLevelFlags -- see Note [Documenting optimisation flags] , ([0], Opt_IgnoreInterfacePragmas) , ([0], Opt_OmitInterfacePragmas) + , ([0], Opt_G_KeepDCoercions) , ([1,2], Opt_CoreConstantFolding) diff --git a/compiler/GHC/Iface/Rename.hs b/compiler/GHC/Iface/Rename.hs index b372e7a1d9..b8e0992a3a 100644 --- a/compiler/GHC/Iface/Rename.hs +++ b/compiler/GHC/Iface/Rename.hs @@ -675,12 +675,14 @@ rnIfaceCo (IfaceCoVarCo lcl) = IfaceCoVarCo <$> pure lcl rnIfaceCo (IfaceHoleCo lcl) = IfaceHoleCo <$> pure lcl rnIfaceCo (IfaceAxiomInstCo n i cs) = IfaceAxiomInstCo <$> rnIfaceGlobal n <*> pure i <*> mapM rnIfaceCo cs +rnIfaceCo (IfaceHydrateDCo r t1 dco) + = IfaceHydrateDCo r <$> rnIfaceType t1 <*> rnIfaceDCo dco rnIfaceCo (IfaceUnivCo s r t1 t2) - = IfaceUnivCo s r <$> rnIfaceType t1 <*> rnIfaceType t2 + = IfaceUnivCo <$> rnIfaceProv rnIfaceCo s <*> pure r <*> rnIfaceType t1 <*> rnIfaceType t2 rnIfaceCo (IfaceSymCo c) = IfaceSymCo <$> rnIfaceCo c -rnIfaceCo (IfaceTransCo c1 c2) - = IfaceTransCo <$> rnIfaceCo c1 <*> rnIfaceCo c2 +rnIfaceCo (IfaceTransCo co1 co2) + = IfaceTransCo <$> rnIfaceCo co1 <*> rnIfaceCo co2 rnIfaceCo (IfaceInstCo c1 c2) = IfaceInstCo <$> rnIfaceCo c1 <*> rnIfaceCo c2 rnIfaceCo (IfaceSelCo d c) = IfaceSelCo d <$> rnIfaceCo c @@ -690,6 +692,42 @@ rnIfaceCo (IfaceAxiomRuleCo ax cos) = IfaceAxiomRuleCo ax <$> mapM rnIfaceCo cos rnIfaceCo (IfaceKindCo c) = IfaceKindCo <$> rnIfaceCo c +rnIfaceDCo :: Rename IfaceDCoercion +rnIfaceDCo IfaceReflDCo + = return IfaceReflDCo +rnIfaceDCo (IfaceGReflRightDCo co) + = IfaceGReflRightDCo <$> rnIfaceCo co +rnIfaceDCo (IfaceGReflLeftDCo co) + = IfaceGReflLeftDCo <$> rnIfaceCo co +rnIfaceDCo (IfaceTyConAppDCo dcos) + = IfaceTyConAppDCo <$> mapM rnIfaceDCo dcos +rnIfaceDCo (IfaceAppDCo dco1 dco2) + = IfaceAppDCo <$> rnIfaceDCo dco1 <*> rnIfaceDCo dco2 +rnIfaceDCo (IfaceForAllDCo bndr dco1 dco2) + = IfaceForAllDCo <$> rnIfaceBndr bndr <*> rnIfaceDCo dco1 <*> rnIfaceDCo dco2 +rnIfaceDCo (IfaceCoVarDCo lcl) + = return (IfaceCoVarDCo lcl) +rnIfaceDCo (IfaceFreeCoVarDCo c) + = return (IfaceFreeCoVarDCo c) +rnIfaceDCo (IfaceAxiomInstDCo ax) + = return (IfaceAxiomInstDCo ax) +rnIfaceDCo (IfaceStepsDCo steps) + = return (IfaceStepsDCo steps) +rnIfaceDCo (IfaceTransDCo co1 co2) + = IfaceTransDCo <$> rnIfaceDCo co1 <*> rnIfaceDCo co2 +rnIfaceDCo (IfaceDehydrateCo co) + = IfaceDehydrateCo <$> rnIfaceCo co +rnIfaceDCo (IfaceUnivDCo prov rhs) + = IfaceUnivDCo <$> rnIfaceProv rnIfaceDCo prov <*> rnIfaceType rhs +rnIfaceDCo (IfaceSubDCo dco) + = IfaceSubDCo <$> rnIfaceDCo dco + +rnIfaceProv :: Rename iface_co -> Rename (IfaceUnivCoProv iface_co) +rnIfaceProv rn_thing (IfacePhantomProv iface_co) = IfacePhantomProv <$> rn_thing iface_co +rnIfaceProv rn_thing (IfaceProofIrrelProv iface_co) = IfaceProofIrrelProv <$> rn_thing iface_co +rnIfaceProv _ (IfacePluginProv str) = return (IfacePluginProv str) +rnIfaceProv _ (IfaceCorePrepProv homo) = return (IfaceCorePrepProv homo) + rnIfaceTyCon :: Rename IfaceTyCon rnIfaceTyCon (IfaceTyCon n info) = IfaceTyCon <$> rnIfaceGlobal n <*> pure info diff --git a/compiler/GHC/Iface/Syntax.hs b/compiler/GHC/Iface/Syntax.hs index 71b87cb19c..686cb187cf 100644 --- a/compiler/GHC/Iface/Syntax.hs +++ b/compiler/GHC/Iface/Syntax.hs @@ -1724,8 +1724,10 @@ freeNamesIfCoercion (IfaceCoVarCo _) = emptyNameSet freeNamesIfCoercion (IfaceHoleCo _) = emptyNameSet freeNamesIfCoercion (IfaceAxiomInstCo ax _ cos) = unitNameSet ax &&& fnList freeNamesIfCoercion cos +freeNamesIfCoercion (IfaceHydrateDCo _ t1 dco) + = freeNamesIfType t1 &&& freeNamesIfDCoercion dco freeNamesIfCoercion (IfaceUnivCo p _ t1 t2) - = freeNamesIfProv p &&& freeNamesIfType t1 &&& freeNamesIfType t2 + = freeNamesIfProv freeNamesIfCoercion p &&& freeNamesIfType t1 &&& freeNamesIfType t2 freeNamesIfCoercion (IfaceSymCo c) = freeNamesIfCoercion c freeNamesIfCoercion (IfaceTransCo c1 c2) @@ -1744,11 +1746,33 @@ freeNamesIfCoercion (IfaceAxiomRuleCo _ax cos) -- the axiom is just a string, so we don't count it as a name. = fnList freeNamesIfCoercion cos -freeNamesIfProv :: IfaceUnivCoProv -> NameSet -freeNamesIfProv (IfacePhantomProv co) = freeNamesIfCoercion co -freeNamesIfProv (IfaceProofIrrelProv co) = freeNamesIfCoercion co -freeNamesIfProv (IfacePluginProv _) = emptyNameSet -freeNamesIfProv (IfaceCorePrepProv _) = emptyNameSet +freeNamesIfDCoercion :: IfaceDCoercion -> NameSet +freeNamesIfDCoercion IfaceReflDCo = emptyNameSet +freeNamesIfDCoercion (IfaceGReflRightDCo co) + = freeNamesIfCoercion co +freeNamesIfDCoercion (IfaceGReflLeftDCo co) + = freeNamesIfCoercion co +freeNamesIfDCoercion (IfaceTyConAppDCo cos) + = fnList freeNamesIfDCoercion cos +freeNamesIfDCoercion (IfaceAppDCo c1 c2) + = freeNamesIfDCoercion c1 &&& freeNamesIfDCoercion c2 +freeNamesIfDCoercion (IfaceForAllDCo _ kind_co co) + = freeNamesIfDCoercion kind_co &&& freeNamesIfDCoercion co +freeNamesIfDCoercion (IfaceFreeCoVarDCo _) = emptyNameSet +freeNamesIfDCoercion (IfaceCoVarDCo _) = emptyNameSet +freeNamesIfDCoercion (IfaceAxiomInstDCo ax) = unitNameSet ax +freeNamesIfDCoercion IfaceStepsDCo{} = emptyNameSet +freeNamesIfDCoercion (IfaceTransDCo co1 co2) + = freeNamesIfDCoercion co1 &&& freeNamesIfDCoercion co2 +freeNamesIfDCoercion (IfaceDehydrateCo co) = freeNamesIfCoercion co +freeNamesIfDCoercion (IfaceUnivDCo p rhs) = freeNamesIfProv freeNamesIfDCoercion p &&& freeNamesIfType rhs +freeNamesIfDCoercion (IfaceSubDCo dco) = freeNamesIfDCoercion dco + +freeNamesIfProv :: (co -> NameSet) -> IfaceUnivCoProv co -> NameSet +freeNamesIfProv free_names (IfacePhantomProv co) = free_names co +freeNamesIfProv free_names (IfaceProofIrrelProv co) = free_names co +freeNamesIfProv _ (IfacePluginProv _) = emptyNameSet +freeNamesIfProv _ (IfaceCorePrepProv _) = emptyNameSet freeNamesIfVarBndr :: VarBndr IfaceBndr vis -> NameSet freeNamesIfVarBndr (Bndr bndr _) = freeNamesIfBndr bndr diff --git a/compiler/GHC/Iface/Type.hs b/compiler/GHC/Iface/Type.hs index 2b45a712e6..b43c285eac 100644 --- a/compiler/GHC/Iface/Type.hs +++ b/compiler/GHC/Iface/Type.hs @@ -19,6 +19,7 @@ module GHC.Iface.Type ( IfaceType(..), IfacePredType, IfaceKind, IfaceCoercion(..), IfaceMCoercion(..), + IfaceDCoercion(..), IfaceUnivCoProv(..), IfaceMult, IfaceTyCon(..), @@ -53,6 +54,7 @@ module GHC.Iface.Type ( pprIfaceForAllPart, pprIfaceForAllPartMust, pprIfaceForAll, pprIfaceSigmaType, pprIfaceTyLit, pprIfaceCoercion, pprParendIfaceCoercion, + pprIfaceDCoercion, splitIfaceSigmaTy, pprIfaceTypeApp, pprUserIfaceForAll, pprIfaceCoTcApp, pprTyTcApp, pprIfacePrefixApp, isIfaceRhoType, @@ -387,7 +389,8 @@ data IfaceCoercion -- There are only a fixed number of CoAxiomRules, so it suffices -- to use an IfaceLclName to distinguish them. -- See Note [Adding built-in type families] in GHC.Builtin.Types.Literals - | IfaceUnivCo IfaceUnivCoProv Role IfaceType IfaceType + | IfaceHydrateDCo Role IfaceType IfaceDCoercion + | IfaceUnivCo (IfaceUnivCoProv IfaceCoercion) Role IfaceType IfaceType | IfaceSymCo IfaceCoercion | IfaceTransCo IfaceCoercion IfaceCoercion | IfaceSelCo CoSel IfaceCoercion @@ -398,11 +401,27 @@ data IfaceCoercion | IfaceFreeCoVar CoVar -- See Note [Free tyvars in IfaceType] | IfaceHoleCo CoVar -- ^ See Note [Holes in IfaceCoercion] -data IfaceUnivCoProv - = IfacePhantomProv IfaceCoercion - | IfaceProofIrrelProv IfaceCoercion +data IfaceDCoercion + = IfaceReflDCo + | IfaceGReflRightDCo IfaceCoercion + | IfaceGReflLeftDCo IfaceCoercion + | IfaceTyConAppDCo [IfaceDCoercion] + | IfaceAppDCo IfaceDCoercion IfaceDCoercion + | IfaceForAllDCo IfaceBndr IfaceDCoercion IfaceDCoercion + | IfaceCoVarDCo IfLclName + | IfaceFreeCoVarDCo CoVar + | IfaceAxiomInstDCo IfExtName + | IfaceStepsDCo !Int + | IfaceTransDCo IfaceDCoercion IfaceDCoercion + | IfaceDehydrateCo IfaceCoercion + | IfaceSubDCo IfaceDCoercion + | IfaceUnivDCo (IfaceUnivCoProv IfaceDCoercion) IfaceType + +data IfaceUnivCoProv iface_co + = IfacePhantomProv iface_co + | IfaceProofIrrelProv iface_co | IfacePluginProv String - | IfaceCorePrepProv Bool -- See defn of CorePrepProv + | IfaceCorePrepProv Bool -- See defn of CorePrepProv {- Note [Holes in IfaceCoercion] ~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~ @@ -609,7 +628,8 @@ substIfaceType env ty go_co (IfaceCoVarCo cv) = IfaceCoVarCo cv go_co (IfaceHoleCo cv) = IfaceHoleCo cv go_co (IfaceAxiomInstCo a i cos) = IfaceAxiomInstCo a i (go_cos cos) - go_co (IfaceUnivCo prov r t1 t2) = IfaceUnivCo (go_prov prov) r (go t1) (go t2) + go_co (IfaceHydrateDCo r t1 dco) = IfaceHydrateDCo r (go t1) (go_dco dco) + go_co (IfaceUnivCo prov r t1 t2) = IfaceUnivCo (go_prov go_co prov) r (go t1) (go t2) go_co (IfaceSymCo co) = IfaceSymCo (go_co co) go_co (IfaceTransCo co1 co2) = IfaceTransCo (go_co co1) (go_co co2) go_co (IfaceSelCo n co) = IfaceSelCo n (go_co co) @@ -619,12 +639,28 @@ substIfaceType env ty go_co (IfaceSubCo co) = IfaceSubCo (go_co co) go_co (IfaceAxiomRuleCo n cos) = IfaceAxiomRuleCo n (go_cos cos) + go_dco IfaceReflDCo = IfaceReflDCo + go_dco (IfaceGReflRightDCo co) = IfaceGReflRightDCo (go_co co) + go_dco (IfaceGReflLeftDCo co) = IfaceGReflLeftDCo (go_co co) + go_dco (IfaceTyConAppDCo cos) = IfaceTyConAppDCo (go_dcos cos) + go_dco (IfaceAppDCo c1 c2) = IfaceAppDCo (go_dco c1) (go_dco c2) + go_dco (IfaceForAllDCo {}) = pprPanic "substIfaceDCoercion" (ppr ty) + go_dco (IfaceFreeCoVarDCo cv) = IfaceFreeCoVarDCo cv + go_dco (IfaceCoVarDCo cv) = IfaceCoVarDCo cv + go_dco dco@IfaceAxiomInstDCo{} = dco + go_dco dco@IfaceStepsDCo{} = dco + go_dco (IfaceTransDCo co1 co2) = IfaceTransDCo (go_dco co1) (go_dco co2) + go_dco (IfaceDehydrateCo co) = IfaceDehydrateCo (go_co co) + go_dco (IfaceSubDCo dco) = IfaceSubDCo (go_dco dco) + go_dco (IfaceUnivDCo p rhs) = IfaceUnivDCo (go_prov go_dco p) (go rhs) + go_cos = map go_co + go_dcos = map go_dco - go_prov (IfacePhantomProv co) = IfacePhantomProv (go_co co) - go_prov (IfaceProofIrrelProv co) = IfaceProofIrrelProv (go_co co) - go_prov co@(IfacePluginProv _) = co - go_prov co@(IfaceCorePrepProv _) = co + go_prov do_subst (IfacePhantomProv co) = IfacePhantomProv (do_subst co) + go_prov do_subst (IfaceProofIrrelProv co) = IfaceProofIrrelProv (do_subst co) + go_prov _ co@(IfacePluginProv _) = co + go_prov _ co@(IfaceCorePrepProv _) = co substIfaceAppArgs :: IfaceTySubst -> IfaceAppArgs -> IfaceAppArgs substIfaceAppArgs env args @@ -1248,9 +1284,9 @@ pprIfaceForAllPartMust :: [IfaceForAllBndr] -> [IfacePredType] -> SDoc -> SDoc pprIfaceForAllPartMust tvs ctxt sdoc = ppr_iface_forall_part ShowForAllMust tvs ctxt sdoc -pprIfaceForAllCoPart :: [(IfLclName, IfaceCoercion)] -> SDoc -> SDoc -pprIfaceForAllCoPart tvs sdoc - = sep [ pprIfaceForAllCo tvs, sdoc ] +pprIfaceForAllCoPart :: (iface_co -> SDoc) -> [(IfLclName, iface_co)] -> SDoc -> SDoc +pprIfaceForAllCoPart ppr_iface_co tvs sdoc + = sep [ pprIfaceForAllCo ppr_iface_co tvs, sdoc ] ppr_iface_forall_part :: ShowForAllFlag -> [IfaceForAllBndr] -> [IfacePredType] -> SDoc -> SDoc @@ -1287,12 +1323,12 @@ ppr_itv_bndrs all_bndrs@(bndr@(Bndr _ vis) : bndrs) vis1 | otherwise = (all_bndrs, []) ppr_itv_bndrs [] _ = ([], []) -pprIfaceForAllCo :: [(IfLclName, IfaceCoercion)] -> SDoc -pprIfaceForAllCo [] = empty -pprIfaceForAllCo tvs = text "forall" <+> pprIfaceForAllCoBndrs tvs <> dot +pprIfaceForAllCo :: (iface_co -> SDoc) -> [(IfLclName, iface_co)] -> SDoc +pprIfaceForAllCo _ [] = empty +pprIfaceForAllCo ppr_iface_co tvs = text "forall" <+> pprIfaceForAllCoBndrs ppr_iface_co tvs <> dot -pprIfaceForAllCoBndrs :: [(IfLclName, IfaceCoercion)] -> SDoc -pprIfaceForAllCoBndrs bndrs = hsep $ map pprIfaceForAllCoBndr bndrs +pprIfaceForAllCoBndrs :: (iface_co -> SDoc) -> [(IfLclName, iface_co)] -> SDoc +pprIfaceForAllCoBndrs ppr_iface_co bndrs = hsep $ map (pprIfaceForAllCoBndr ppr_iface_co) bndrs pprIfaceForAllBndr :: IfaceForAllBndr -> SDoc pprIfaceForAllBndr bndr = @@ -1306,9 +1342,9 @@ pprIfaceForAllBndr bndr = -- See Note [Suppressing binder signatures] suppress_sig = SuppressBndrSig False -pprIfaceForAllCoBndr :: (IfLclName, IfaceCoercion) -> SDoc -pprIfaceForAllCoBndr (tv, kind_co) - = parens (ppr tv <+> dcolon <+> pprIfaceCoercion kind_co) +pprIfaceForAllCoBndr :: (iface_co -> SDoc) -> (IfLclName, iface_co) -> SDoc +pprIfaceForAllCoBndr ppr_iface_co (tv, kind_co) + = parens (ppr tv <+> dcolon <+> ppr_iface_co kind_co) -- | Show forall flag -- @@ -1793,7 +1829,7 @@ ppr_co ctxt_prec (IfaceAppCo co1 co2) ppr_co funPrec co1 <+> pprParendIfaceCoercion co2 ppr_co ctxt_prec co@(IfaceForAllCo {}) = maybeParen ctxt_prec funPrec $ - pprIfaceForAllCoPart tvs (pprIfaceCoercion inner_co) + pprIfaceForAllCoPart pprIfaceCoercion tvs (pprIfaceCoercion inner_co) where (tvs, inner_co) = split_co co @@ -1808,10 +1844,13 @@ ppr_co _ (IfaceFreeCoVar covar) = ppr covar ppr_co _ (IfaceCoVarCo covar) = ppr covar ppr_co _ (IfaceHoleCo covar) = braces (ppr covar) +ppr_co ctxt_prec (IfaceHydrateDCo role ty1 dco) + = maybeParen ctxt_prec appPrec $ + text "Hydrate" <+> (ppr role <+> ppr_ty appPrec ty1 <+> pprParendIfaceDCoercion dco) ppr_co _ (IfaceUnivCo prov role ty1 ty2) = text "Univ" <> (parens $ - sep [ ppr role <+> pprIfaceUnivCoProv prov - , dcolon <+> ppr ty1 <> comma <+> ppr ty2 ]) + sep [ ppr role <+> pprIfaceUnivCoProv pprParendIfaceCoercion prov + , dcolon <+> ppr_ty appPrec ty1 <+> text "~" <+> ppr_ty appPrec ty2 ]) ppr_co ctxt_prec (IfaceInstCo co ty) = maybeParen ctxt_prec appPrec $ @@ -1853,14 +1892,77 @@ ppr_role r = underscore <> pp_role Phantom -> char 'P' ------------------ -pprIfaceUnivCoProv :: IfaceUnivCoProv -> SDoc -pprIfaceUnivCoProv (IfacePhantomProv co) - = text "phantom" <+> pprParendIfaceCoercion co -pprIfaceUnivCoProv (IfaceProofIrrelProv co) - = text "irrel" <+> pprParendIfaceCoercion co -pprIfaceUnivCoProv (IfacePluginProv s) +pprIfaceDCoercion, pprParendIfaceDCoercion :: IfaceDCoercion -> SDoc +pprIfaceDCoercion = ppr_dco topPrec +pprParendIfaceDCoercion = ppr_dco appPrec + +ppr_dco :: PprPrec -> IfaceDCoercion -> SDoc +ppr_dco _ IfaceReflDCo = text "Refl" +ppr_dco ctxt_prec (IfaceGReflRightDCo co) + = maybeParen ctxt_prec appPrec $ + text "GReflRight" <+> pprParendIfaceCoercion co +ppr_dco ctxt_prec (IfaceGReflLeftDCo co) + = maybeParen ctxt_prec appPrec $ + text "GReflLeft" <+> pprParendIfaceCoercion co +ppr_dco ctxt_prec (IfaceTyConAppDCo cos) + = ppr_special_dco ctxt_prec (text "TyConApp") cos +ppr_dco ctxt_prec (IfaceAppDCo co1 co2) + = maybeParen ctxt_prec appPrec $ + ppr_dco funPrec co1 <+> pprParendIfaceDCoercion co2 +ppr_dco ctxt_prec co@(IfaceForAllDCo {}) + = maybeParen ctxt_prec funPrec $ + pprIfaceForAllCoPart pprIfaceDCoercion tvs (pprIfaceDCoercion inner_dco) + where + (tvs, inner_dco) = split_dco co + + split_dco (IfaceForAllDCo (IfaceTvBndr (name, _)) kind_dco co') + = let (tvs, co'') = split_dco co' in ((name,kind_dco):tvs,co'') + split_dco (IfaceForAllDCo (IfaceIdBndr (_, name, _)) kind_dco co') + = let (tvs, co'') = split_dco co' in ((name,kind_dco):tvs,co'') + split_dco co' = ([], co') + +-- Why these two? See Note [Free tyvars in IfaceType] +ppr_dco _ (IfaceFreeCoVarDCo covar) = ppr covar +ppr_dco _ (IfaceCoVarDCo covar) = ppr covar + +ppr_dco _ (IfaceAxiomInstDCo ax) = ppr ax +ppr_dco ctxt_prec (IfaceStepsDCo n) + = maybeParen ctxt_prec appPrec $ + text "Steps" <+> ppr n + +ppr_dco ctxt_prec (IfaceTransDCo co1 co2) + -- chain nested TransCo + = let ppr_trans (IfaceTransDCo c1 c2) = semi <+> ppr_dco topPrec c1 : ppr_trans c2 + ppr_trans c = [semi <+> ppr_dco opPrec c] + in maybeParen ctxt_prec opPrec $ + vcat (ppr_dco topPrec co1 : ppr_trans co2) +ppr_dco ctxt_prec (IfaceDehydrateCo co) + = maybeParen ctxt_prec funPrec + $ text "Dehydrate" <+> pprParendIfaceCoercion co +ppr_dco _ (IfaceUnivDCo prov rhs) + = text "UnivDCo" <> (parens $ + sep [ pprIfaceUnivCoProv pprParendIfaceDCoercion prov + , dcolon <+> text "_ ~>" <+> ppr_ty appPrec rhs ]) +ppr_dco ctxt_prec (IfaceSubDCo dco) + = maybeParen ctxt_prec appPrec $ + text "Sub" <+> ppr_dco appPrec dco + +-- AMG TODO: deduplicate some of the pretty-printing code +ppr_special_dco :: PprPrec -> SDoc -> [IfaceDCoercion] -> SDoc +ppr_special_dco ctxt_prec doc cos + = maybeParen ctxt_prec appPrec + (sep [doc, nest 4 (sep (map pprParendIfaceDCoercion cos))]) + + +------------------ +pprIfaceUnivCoProv :: (iface_co -> SDoc) -> IfaceUnivCoProv iface_co -> SDoc +pprIfaceUnivCoProv ppr_co (IfacePhantomProv co) + = text "phantom" <+> ppr_co co +pprIfaceUnivCoProv ppr_co (IfaceProofIrrelProv co) + = text "irrel" <+> ppr_co co +pprIfaceUnivCoProv _ (IfacePluginProv s) = text "plugin" <+> doubleQuotes (text s) -pprIfaceUnivCoProv (IfaceCorePrepProv _) +pprIfaceUnivCoProv _ (IfaceCorePrepProv _) = text "CorePrep" ------------------- @@ -2154,6 +2256,11 @@ instance Binary IfaceCoercion where putByte bh 17 put_ bh a put_ bh b + put_ bh (IfaceHydrateDCo r ty dco) = do + putByte bh 18 + put_ bh r + put_ bh ty + put_ bh dco put_ _ (IfaceFreeCoVar cv) = pprPanic "Can't serialise IfaceFreeCoVar" (ppr cv) put_ _ (IfaceHoleCo cv) @@ -2217,9 +2324,96 @@ instance Binary IfaceCoercion where 17-> do a <- get bh b <- get bh return $ IfaceAxiomRuleCo a b + 18-> do r <- get bh + t <- get bh + dco <- get bh + return $ IfaceHydrateDCo r t dco _ -> panic ("get IfaceCoercion " ++ show tag) -instance Binary IfaceUnivCoProv where +instance Binary IfaceDCoercion where + put_ bh IfaceReflDCo = do + putByte bh 1 + put_ bh (IfaceGReflLeftDCo a) = do + putByte bh 2 + put_ bh a + put_ bh (IfaceGReflRightDCo a) = do + putByte bh 3 + put_ bh a + put_ bh (IfaceTyConAppDCo a) = do + putByte bh 4 + put_ bh a + put_ bh (IfaceAppDCo a b) = do + putByte bh 5 + put_ bh a + put_ bh b + put_ bh (IfaceForAllDCo a b c) = do + putByte bh 6 + put_ bh a + put_ bh b + put_ bh c + put_ bh (IfaceCoVarDCo a) = do + putByte bh 7 + put_ bh a + put_ bh (IfaceAxiomInstDCo a) = do + putByte bh 8 + put_ bh a + put_ bh (IfaceStepsDCo a) = do + putByte bh 10 + put_ bh a + put_ bh (IfaceTransDCo a b) = do + putByte bh 11 + put_ bh a + put_ bh b + put_ bh (IfaceDehydrateCo a) = do + putByte bh 12 + put_ bh a + put_ bh (IfaceUnivDCo p rhs) = do + putByte bh 13 + put_ bh p + put_ bh rhs + put_ bh (IfaceSubDCo dco) = do + putByte bh 14 + put_ bh dco + put_ _ (IfaceFreeCoVarDCo cv) + = pprPanic "Can't serialise IfaceFreeCoVarDCo" (ppr cv) + -- See Note [Holes in IfaceCoercion] + + get bh = do + tag <- getByte bh + case tag of + 1 -> return IfaceReflDCo + 2 -> do a <- get bh + return $ IfaceGReflLeftDCo a + 3 -> do a <- get bh + return $ IfaceGReflRightDCo a + 4 -> do a <- get bh + return $ IfaceTyConAppDCo a + 5 -> do a <- get bh + b <- get bh + return $ IfaceAppDCo a b + 6 -> do a <- get bh + b <- get bh + c <- get bh + return $ IfaceForAllDCo a b c + 7 -> do a <- get bh + return $ IfaceCoVarDCo a + 8 -> do a <- get bh + return $ IfaceAxiomInstDCo a + 10-> do a <- get bh + return $ IfaceStepsDCo a + 11-> do a <- get bh + b <- get bh + return $ IfaceTransDCo a b + 12 -> do a <- get bh + return $ IfaceDehydrateCo a + 13 -> do p <- get bh + rhs <- get bh + return $ IfaceUnivDCo p rhs + 14 -> do dco <- get bh + return $ IfaceSubDCo dco + _ -> panic ("get IfaceDCoercion " ++ show tag) + +instance Binary iface_co => Binary (IfaceUnivCoProv iface_co) where put_ bh (IfacePhantomProv a) = do putByte bh 1 put_ bh a @@ -2286,6 +2480,7 @@ instance NFData IfaceCoercion where IfaceCoVarCo f1 -> rnf f1 IfaceAxiomInstCo f1 f2 f3 -> rnf f1 `seq` rnf f2 `seq` rnf f3 IfaceAxiomRuleCo f1 f2 -> rnf f1 `seq` rnf f2 + IfaceHydrateDCo f1 f2 f3 -> f1 `seq` rnf f2 `seq` rnf f3 IfaceUnivCo f1 f2 f3 f4 -> rnf f1 `seq` f2 `seq` rnf f3 `seq` rnf f4 IfaceSymCo f1 -> rnf f1 IfaceTransCo f1 f2 -> rnf f1 `seq` rnf f2 @@ -2297,7 +2492,24 @@ instance NFData IfaceCoercion where IfaceFreeCoVar f1 -> f1 `seq` () IfaceHoleCo f1 -> f1 `seq` () -instance NFData IfaceUnivCoProv where +instance NFData IfaceDCoercion where + rnf = \case + IfaceReflDCo -> () + IfaceGReflRightDCo f1 -> rnf f1 + IfaceGReflLeftDCo f1 -> rnf f1 + IfaceTyConAppDCo f1 -> rnf f1 + IfaceAppDCo f1 f2 -> rnf f1 `seq` rnf f2 + IfaceForAllDCo f1 f2 f3 -> rnf f1 `seq` rnf f2 `seq` rnf f3 + IfaceCoVarDCo f1 -> rnf f1 + IfaceAxiomInstDCo f1 -> rnf f1 + IfaceStepsDCo f1 -> rnf f1 + IfaceUnivDCo f1 f2 -> rnf f1 `seq` rnf f2 + IfaceTransDCo f1 f2 -> rnf f1 `seq` rnf f2 + IfaceDehydrateCo f1 -> rnf f1 + IfaceFreeCoVarDCo f1 -> f1 `seq` () + IfaceSubDCo f1 -> f1 `seq` () + +instance NFData (IfaceUnivCoProv co) where rnf x = seq x () instance NFData IfaceMCoercion where diff --git a/compiler/GHC/Iface/Type.hs-boot b/compiler/GHC/Iface/Type.hs-boot index 9c10f29ed5..ae26e40f3c 100644 --- a/compiler/GHC/Iface/Type.hs-boot +++ b/compiler/GHC/Iface/Type.hs-boot @@ -1,6 +1,7 @@ module GHC.Iface.Type ( IfaceType, IfaceTyCon, IfaceBndr - , IfaceCoercion, IfaceTyLit, IfaceAppArgs + , IfaceCoercion, IfaceDCoercion + , IfaceTyLit, IfaceAppArgs ) where @@ -14,4 +15,5 @@ data IfaceType data IfaceTyCon data IfaceTyLit data IfaceCoercion +data IfaceDCoercion data IfaceBndr diff --git a/compiler/GHC/IfaceToCore.hs b/compiler/GHC/IfaceToCore.hs index e37f34ef46..8fafceeb6a 100644 --- a/compiler/GHC/IfaceToCore.hs +++ b/compiler/GHC/IfaceToCore.hs @@ -1491,11 +1491,15 @@ tcIfaceCo = go ForAllCo tv' k' <$> go c } go (IfaceCoVarCo n) = CoVarCo <$> go_var n go (IfaceAxiomInstCo n i cs) = AxiomInstCo <$> tcIfaceCoAxiom n <*> pure i <*> mapM go cs - go (IfaceUnivCo p r t1 t2) = UnivCo <$> tcIfaceUnivCoProv p <*> pure r + go (IfaceHydrateDCo r t1 dco)= do { t1 <- tcIfaceType t1 + ; dco <- tcIfaceDCo dco + ; return $ HydrateDCo r t1 dco (followDCo r t1 dco) } + -- SLD TODO: investigate perf impact here... + -- might be worth storing RHS in the interface file... + go (IfaceUnivCo p r t1 t2) = UnivCo <$> tcIfaceUnivCoProv go p <*> pure r <*> tcIfaceType t1 <*> tcIfaceType t2 go (IfaceSymCo c) = SymCo <$> go c - go (IfaceTransCo c1 c2) = TransCo <$> go c1 - <*> go c2 + go (IfaceTransCo co1 co2) = TransCo <$> go co1 <*> go co2 go (IfaceInstCo c1 t2) = InstCo <$> go c1 <*> go t2 go (IfaceSelCo d c) = do { c' <- go c @@ -1511,11 +1515,34 @@ tcIfaceCo = go go_var :: FastString -> IfL CoVar go_var = tcIfaceLclId -tcIfaceUnivCoProv :: IfaceUnivCoProv -> IfL UnivCoProvenance -tcIfaceUnivCoProv (IfacePhantomProv kco) = PhantomProv <$> tcIfaceCo kco -tcIfaceUnivCoProv (IfaceProofIrrelProv kco) = ProofIrrelProv <$> tcIfaceCo kco -tcIfaceUnivCoProv (IfacePluginProv str) = return $ PluginProv str -tcIfaceUnivCoProv (IfaceCorePrepProv b) = return $ CorePrepProv b +tcIfaceDCo :: IfaceDCoercion -> IfL DCoercion +tcIfaceDCo = go + where + go IfaceReflDCo = pure ReflDCo + go (IfaceGReflRightDCo co) = GReflRightDCo <$> tcIfaceCo co + go (IfaceGReflLeftDCo co) = GReflLeftDCo <$> tcIfaceCo co + go (IfaceTyConAppDCo cs) = TyConAppDCo <$> mapM go cs + go (IfaceAppDCo c1 c2) = AppDCo <$> go c1 <*> go c2 + go (IfaceForAllDCo tv k c) = do { k' <- tcIfaceDCo k + ; bindIfaceBndr tv $ \ tv' -> + ForAllDCo tv' k' <$> go c } + go (IfaceCoVarDCo n) = CoVarDCo <$> go_var n + go (IfaceAxiomInstDCo ax) = AxiomInstDCo <$> tcIfaceCoAxiom ax + go (IfaceStepsDCo n) = pure $ StepsDCo n + go (IfaceTransDCo co1 co2) = TransDCo <$> go co1 <*> go co2 + go (IfaceDehydrateCo co) = DehydrateCo <$> tcIfaceCo co + go (IfaceUnivDCo prov rhs) = UnivDCo <$> tcIfaceUnivCoProv go prov <*> tcIfaceType rhs + go (IfaceSubDCo dco) = SubDCo <$> go dco + go (IfaceFreeCoVarDCo c) = pprPanic "tcIfaceDCo:IfaceFreeCoVarDCo" (ppr c) + + go_var :: FastString -> IfL CoVar + go_var = tcIfaceLclId + +tcIfaceUnivCoProv :: (co -> IfL iface_co) -> IfaceUnivCoProv co -> IfL (UnivCoProvenance iface_co) +tcIfaceUnivCoProv tc_co (IfacePhantomProv kco) = PhantomProv <$> tc_co kco +tcIfaceUnivCoProv tc_co (IfaceProofIrrelProv kco) = ProofIrrelProv <$> tc_co kco +tcIfaceUnivCoProv _ (IfacePluginProv str) = return $ PluginProv str +tcIfaceUnivCoProv _ (IfaceCorePrepProv b) = return $ CorePrepProv b {- ************************************************************************ diff --git a/compiler/GHC/Tc/Gen/Foreign.hs b/compiler/GHC/Tc/Gen/Foreign.hs index 31c42f86d6..b369b43c48 100644 --- a/compiler/GHC/Tc/Gen/Foreign.hs +++ b/compiler/GHC/Tc/Gen/Foreign.hs @@ -137,10 +137,10 @@ normaliseFfiType' env ty0 = runWriterT $ go Representational initRecTc ty0 | (bndrs, inner_ty) <- splitForAllForAllTyBinders ty , not (null bndrs) = do redn <- go role rec_nts inner_ty - return $ mkHomoForAllRedn bndrs redn + return $ mkHomoForAllRedn bndrs inner_ty redn | otherwise -- see Note [Don't recur in normaliseFfiType'] - = return $ mkReflRedn role ty + = return $ mkReflRedn ty go_tc_app :: Role -> RecTcChecker -> TyCon -> [Type] -> WriterT (Bag GlobalRdrElt) TcM Reduction @@ -168,13 +168,13 @@ normaliseFfiType' env ty0 = runWriterT $ go Representational initRecTc ty0 Just gre -> do { redn <- go role rec_nts' nt_rhs ; tell (unitBag gre) - ; return $ nt_co `mkTransRedn` redn } } + ; return $ mkDehydrateCoercionRedn nt_co `mkTransRedn` redn } } -- AMG TODO | isFamilyTyCon tc -- Expand open tycons - , Reduction co ty <- normaliseTcApp env role tc tys - , not (isReflexiveCo co) + , redn0@(Reduction dco ty) <- normaliseTcApp env role tc tys + , not (isReflexiveDCo role (mkTyConApp tc tys) dco ty) = do redn <- go role rec_nts ty - return $ co `mkTransRedn` redn + return $ redn0 `mkTransRedn` redn | otherwise = nothing -- see Note [Don't recur in normaliseFfiType'] @@ -184,12 +184,12 @@ normaliseFfiType' env ty0 = runWriterT $ go Representational initRecTc ty0 = do { args <- unzipRedns <$> zipWithM ( \ ty r -> go r rec_nts ty ) tys (tyConRoleListX role tc) - ; return $ mkTyConAppRedn role tc args } + ; return $ mkTyConAppRedn tc args } nt_co = mkUnbranchedAxInstCo role (newTyConCo tc) tys [] nt_rhs = newTyConInstRhs tc tys ty = mkTyConApp tc tys - nothing = return $ mkReflRedn role ty + nothing = return $ mkReflRedn ty checkNewtypeFFI :: GlobalRdrEnv -> TyCon -> Maybe GlobalRdrElt checkNewtypeFFI rdr_env tc @@ -252,7 +252,7 @@ tcFImport (L dloc fo@(ForeignImport { fd_name = L nloc nm, fd_sig_ty = hs_ty , fd_fi = imp_decl })) = setSrcSpanA dloc $ addErrCtxt (foreignDeclCtxt fo) $ do { sig_ty <- tcHsSigType (ForSigCtxt nm) hs_ty - ; (Reduction norm_co norm_sig_ty, gres) <- normaliseFfiType sig_ty + ; (redn@(Reduction _ norm_sig_ty), gres) <- normaliseFfiType sig_ty ; let -- Drop the foralls before inspecting the -- structure of the foreign type. @@ -272,10 +272,12 @@ tcFImport (L dloc fo@(ForeignImport { fd_name = L nloc nm, fd_sig_ty = hs_ty ; imp_decl' <- tcCheckFIType arg_tys res_ty imp_decl -- Can't use sig_ty here because sig_ty :: Type and -- we need HsType Id hence the undefined - ; let fi_decl = ForeignImport { fd_name = L nloc id - , fd_sig_ty = undefined - , fd_i_ext = mkSymCo norm_co - , fd_fi = imp_decl' } + ; let co = mkSymCo $ mkHydrateReductionDCoercion Representational sig_ty redn + fi_decl = + ForeignImport { fd_name = L nloc id + , fd_sig_ty = undefined + , fd_i_ext = co + , fd_fi = imp_decl' } ; return (id, L dloc fi_decl, gres) } tcFImport d = pprPanic "tcFImport" (ppr d) @@ -411,7 +413,7 @@ tcFExport fo@(ForeignExport { fd_name = L loc nm, fd_sig_ty = hs_ty, fd_fe = spe sig_ty <- tcHsSigType (ForSigCtxt nm) hs_ty rhs <- tcCheckPolyExpr (nlHsVar nm) sig_ty - (Reduction norm_co norm_sig_ty, gres) <- normaliseFfiType sig_ty + (redn@(Reduction _ norm_sig_ty), gres) <- normaliseFfiType sig_ty spec' <- tcCheckFEType norm_sig_ty spec @@ -428,7 +430,7 @@ tcFExport fo@(ForeignExport { fd_name = L loc nm, fd_sig_ty = hs_ty, fd_fe = spe return ( mkVarBind id rhs , ForeignExport { fd_name = L loc id , fd_sig_ty = undefined - , fd_e_ext = norm_co + , fd_e_ext = mkHydrateReductionDCoercion Representational sig_ty redn , fd_fe = spec' } , gres) tcFExport d = pprPanic "tcFExport" (ppr d) diff --git a/compiler/GHC/Tc/Instance/Family.hs b/compiler/GHC/Tc/Instance/Family.hs index 5e2b523e4b..b5b4a71f50 100644 --- a/compiler/GHC/Tc/Instance/Family.hs +++ b/compiler/GHC/Tc/Instance/Family.hs @@ -529,6 +529,7 @@ tcTopNormaliseNewTypeTF_maybe faminsts rdr_env ty | otherwise = NS_Done +-- AMG TODO: refactor tcTopNormaliseNewTypeTF_maybe to just return count of steps taken? {- ************************************************************************ diff --git a/compiler/GHC/Tc/Solver/Canonical.hs b/compiler/GHC/Tc/Solver/Canonical.hs index 49210cefa8..5e850c6441 100644 --- a/compiler/GHC/Tc/Solver/Canonical.hs +++ b/compiler/GHC/Tc/Solver/Canonical.hs @@ -1010,31 +1010,40 @@ the rewriter set. We check this with an assertion. -} -rewriteEvidence rewriters old_ev (Reduction co new_pred) do_next - | isReflCo co -- See Note [Rewriting with Refl] +rewriteEvidence rewriters old_ev (Reduction dco new_pred) do_next + | isReflDCo dco -- See Note [Rewriting with Refl] = assert (isEmptyRewriterSet rewriters) $ do_next (setCtEvPredType old_ev new_pred) rewriteEvidence rewriters ev@(CtGiven { ctev_evar = old_evar, ctev_loc = loc }) - (Reduction co new_pred) do_next + (Reduction dco new_pred) do_next = assert (isEmptyRewriterSet rewriters) $ -- this is a Given, not a wanted - do { new_ev <- newGivenEvVar loc (new_pred, new_tm) + do { let + old_pred = ctEvPred ev + dco' = downgradeDCoToRepresentational (ctEvRole ev) old_pred dco new_pred + co = mkHydrateDCo Representational old_pred dco' new_pred + + -- mkEvCast optimises ReflCo + new_tm = mkEvCast (evId old_evar) co + ; new_ev <- newGivenEvVar loc (new_pred, new_tm) ; do_next new_ev } - where - -- mkEvCast optimises ReflCo - new_tm = mkEvCast (evId old_evar) - (downgradeRole Representational (ctEvRole ev) co) rewriteEvidence new_rewriters ev@(CtWanted { ctev_dest = dest , ctev_loc = loc , ctev_rewriters = rewriters }) - (Reduction co new_pred) do_next + (Reduction dco new_pred) do_next = do { mb_new_ev <- newWanted loc rewriters' new_pred - ; massert (coercionRole co == ctEvRole ev) + ; let + old_pred = ctEvPred ev + dco' = downgradeDCoToRepresentational (ctEvRole ev) old_pred dco new_pred + co = mkHydrateDCo Representational old_pred dco' new_pred + -- NB: this call to mkHydrateDCo is OK, because of the invariant + -- on the LHS type stored in a Reduction. See Note [The Reduction type] + -- in GHC.Core.Reduction. + ; setWantedEvTerm dest IsCoherent $ - mkEvCast (getEvExpr mb_new_ev) - (downgradeRole Representational (ctEvRole ev) (mkSymCo co)) + (mkEvCast (getEvExpr mb_new_ev) (mkSymCo co)) ; case mb_new_ev of Fresh new_ev -> do_next new_ev Cached _ -> stopWith ev "Cached wanted" } diff --git a/compiler/GHC/Tc/Solver/Equality.hs b/compiler/GHC/Tc/Solver/Equality.hs index 6bb894b8b4..95d7b56b1c 100644 --- a/compiler/GHC/Tc/Solver/Equality.hs +++ b/compiler/GHC/Tc/Solver/Equality.hs @@ -239,7 +239,8 @@ can_eq_nc' False rdr_env envs ev eq_rel _ ps_ty1 _ ps_ty2 = -- Rewrite the two types and try again do { (redn1@(Reduction _ xi1), rewriters1) <- rewrite ev ps_ty1 ; (redn2@(Reduction _ xi2), rewriters2) <- rewrite ev ps_ty2 - ; new_ev <- rewriteEqEvidence (rewriters1 S.<> rewriters2) ev NotSwapped redn1 redn2 + ; new_ev <- rewriteEqEvidence (rewriters1 S.<> rewriters2) ev NotSwapped + (ps_ty1,redn1) (ps_ty2,redn2) ; traceTcS "can_eq_nc: go round again" (ppr new_ev $$ ppr xi1 $$ ppr xi2) ; can_eq_nc' True rdr_env envs new_ev eq_rel xi1 xi1 xi2 xi2 } @@ -633,10 +634,12 @@ can_eq_newtype_nc ev swapped ty1 ((gres, co1), ty1') ty2 ps_ty2 -- through newtypes is tantamount to using their constructors. ; recordUsedGREs gres - ; let redn1 = mkReduction co1 ty1' + ; let redn1 = mkReduction (mkDehydrateCo co1) ty1' + -- TODO: eliminate dehydration + ; new_ev <- rewriteEqEvidence emptyRewriterSet ev' swapped - redn1 (mkReflRedn Representational ps_ty2) + (ty1, redn1) (ps_ty2,mkReflRedn ps_ty2) ; can_eq_nc False new_ev ReprEq ty1' ty1' ty2 ps_ty2 } @@ -712,11 +715,9 @@ canEqCast rewritten ev eq_rel swapped ty1 co1 ty2 ps_ty2 , ppr ty1 <+> text "|>" <+> ppr co1 , ppr ps_ty2 ]) ; new_ev <- rewriteEqEvidence emptyRewriterSet ev swapped - (mkGReflLeftRedn role ty1 co1) - (mkReflRedn role ps_ty2) + (mkCastTy ty1 co1, mkGReflLeftRedn ty1 co1) + (ps_ty2, mkReflRedn ps_ty2) ; can_eq_nc rewritten new_ev eq_rel ty1 ty1 ty2 ps_ty2 } - where - role = eqRelRole eq_rel ------------------------ canTyConApp :: CtEvidence -> EqRel @@ -1304,7 +1305,8 @@ canEqFailure ev ReprEq ty1 ty2 -- new equalities become available ; traceTcS "canEqFailure with ReprEq" $ vcat [ ppr ev, ppr redn1, ppr redn2 ] - ; new_ev <- rewriteEqEvidence (rewriters1 S.<> rewriters2) ev NotSwapped redn1 redn2 + ; new_ev <- rewriteEqEvidence (rewriters1 S.<> rewriters2) ev NotSwapped + (ty1,redn1) (ty2,redn2) ; continueWith (mkIrredCt ReprEqReason new_ev) } -- | Call when canonicalizing an equality fails with utterly no hope. @@ -1315,7 +1317,8 @@ canEqHardFailure ev ty1 ty2 = do { traceTcS "canEqHardFailure" (ppr ty1 $$ ppr ty2) ; (redn1, rewriters1) <- rewriteForErrors ev ty1 ; (redn2, rewriters2) <- rewriteForErrors ev ty2 - ; new_ev <- rewriteEqEvidence (rewriters1 S.<> rewriters2) ev NotSwapped redn1 redn2 + ; new_ev <- rewriteEqEvidence (rewriters1 S.<> rewriters2) ev NotSwapped + (ty1,redn1) (ty2,redn2) ; continueWith (mkIrredCt ShapeMismatchReason new_ev) } {- @@ -1506,8 +1509,8 @@ canEqCanLHSHetero ev eq_rel swapped lhs1 ps_xi1 ki1 xi2 ps_xi2 ki2 -- Otherwise we might put something in the inert set that isn't inert then startAgainWith (mkNonCanonical ev) else - do { let lhs_redn = mkReflRedn role ps_xi1 - rhs_redn = mkGReflRightRedn role xi2 mb_sym_kind_co + do { let lhs_redn = mkReflRedn ps_xi1 + rhs_redn = mkGReflRightRedn xi2 mb_sym_kind_co mb_sym_kind_co = case swapped of NotSwapped -> mkSymCo kind_co IsSwapped -> kind_co @@ -1515,7 +1518,8 @@ canEqCanLHSHetero ev eq_rel swapped lhs1 ps_xi1 ki1 xi2 ps_xi2 ki2 ; traceTcS "Hetero equality gives rise to kind equality" (ppr swapped $$ ppr kind_co <+> dcolon <+> sep [ ppr ki1, text "~#", ppr ki2 ]) - ; type_ev <- rewriteEqEvidence rewriters ev swapped lhs_redn rhs_redn + ; type_ev <- rewriteEqEvidence rewriters ev swapped + (xi1,lhs_redn) (xi2,rhs_redn) ; let new_xi2 = mkCastTy ps_xi2 mb_sym_kind_co ; canEqCanLHSHomo type_ev eq_rel NotSwapped lhs1 ps_xi1 new_xi2 new_xi2 }} @@ -1540,7 +1544,6 @@ canEqCanLHSHetero ev eq_rel swapped lhs1 ps_xi1 ki1 xi2 ps_xi2 ki2 ; return (kind_co, rewriterSetFromCts cts, not (null unifs)) } xi1 = canEqLHSType lhs1 - role = eqRelRole eq_rel canEqCanLHSHomo :: CtEvidence -- lhs ~ rhs -- or, if swapped: rhs ~ lhs @@ -1626,7 +1629,6 @@ canEqCanLHS2 ev eq_rel swapped lhs1 ps_xi1 lhs2 ps_xi2 mco else finish_without_swapping } } where sym_mco = mkSymMCo mco - role = eqRelRole eq_rel lhs1_ty = canEqLHSType lhs1 lhs2_ty = canEqLHSType lhs2 @@ -1639,9 +1641,10 @@ canEqCanLHS2 ev eq_rel swapped lhs1 ps_xi1 lhs2 ps_xi2 mco -- where grefl1 : lhs1 ~ lhs1 |> sym co -- grefl2 : lhs2 ~ lhs2 |> co finish_with_swapping - = do { let lhs1_redn = mkGReflRightMRedn role lhs1_ty sym_mco - lhs2_redn = mkGReflLeftMRedn role lhs2_ty mco - ; new_ev <-rewriteEqEvidence emptyRewriterSet ev swapped lhs1_redn lhs2_redn + = do { let lhs1_redn = mkGReflRightMRedn lhs1_ty sym_mco + lhs2_redn = mkGReflLeftMRedn lhs2_ty mco + ; new_ev <- rewriteEqEvidence emptyRewriterSet ev swapped + (lhs1_ty, lhs1_redn) (mkCastTyMCo lhs2_ty mco, lhs2_redn) ; canEqCanLHSFinish new_ev eq_rel IsSwapped lhs2 (ps_xi1 `mkCastTyMCo` sym_mco) } put_tyvar_on_lhs = isWanted ev && eq_rel == NomEq @@ -1772,7 +1775,7 @@ canEqCanLHSFinish_try_unification ev eq_rel swapped lhs rhs -> canEqCanLHSFinish_no_unification ev eq_rel swapped lhs rhs | otherwise - -> tryIrredInstead reason ev eq_rel swapped lhs rhs ; + -> tryIrredInstead reason ev swapped lhs rhs ; PuOK _ rhs_redn -> @@ -1783,10 +1786,11 @@ canEqCanLHSFinish_try_unification ev eq_rel swapped lhs rhs -- We unify alpha := Int, and set co := <Int>. No need to -- swap to co = sym co' -- co' = <Int> - new_ev <- if isReflCo (reductionCoercion rhs_redn) + new_ev <- if isReflDCo (reductionDCoercion rhs_redn) then return ev - else rewriteEqEvidence emptyRewriterSet ev swapped - (mkReflRedn Nominal (mkTyVarTy tv)) rhs_redn + else let lhs = mkTyVarTy tv + in rewriteEqEvidence emptyRewriterSet ev swapped + (lhs, mkReflRedn lhs) (rhs, rhs_redn) ; let tv_ty = mkTyVarTy tv final_rhs = reductionReducedType rhs_redn @@ -1848,12 +1852,12 @@ canEqCanLHSFinish_no_unification ev eq_rel swapped lhs rhs -- -> swapAndFinish ev eq_rel swapped lhs_ty can_rhs -- | otherwise - -> tryIrredInstead reason ev eq_rel swapped lhs rhs + -> tryIrredInstead reason ev swapped lhs rhs PuOK _ rhs_redn -> do { new_ev <- rewriteEqEvidence emptyRewriterSet ev swapped - (mkReflRedn (eqRelRole eq_rel) lhs_ty) - rhs_redn + (lhs_ty, mkReflRedn lhs_ty) + (rhs, rhs_redn) -- Important: even if the coercion is Refl, -- * new_ev has reductionReducedType on the RHS @@ -1871,30 +1875,28 @@ swapAndFinish :: CtEvidence -> EqRel -> SwapFlag -- mentions alpha, it would not be a canonical constraint as-is. -- We want to flip it to (F tys ~ a), whereupon it is canonical swapAndFinish ev eq_rel swapped lhs_ty can_rhs - = do { new_ev <- rewriteEqEvidence emptyRewriterSet ev (flipSwap swapped) - (mkReflRedn role (canEqLHSType can_rhs)) - (mkReflRedn role lhs_ty) + = do { let rhs = canEqLHSType can_rhs + ; new_ev <- rewriteEqEvidence emptyRewriterSet ev (flipSwap swapped) + (rhs, mkReflRedn rhs) + (lhs_ty, mkReflRedn lhs_ty) ; interactEq (EqCt { eq_ev = new_ev, eq_eq_rel = eq_rel , eq_lhs = can_rhs, eq_rhs = lhs_ty }) } - where - role = eqRelRole eq_rel ---------------------- -tryIrredInstead :: CheckTyEqResult -> CtEvidence -> EqRel -> SwapFlag +tryIrredInstead :: CheckTyEqResult -> CtEvidence -> SwapFlag -> CanEqLHS -> TcType -> TcS (StopOrContinue Ct) -- We have a non-canonical equality -- We still swap it if 'swapped' says so, so that it is oriented -- in the direction that the error message reporting machinery -- expects it; e.g. (m ~ t m) rather than (t m ~ m) -- This is not very important, and only affects error reporting. -tryIrredInstead reason ev eq_rel swapped lhs rhs +tryIrredInstead reason ev swapped lhs rhs = do { traceTcS "cantMakeCanonical" (ppr reason $$ ppr lhs $$ ppr rhs) + ; let lhs_ty = canEqLHSType lhs ; new_ev <- rewriteEqEvidence emptyRewriterSet ev swapped - (mkReflRedn role (canEqLHSType lhs)) - (mkReflRedn role rhs) + (lhs_ty, mkReflRedn lhs_ty) + (rhs, mkReflRedn rhs) ; solveIrredEquality (NonCanonicalReason reason) new_ev } - where - role = eqRelRole eq_rel ----------------------- -- | Solve a reflexive equality constraint @@ -2386,8 +2388,8 @@ rewriteEqEvidence :: RewriterSet -- New rewriters -> CtEvidence -- Old evidence :: olhs ~ orhs (not swapped) -- or orhs ~ olhs (swapped) -> SwapFlag - -> Reduction -- lhs_co :: olhs ~ nlhs - -> Reduction -- rhs_co :: orhs ~ nrhs + -> (Type, Reduction) -- lhs_co :: olhs ~ nlhs + -> (Type, Reduction) -- rhs_co :: orhs ~ nrhs -> TcS CtEvidence -- Of type nlhs ~ nrhs -- With reductions (Reduction lhs_co nlhs) (Reduction rhs_co nrhs), -- rewriteEqEvidence yields, for a given equality (Given g olhs orhs): @@ -2404,10 +2406,11 @@ rewriteEqEvidence :: RewriterSet -- New rewriters -- w : orhs ~ olhs = rhs_co ; sym w1 ; sym lhs_co -- -- It's all a form of rewriteEvidence, specialised for equalities -rewriteEqEvidence new_rewriters old_ev swapped (Reduction lhs_co nlhs) (Reduction rhs_co nrhs) +rewriteEqEvidence new_rewriters old_ev swapped (olhs, lhs_redn@(Reduction lhs_dco nlhs)) + (orhs, rhs_redn@(Reduction rhs_dco nrhs)) | NotSwapped <- swapped - , isReflCo lhs_co -- See Note [Rewriting with Refl] - , isReflCo rhs_co + , isReflDCo lhs_dco -- See Note [Rewriting with Refl] + , isReflDCo rhs_dco = return (setCtEvPredType old_ev new_pred) | CtGiven { ctev_evar = old_evar } <- old_ev @@ -2437,6 +2440,8 @@ rewriteEqEvidence new_rewriters old_ev swapped (Reduction lhs_co nlhs) (Reductio where new_pred = mkTcEqPredLikeEv old_ev nlhs nrhs loc = ctEvLoc old_ev + lhs_co = mkHydrateReductionDCoercion (ctEvRole old_ev) olhs lhs_redn + rhs_co = mkHydrateReductionDCoercion (ctEvRole old_ev) orhs rhs_redn {- ********************************************************************** @@ -2678,7 +2683,6 @@ final_qci_check work_ct eq_rel lhs rhs where ev = ctEvidence work_ct loc = ctEvLoc ev - role = eqRelRole eq_rel try_for_qci -- First try looking for (lhs ~ rhs) | Just (cls, tys) <- boxEqPred eq_rel lhs rhs @@ -2698,7 +2702,7 @@ final_qci_check work_ct eq_rel lhs rhs ; case res of OneInst { cir_mk_ev = mk_ev } -> do { ev' <- rewriteEqEvidence emptyRewriterSet ev IsSwapped - (mkReflRedn role rhs) (mkReflRedn role lhs) + (rhs, mkReflRedn rhs) (lhs, mkReflRedn lhs) ; chooseInstance ev' (res { cir_mk_ev = mk_eq_ev cls tys mk_ev }) } _ -> do { traceTcS "final_qci_check:3" (ppr work_ct) ; continueWith work_ct }} diff --git a/compiler/GHC/Tc/Solver/Monad.hs b/compiler/GHC/Tc/Solver/Monad.hs index 91e20becf8..35d560f9a7 100644 --- a/compiler/GHC/Tc/Solver/Monad.hs +++ b/compiler/GHC/Tc/Solver/Monad.hs @@ -762,7 +762,8 @@ lookupFamAppInert rewrite_pred fam_tc tys | Just ecl <- findFunEq inert_funeqs fam_tc tys , Just (EqCt { eq_ev = ctev, eq_rhs = rhs }) <- find (rewrite_pred . eqCtFlavourRole) ecl - = Just (mkReduction (ctEvCoercion ctev) rhs, ctEvFlavourRole ctev) + = Just (mkReduction (mkDehydrateCo (ctEvCoercion ctev)) rhs -- SLD TODO: avoid dehydrating? + ,ctEvFlavourRole ctev) | otherwise = Nothing lookupInInerts :: CtLoc -> TcPredType -> TcS (Maybe CtEvidence) @@ -812,7 +813,6 @@ lookupFamAppCache fam_tc tys Nothing -> return Nothing } extendFamAppCache :: TyCon -> [Type] -> Reduction -> TcS () --- NB: co :: rhs ~ F tys, to match expectations of rewriter extendFamAppCache tc xi_args stuff@(Reduction _ ty) = do { dflags <- getDynFlags ; when (gopt Opt_FamAppCache dflags) $ @@ -831,7 +831,7 @@ dropFromFamAppCache varset where check :: Reduction -> Bool check redn - = not (anyFreeVarsOfCo (`elemVarSet` varset) $ reductionCoercion redn) + = not (anyFreeVarsOfDCo (`elemVarSet` varset) $ reductionDCoercion redn) {- ********************************************************************* * * @@ -892,16 +892,17 @@ data TcSEnv --------------- newtype TcS a = TcS { unTcS :: TcSEnv -> TcM a } - deriving (Functor) - -instance MonadFix TcS where - mfix k = TcS $ \env -> mfix (\x -> unTcS (k x) env) -- | Smart constructor for 'TcS', as describe in Note [The one-shot state -- monad trick] in "GHC.Utils.Monad". mkTcS :: (TcSEnv -> TcM a) -> TcS a mkTcS f = TcS (oneShot f) +-- Use the one-shot trick for the functor instance of 'TcS'. +instance Functor TcS where + fmap f m = mkTcS $ \env -> + fmap f $ unTcS m env + instance Applicative TcS where pure x = mkTcS $ \_ -> return x (<*>) = ap @@ -913,6 +914,9 @@ instance Monad TcS where instance MonadIO TcS where liftIO act = TcS $ \_env -> liftIO act +instance MonadFix TcS where + mfix k = TcS $ \env -> mfix (\x -> unTcS (k x) env) + instance MonadFail TcS where fail err = mkTcS $ \_ -> fail err @@ -2103,7 +2107,7 @@ checkTouchableTyVarEq ev lhs_tv rhs | simpleUnifyCheck True lhs_tv rhs -- True <=> type families are ok on the RHS = do { traceTcS "checkTouchableTyVarEq: simple-check wins" (ppr lhs_tv $$ ppr rhs) - ; return (pure (mkReflRedn Nominal rhs)) } + ; return (pure (mkReflRedn rhs)) } | otherwise = do { traceTcS "checkTouchableTyVarEq {" (ppr lhs_tv $$ ppr rhs) @@ -2165,8 +2169,8 @@ checkTouchableTyVarEq ev lhs_tv rhs , ctev_dest = HoleDest hole , ctev_loc = cb_loc , ctev_rewriters = ctEvRewriters ev } - ; return (PuOK (singleCt (mkNonCanonical new_ev)) - (mkReduction (HoleCo hole) new_tv_ty)) } } + redn = mkDehydrateCoercionRedn (HoleCo hole) + ; return (PuOK (singleCt (mkNonCanonical new_ev)) redn) } } -- See Detail (7) of the Note cb_loc = updateCtLocOrigin (ctEvLoc ev) CycleBreakerOrigin @@ -2231,7 +2235,7 @@ checkTypeEq ev eq_rel lhs rhs break_given fam_app = do { new_tv <- TcM.newCycleBreakerTyVar (typeKind fam_app) ; return (PuOK (unitBag (new_tv, fam_app)) - (mkReflRedn Nominal (mkTyVarTy new_tv))) } + (mkReflRedn (mkTyVarTy new_tv))) } -- Why reflexive? See Detail (4) of the Note --------------------------- diff --git a/compiler/GHC/Tc/Solver/Rewrite.hs b/compiler/GHC/Tc/Solver/Rewrite.hs index 64d590cbe9..6713019e35 100644 --- a/compiler/GHC/Tc/Solver/Rewrite.hs +++ b/compiler/GHC/Tc/Solver/Rewrite.hs @@ -1,5 +1,4 @@ {-# LANGUAGE BangPatterns #-} - {-# LANGUAGE DeriveFunctor #-} module GHC.Tc.Solver.Rewrite( @@ -56,7 +55,10 @@ import qualified GHC.Data.List.Infinite as Inf -- | The 'RewriteM' monad is a wrapper around 'TcS' with a 'RewriteEnv' newtype RewriteM a = RewriteM { runRewriteM :: RewriteEnv -> TcS a } - deriving (Functor) + +-- Use the one-shot trick for the functor instance of 'RewriteM'. +instance Functor RewriteM where + fmap f m = mkRewriteM $ \env -> fmap f $ runRewriteM m env -- | Smart constructor for 'RewriteM', as describe in Note [The one-shot state -- monad trick] in "GHC.Utils.Monad". @@ -92,11 +94,11 @@ runRewriteCtEv ev runRewrite :: CtLoc -> CtFlavour -> EqRel -> RewriteM a -> TcS (a, RewriterSet) runRewrite loc flav eq_rel thing_inside = do { rewriters_ref <- newTcRef emptyRewriterSet - ; let fmode = RE { re_loc = loc + ; let rmode = RE { re_loc = loc , re_flavour = flav , re_eq_rel = eq_rel , re_rewriters = rewriters_ref } - ; res <- runRewriteM thing_inside fmode + ; res <- runRewriteM thing_inside rmode ; rewriters <- readTcRef rewriters_ref ; return (res, rewriters) } @@ -212,16 +214,19 @@ a better error message anyway.) -} -- | See Note [Rewriting]. --- If (xi, co, rewriters) <- rewrite mode ev ty, then co :: xi ~r ty +-- If (Reduction ty' dco xi, rewriters) <- rewrite mode ev ty, then dco :: ty' ~r xi -- where r is the role in @ev@. --- rewriters is the set of coercion holes that have been used to rewrite +-- @rewriters@ is the set of coercion holes that have been used to rewrite -- See Note [Wanteds rewrite Wanteds] in GHC.Tc.Types.Constraint rewrite :: CtEvidence -> TcType -> TcS (Reduction, RewriterSet) rewrite ev ty = do { traceTcS "rewrite {" (ppr ty) ; result@(redn, _) <- runRewriteCtEv ev (rewrite_one ty) - ; traceTcS "rewrite }" (ppr $ reductionReducedType redn) + ; traceTcS "rewrite }" $ + vcat [ text "ty:" <+> ppr ty + , text "dco:" <+> ppr (reductionDCoercion redn) + , text "xi:" <+> ppr (reductionReducedType redn) ] ; return result } -- | See Note [Rewriting] @@ -238,7 +243,7 @@ rewriteForErrors ev ty ; traceTcS "rewriteForErrors }" (ppr $ reductionReducedType redn) ; return $ case ctEvEqRel ev of NomEq -> result - ReprEq -> (mkSubRedn redn, rewriters) } + ReprEq -> (mkSubRedn ty redn, rewriters) } -- See Note [Rewriting] rewriteArgsNom :: CtEvidence -> TyCon -> [TcType] @@ -254,11 +259,11 @@ rewriteArgsNom :: CtEvidence -> TyCon -> [TcType] -- Final return value returned which Wanteds rewrote another Wanted -- See Note [Wanteds rewrite Wanteds] in GHC.Tc.Types.Constraint rewriteArgsNom ev tc tys - = do { traceTcS "rewrite_args {" (vcat (map ppr tys)) - ; (ArgsReductions redns@(Reductions _ tys') kind_co, rewriters) + = do { traceTcS "rewriteArgsNom {" (vcat (map ppr tys)) + ; (ArgsReductions redns@(Reductions _ tys') kind_dco, rewriters) <- runRewriteCtEv ev (rewrite_args_tc tc Nothing tys) - ; massert (isReflMCo kind_co) - ; traceTcS "rewrite }" (vcat (map ppr tys')) + ; massert (isReflMCo kind_dco) + ; traceTcS "rewriteArgsNom }" (vcat (map ppr tys')) ; return (redns, rewriters) } -- | Rewrite a type w.r.t. nominal equality. This is useful to rewrite @@ -282,16 +287,16 @@ rewriteType loc ty ********************************************************************* -} {- Note [Rewriting] -~~~~~~~~~~~~~~~~~~~~ - rewrite ty ==> Reduction co xi +~~~~~~~~~~~~~~~~~~~ + rewrite ty (at role r) ==> Reduction ty' dco xi where xi has no reducible type functions has no skolems that are mapped in the inert set has no filled-in metavariables - co :: ty ~ xi (coercions in reductions are always left-to-right) + dco :: ty' ~r xi (coercions in reductions are always left-to-right) Key invariants: - (F0) co :: zonk(ty') ~ xi where zonk(ty') ~ zonk(ty) + (F0) dco :: zonk(ty') ~ xi where zonk(ty') ~ zonk(ty) (F1) typeKind(xi) succeeds and returns a fully zonked kind (F2) typeKind(xi) `eqType` zonk(typeKind(ty)) @@ -301,18 +306,11 @@ Rewriting also: * zonks, removing any metavariables, and * applies the substitution embodied in the inert set -Because rewriting zonks and the returned coercion ("co" above) is also -zonked, it's possible that (co :: ty ~ xi) isn't quite true. So, instead, +Because rewriting zonks and the returned directed coercion ("dco" above) +is also zonked, it's possible that (dco :: ty ~r xi) isn't quite true. So, instead, we can rely on this fact: - (F0) co :: zonk(ty') ~ xi, where zonk(ty') ~ zonk(ty) - -Note that the right-hand type of co is *always* precisely xi. The left-hand -type may or may not be ty, however: if ty has unzonked filled-in metavariables, -then the left-hand type of co will be the zonk-equal to ty. -It is for this reason that we occasionally have to explicitly zonk, -when (co :: ty ~ xi) is important even before we zonk the whole program. -For example, see the RTRNotFollowed case in rewriteTyVar. + (F0) dco :: ty' ~r xi, where zonk(ty') ~ zonk(ty) Why have these invariants on rewriting? Because we sometimes use typeKind during canonicalisation, and we want this kind to be zonked (e.g., see @@ -389,7 +387,7 @@ rewrite_args_tc -- Otherwise: no assumptions; use roles provided -> [Type] -> RewriteM ArgsReductions -- See the commentary on rewrite_args -rewrite_args_tc tc = rewrite_args all_bndrs any_named_bndrs inner_ki emptyVarSet +rewrite_args_tc tc roles args = rewrite_args all_bndrs any_named_bndrs inner_ki emptyVarSet roles args -- NB: TyCon kinds are always closed where -- There are many bang patterns in here. It's been observed that they @@ -459,7 +457,12 @@ rewrite_args_slow :: [PiTyBinder] -> Kind -> TcTyCoVarSet -> RewriteM ArgsReductions rewrite_args_slow binders inner_ki fvs roles tys = do { rewritten_args <- zipWithM rw (Inf.toList roles) tys - ; return (simplifyArgsWorker binders inner_ki fvs roles rewritten_args) } + -- NB: this is the crucial place where we require the hydration invariant + -- to be satisfied. This is achieved by having Reduction store a LHS type. + -- See Note [The Reduction type] in GHC.Core.Reduction, + -- and Note [Following a directed coercion] in GHC.Core.Coercion. + -- Relevant test case: T13333. + ; return $ simplifyArgsWorker binders inner_ki fvs roles tys rewritten_args } where {-# INLINE rw #-} rw :: Role -> Type -> RewriteM Reduction @@ -474,7 +477,7 @@ rewrite_args_slow binders inner_ki fvs roles tys rw Phantom ty -- See Note [Phantoms in the rewriter] = do { ty <- liftTcS $ zonkTcType ty - ; return $ mkReflRedn Phantom ty } + ; return $ mkReflRedn ty } ------------------ rewrite_one :: TcType -> RewriteM Reduction @@ -490,8 +493,7 @@ rewrite_one ty = rewrite_one ty' rewrite_one xi@(LitTy {}) - = do { role <- getRole - ; return $ mkReflRedn role xi } + = return $ mkReflRedn xi rewrite_one (TyVarTy tv) = rewriteTyVar tv @@ -518,28 +520,34 @@ rewrite_one (FunTy { ft_af = vis, ft_mult = mult, ft_arg = ty1, ft_res = ty2 }) ; let arg_rep = getRuntimeRep (reductionReducedType arg_redn) res_rep = getRuntimeRep (reductionReducedType res_redn) - ; (w_redn, arg_rep_redn, res_rep_redn) <- setEqRel NomEq $ - liftA3 (,,) (rewrite_one mult) - (rewrite_one arg_rep) - (rewrite_one res_rep) - ; role <- getRole + ; ( w_redn + , Reduction arg_rep_dco arg_rep_xi + , Reduction res_rep_dco res_rep_xi + ) <- setEqRel NomEq $ + liftA3 (,,) (rewrite_one mult) + (rewrite_one arg_rep) + (rewrite_one res_rep) - ; let arg_rep_co = reductionCoercion arg_rep_redn + ; let arg_rep_co = mkHydrateDCo Nominal arg_rep arg_rep_dco arg_rep_xi -- :: arg_rep ~ arg_rep_xi arg_ki_co = mkTyConAppCo Nominal tYPETyCon [arg_rep_co] -- :: TYPE arg_rep ~ TYPE arg_rep_xi - casted_arg_redn = mkCoherenceRightRedn role arg_redn arg_ki_co + casted_arg_redn = mkCoherenceRightRedn arg_redn arg_ki_co -- :: ty1 ~> arg_xi |> arg_ki_co - res_rep_co = reductionCoercion res_rep_redn + res_rep_co = mkHydrateDCo Nominal res_rep res_rep_dco res_rep_xi res_ki_co = mkTyConAppCo Nominal tYPETyCon [res_rep_co] - casted_res_redn = mkCoherenceRightRedn role res_redn res_ki_co + casted_res_redn = mkCoherenceRightRedn res_redn res_ki_co + + -- NB: these two calls to mkHydrateDCo are OK, because of the invariant + -- on the LHS type stored in a Reduction. See Note [The Reduction type] + -- in GHC.Core.Reduction. -- We must rewrite the representations, because that's what would -- be done if we used TyConApp instead of FunTy. These rewritten -- representations are seen only in casts of the arg and res, below. -- Forgetting this caused #19677. - ; return $ mkFunRedn role vis w_redn casted_arg_redn casted_res_redn } + ; return $ mkFunRedn vis w_redn arg_rep_dco res_rep_dco casted_arg_redn casted_res_redn } rewrite_one ty@(ForAllTy {}) -- TODO (RAE): This is inadequate, as it doesn't rewrite the kind of @@ -550,13 +558,12 @@ rewrite_one ty@(ForAllTy {}) -- applications inside the forall involve the bound type variables. = do { let (bndrs, rho) = tcSplitForAllTyVarBinders ty ; redn <- rewrite_one rho - ; return $ mkHomoForAllRedn bndrs redn } + ; return $ mkHomoForAllRedn bndrs rho redn } rewrite_one (CastTy ty g) = do { redn <- rewrite_one ty ; g' <- rewrite_co g - ; role <- getRole - ; return $ mkCastRedn1 role ty g' redn } + ; return $ mkCastRedn1 g' redn } -- This calls castCoercionKind1. -- It makes a /big/ difference to call castCoercionKind1 not -- the more general castCoercionKind2. @@ -564,8 +571,7 @@ rewrite_one (CastTy ty g) rewrite_one (CoercionTy co) = do { co' <- rewrite_co co - ; role <- getRole - ; return $ mkReflCoRedn role co' } + ; return $ mkReflCoRedn co' } -- | "Rewrite" a coercion. Really, just zonk it so we can uphold -- (F1) of Note [Rewriting] @@ -574,9 +580,9 @@ rewrite_co co = liftTcS $ zonkCo co -- | Rewrite a reduction, composing the resulting coercions. rewrite_reduction :: Reduction -> RewriteM Reduction -rewrite_reduction (Reduction co xi) +rewrite_reduction redn0@(Reduction _ xi) = do { redn <- bumpDepth $ rewrite_one xi - ; return $ co `mkTransRedn` redn } + ; return $ redn0 `mkTransRedn` redn } -- rewrite (nested) AppTys rewrite_app_tys :: Type -> [Type] -> RewriteM Reduction @@ -598,44 +604,38 @@ rewrite_app_ty_args :: Reduction -> [Type] -> RewriteM Reduction rewrite_app_ty_args redn [] -- this will be a common case when called from rewrite_fam_app, so shortcut = return redn -rewrite_app_ty_args fun_redn@(Reduction fun_co fun_xi) arg_tys - = do { het_redn <- case tcSplitTyConApp_maybe fun_xi of - Just (tc, xis) -> - do { let tc_roles = tyConRolesRepresentational tc - arg_roles = Inf.dropList xis tc_roles - ; ArgsReductions (Reductions arg_cos arg_xis) kind_co - <- rewrite_vector (typeKind fun_xi) arg_roles arg_tys - - -- We start with a reduction of the form - -- fun_co :: ty ~ T xi_1 ... xi_n - -- and further arguments a_1, ..., a_m. - -- We rewrite these arguments, and obtain coercions: - -- arg_co_i :: a_i ~ zeta_i - -- Now, we need to apply fun_co to the arg_cos. The problem is - -- that using mkAppCo is wrong because that function expects - -- its second coercion to be Nominal, and the arg_cos might - -- not be. The solution is to use transitivity: - -- fun_co <a_1> ... <a_m> ;; T <xi_1> .. <xi_n> arg_co_1 ... arg_co_m - ; eq_rel <- getEqRel - ; let app_xi = mkTyConApp tc (xis ++ arg_xis) - app_co = case eq_rel of - NomEq -> mkAppCos fun_co arg_cos - ReprEq -> mkAppCos fun_co (map mkNomReflCo arg_tys) - `mkTransCo` - mkTyConAppCo Representational tc - (zipWith mkReflCo (Inf.toList tc_roles) xis ++ arg_cos) - - ; return $ - mkHetReduction - (mkReduction app_co app_xi ) - kind_co } - Nothing -> - do { ArgsReductions redns kind_co - <- rewrite_vector (typeKind fun_xi) (Inf.repeat Nominal) arg_tys - ; return $ mkHetReduction (mkAppRedns fun_redn redns) kind_co } - - ; role <- getRole - ; return (homogeniseHetRedn role het_redn) } +rewrite_app_ty_args fun_redn@(Reduction fun_co fun_xi) more_arg_tys + = case tcSplitTyConApp_maybe fun_xi of + Just (tc, xis) -> + do { let tc_roles = tyConRolesRepresentational tc + arg_roles = Inf.dropList xis tc_roles + ; ArgsReductions (Reductions arg_cos arg_xis) kind_co + <- rewrite_vector (typeKind fun_xi) arg_roles more_arg_tys + + -- We start with a reduction of the form + -- fun_co :: ty ~ T xi_1 ... xi_n + -- and further arguments a_1, ..., a_m. + -- We rewrite these arguments, and obtain coercions: + -- arg_co_i :: a_i ~ zeta_i + -- Now, we need to apply fun_co to the arg_cos. The problem is + -- that using mkAppCo is wrong because that function expects + -- its second coercion to be Nominal, and the arg_cos might + -- not be. The solution is to use transitivity: + -- fun_co <a_1> ... <a_m> ;; T <xi_1> .. <xi_n> arg_co_1 ... arg_co_m + + ; eq_rel <- getEqRel + ; let app_xi = mkTyConApp tc (xis ++ arg_xis) + app_co = case eq_rel of + NomEq -> mkAppDCos fun_co arg_cos + ReprEq -> mkAppDCos fun_co (mkReflDCos more_arg_tys) + `mkTransDCo` + mkTyConAppDCo (mkReflDCos xis ++ arg_cos) + + ; return $ homogeniseRedn (mkReduction app_co app_xi) kind_co } + Nothing -> + do { ArgsReductions redns kind_co + <- rewrite_vector (typeKind fun_xi) (Inf.repeat Nominal) more_arg_tys + ; return $ homogeniseRedn (mkAppRedns fun_redn redns) kind_co } rewrite_ty_con_app :: TyCon -> [TcType] -> RewriteM Reduction rewrite_ty_con_app tc tys @@ -643,11 +643,10 @@ rewrite_ty_con_app tc tys ; let m_roles | Nominal <- role = Nothing | otherwise = Just $ tyConRolesX role tc ; ArgsReductions redns kind_co <- rewrite_args_tc tc m_roles tys - ; let tyconapp_redn - = mkHetReduction - (mkTyConAppRedn role tc redns) - kind_co - ; return $ homogeniseHetRedn role tyconapp_redn } + ; return $ homogeniseRedn + (mkTyConAppRedn_MightBeSynonym role tc tys redns) + kind_co } +{-# INLINE rewrite_ty_con_app #-} -- Rewrite a vector (list of arguments). rewrite_vector :: Kind -- of the function being applied to these arguments @@ -758,8 +757,8 @@ STEP 5: GIVEUP. No progress to be made. Return what we have. (Do not FINISH.) FINISH 1. We've made a reduction, but the new type may still have more work to do. So rewrite the new type. -FINISH 2. Add the result to the famapp-cache, connecting the type we started - with to the one we ended with. +FINISH 2. Add the result to the famapp-cache, to speed things up next time we + come across the same type family application. Because STEP 1{a,b,c} and STEP 4{a,b,c} happen the same way, they are abstracted into try_to_reduce. @@ -773,7 +772,6 @@ is inlined in that case, and only FINISH 1 is performed. rewrite_fam_app :: TyCon -> [TcType] -> RewriteM Reduction -- rewrite_fam_app can be over-saturated -- rewrite_exact_fam_app lifts out the application to top level - -- Postcondition: Coercion :: Xi ~ F tys rewrite_fam_app tc tys -- Can be over-saturated = assertPpr (tys `lengthAtLeast` tyConArity tc) (ppr tc $$ ppr (tyConArity tc) $$ ppr tys) $ @@ -782,15 +780,17 @@ rewrite_fam_app tc tys -- Can be over-saturated -- The type function might be *over* saturated -- in which case the remaining arguments should -- be dealt with by AppTys - do { let (tys1, tys_rest) = splitAt (tyConArity tc) tys - ; redn <- rewrite_exact_fam_app tc tys1 + do { let (!tys1, !tys_rest) + | length tys > tyConArity tc = splitAt (tyConArity tc) tys + | otherwise = (tys, []) + ; !redn <- rewrite_exact_fam_app tc tys1 ; rewrite_app_ty_args redn tys_rest } -- the [TcType] exactly saturate the TyCon -- See Note [How to normalise a family application] rewrite_exact_fam_app :: TyCon -> [TcType] -> RewriteM Reduction rewrite_exact_fam_app tc tys - = do { checkStackDepth (mkTyConApp tc tys) + = do { checkStackDepth $ mkTyConApp tc tys -- Query the typechecking plugins for all their rewriting functions -- which apply to a type family application headed by the TyCon 'tc'. @@ -801,17 +801,12 @@ rewrite_exact_fam_app tc tys ; case result1 of -- Don't use the cache; -- See Note [rewrite_exact_fam_app performance] - { Just redn -> finish False redn + { Just redn -> finish Don'tAddToCache redn ; Nothing -> -- That didn't work. So reduce the arguments, in STEP 2. - do { eq_rel <- getEqRel - -- checking eq_rel == NomEq saves ~0.5% in T9872a - ; ArgsReductions (Reductions cos xis) kind_co <- - if eq_rel == NomEq - then rewrite_args_tc tc Nothing tys - else setEqRel NomEq $ - rewrite_args_tc tc Nothing tys + do { (ArgsReductions redns@(Reductions _ xis) kind_co) <- + setEqRel NomEq $ rewrite_args_tc tc Nothing tys -- If we manage to rewrite the type family application after -- rewriting the arguments, we will need to compose these @@ -826,63 +821,86 @@ rewrite_exact_fam_app tc tys -- -- full_co :: F ty_1 ... ty_n ~ zeta -- full_co = F co_1 ... co_n ;; fam_co - ; let - role = eqRelRole eq_rel - args_co = mkTyConAppCo role tc cos - ; let homogenise :: Reduction -> Reduction - homogenise redn - = homogeniseHetRedn role - $ mkHetReduction - (args_co `mkTransRedn` redn) - kind_co - - give_up :: Reduction - give_up = homogenise $ mkReflRedn role reduced - where reduced = mkTyConApp tc xis + ; let args_redn :: Reduction + !args_redn = mkTyConAppRedn tc redns + homogenise :: Reduction -> Reduction + homogenise redn + = homogeniseRedn + (args_redn `mkTransRedn` redn) + kind_co + + give_up :: Reduction + give_up = homogenise $ mkReflRedn reduced + where reduced = mkTyConApp tc xis -- STEP 3: try the inerts - ; flavour <- getFlavour - ; result2 <- liftTcS $ lookupFamAppInert (`eqCanRewriteFR` (flavour, eq_rel)) tc xis + ; flavour_role@(_, eq_rel) <- getFlavourRole + ; result2 <- liftTcS $ lookupFamAppInert (`eqCanRewriteFR` flavour_role) tc xis ; case result2 of - { Just (redn, (inert_flavour, inert_eq_rel)) - -> do { traceRewriteM "rewrite family application with inert" - (ppr tc <+> ppr xis $$ ppr redn) - ; finish (inert_flavour == Given) (homogenise downgraded_redn) } - -- this will sometimes duplicate an inert in the cache, - -- but avoiding doing so had no impact on performance, and - -- it seems easier not to weed out that special case + { Just (redn, (inert_flavour, inert_eq_rel)) -> + do { traceRewriteM "rewrite family application with inert" $ + ( ppr tc <+> ppr xis $$ ppr redn) + ; let use_cache :: AddToCache + !use_cache + -- Don't add something to the cache if the reduction + -- contains a coercion hole. + | inert_flavour == Given + = RewroteArgsAddToCache + | otherwise + = Don'tAddToCache + ; finish use_cache (homogenise downgraded_redn) } where inert_role = eqRelRole inert_eq_rel role = eqRelRole eq_rel - downgraded_redn = downgradeRedn role inert_role redn + !downgraded_redn + | inert_role == Nominal && role == Representational + = mkSubRedn (mkTyConApp tc xis) redn + | otherwise + = redn ; _ -> -- inerts didn't work. Try to reduce again, in STEP 4. do { result3 <- try_to_reduce tc xis tc_rewriters ; case result3 of - Just redn -> finish True (homogenise redn) + Just redn -> finish RewroteArgsAddToCache (homogenise redn) -- we have made no progress at all: STEP 5 (GIVEUP). _ -> return give_up }}}}} where -- call this if the above attempts made progress. -- This recursively rewrites the result and then adds to the cache - finish :: Bool -- add to the cache? - -- Precondition: True ==> input coercion has - -- no coercion holes - -> Reduction -> RewriteM Reduction + finish :: AddToCache -- Add to the cache? + -> Reduction -- Precondition: we can only add to the cache a 'Reduction' + -- which does not have any coercion holes. + -> RewriteM Reduction finish use_cache redn = do { -- rewrite the result: FINISH 1 final_redn <- rewrite_reduction redn - ; eq_rel <- getEqRel - + ; case use_cache of + { Don'tAddToCache {} -> return final_redn + ; RewroteArgsAddToCache -> -- extend the cache: FINISH 2 - ; when (use_cache && eq_rel == NomEq) $ - -- the cache only wants Nominal eqs - liftTcS $ extendFamAppCache tc tys final_redn - ; return final_redn } + do { eq_rel <- getEqRel + ; when (eq_rel == NomEq) $ + -- the cache only wants Nominal eqs + liftTcS $ extendFamAppCache tc tys final_redn + -- This will sometimes duplicate an inert in the cache, + -- but avoiding doing so had no impact on performance, and + -- it seems easier not to weed out that special case. + ; return final_redn } } } {-# INLINE finish #-} +-- | How to finish rewriting an exact type family application, +-- depending on whether we have rewritten the arguments or not. +data AddToCache + -- | We didn't rewrite the arguments: don't add to the cache. + -- + -- See Note [rewrite_exact_fam_app performance]. + = Don'tAddToCache + -- | We rewrote the arguments. We add the type family application, + -- with rewritten arguments, to the cache. + | RewroteArgsAddToCache + -- Returned coercion is input ~r output, where r is the role in the RewriteM monad -- See Note [How to normalise a family application] try_to_reduce :: TyCon -> [TcType] -> [TcPluginRewriter] @@ -894,23 +912,23 @@ try_to_reduce tc tys tc_rewriters [ runTcPluginRewriters rewrite_env tc_rewriters tys -- STEP 1a & STEP 4a , lookupFamAppCache tc tys -- STEP 1b & STEP 4b , matchFam tc tys ] -- STEP 1c & STEP 4c - ; traverse downgrade result } + ; traverse finish result } where -- The result above is always Nominal. We might want a Representational -- coercion; this downgrades (and prints, out of convenience). - downgrade :: Reduction -> RewriteM Reduction - downgrade redn + finish :: Reduction -> RewriteM Reduction + finish redn = do { traceRewriteM "Eager T.F. reduction success" $ - vcat [ ppr tc - , ppr tys - , ppr redn - ] + vcat [ ppr tc + , ppr tys + , ppr redn + ] ; eq_rel <- getEqRel -- manually doing it this way avoids allocation in the vastly -- common NomEq case ; case eq_rel of NomEq -> return redn - ReprEq -> return $ mkSubRedn redn } + ReprEq -> return $ mkSubRedn (mkTyConApp tc tys) redn } -- Retrieve all type-checking plugins that can rewrite a (saturated) type-family application -- headed by the given 'TyCon`. @@ -959,11 +977,17 @@ runTcPluginRewriters rewriteEnv rewriterFunctions tys -- | The result of rewriting a tyvar "one step". data RewriteTvResult = RTRNotFollowed - -- ^ The inert set doesn't make the tyvar equal to anything else + -- ^ Not a filled metavariable, and the inert set doesn't make + -- the tyvar equal to anything else. - | RTRFollowed !Reduction - -- ^ The tyvar rewrites to a not-necessarily rewritten other type. - -- The role is determined by the RewriteEnv. + | RTRFollowedMeta !TcType + -- ^ We followed a filled metavariable to the given type, + -- which has not yet been rewritten. + + | RTRFollowedInert !Reduction + -- ^ The tyvar rewrites to a not-necessarily rewritten other type, + -- using an inert equality; this rewriting is stored in a + -- 'Reduction'. -- -- With Quick Look, the returned TcType can be a polytype; -- that is, in the constraint solver, a unification variable @@ -974,14 +998,13 @@ rewriteTyVar :: TyVar -> RewriteM Reduction rewriteTyVar tv = do { mb_yes <- rewrite_tyvar1 tv ; case mb_yes of - RTRFollowed redn -> rewrite_reduction redn - + RTRFollowedMeta ty -> rewrite_one ty + RTRFollowedInert redn -> rewrite_reduction redn RTRNotFollowed -- Done, but make sure the kind is zonked -- Note [Rewriting] invariant (F0) and (F1) -> do { tv' <- liftTcS $ updateTyVarKindM zonkTcType tv - ; role <- getRole ; let ty' = mkTyVarTy tv' - ; return $ mkReflRedn role ty' } } + ; return $ mkReflRedn ty' } } rewrite_tyvar1 :: TcTyVar -> RewriteM RewriteTvResult -- "Rewriting" a type variable means to apply the substitution to it @@ -995,9 +1018,7 @@ rewrite_tyvar1 tv ; case mb_ty of Just ty -> do { traceRewriteM "Following filled tyvar" (ppr tv <+> equals <+> ppr ty) - ; role <- getRole - ; return $ RTRFollowed $ - mkReflRedn role ty } + ; return $ RTRFollowedMeta ty } Nothing -> do { traceRewriteM "Unfilled tyvar" (pprTyVar tv) ; fr <- getFlavourRole ; rewrite_tyvar2 tv fr } } @@ -1022,20 +1043,21 @@ rewrite_tyvar2 tv fr@(_, eq_rel) , text "wanted_rewrite_wanted:" <+> ppr wrw ] ; when wrw $ recordRewriter ctev - ; let rewriting_co1 = ctEvCoercion ctev - rewriting_co = case (ct_eq_rel, eq_rel) of + ; let rewriting_dco1 = mkDehydrateCo $ ctEvCoercion ctev + rewriting_dco = case (ct_eq_rel, eq_rel) of (ReprEq, _rel) -> assert (_rel == ReprEq) -- if this assert fails, then -- eqCanRewriteFR answered incorrectly - rewriting_co1 - (NomEq, NomEq) -> rewriting_co1 - (NomEq, ReprEq) -> mkSubCo rewriting_co1 + rewriting_dco1 + (NomEq, NomEq) -> rewriting_dco1 + (NomEq, ReprEq) -> mkSubDCo lhs_ty rewriting_dco1 rhs_ty - ; return $ RTRFollowed $ mkReduction rewriting_co rhs_ty } + ; return $ RTRFollowedInert $ mkReduction rewriting_dco rhs_ty } _other -> return RTRNotFollowed } - where + lhs_ty :: TcType + lhs_ty = mkTyVarTy tv can_rewrite :: EqCt -> Bool can_rewrite ct = eqCtFlavourRole ct `eqCanRewriteFR` fr -- This is THE key call of eqCanRewriteFR diff --git a/compiler/GHC/Tc/TyCl/Utils.hs b/compiler/GHC/Tc/TyCl/Utils.hs index 8e7b3b8c39..56d6710872 100644 --- a/compiler/GHC/Tc/TyCl/Utils.hs +++ b/compiler/GHC/Tc/TyCl/Utils.hs @@ -40,7 +40,7 @@ import GHC.Builtin.Uniques ( mkBuiltinUnique ) import GHC.Hs -import GHC.Core.TyCo.Rep( Type(..), Coercion(..), MCoercion(..), UnivCoProvenance(..) ) +import GHC.Core.TyCo.Rep( Type(..), Coercion(..), MCoercion(..), DCoercion(..), UnivCoProvenance(..) ) import GHC.Core.Multiplicity import GHC.Core.Predicate import GHC.Core.Make( rEC_SEL_ERROR_ID ) @@ -143,7 +143,8 @@ synonymTyConsOfType ty go_co (CoVarCo _) = emptyNameEnv go_co (HoleCo {}) = emptyNameEnv go_co (AxiomInstCo _ _ cs) = go_co_s cs - go_co (UnivCo p _ ty ty') = go_prov p `plusNameEnv` go ty `plusNameEnv` go ty' + go_co (HydrateDCo _ ty dco _)= go ty `plusNameEnv` go_dco dco + go_co (UnivCo p _ ty ty') = go_prov go_co p `plusNameEnv` go ty `plusNameEnv` go ty' go_co (SymCo co) = go_co co go_co (TransCo co co') = go_co co `plusNameEnv` go_co co' go_co (SelCo _ co) = go_co co @@ -153,15 +154,30 @@ synonymTyConsOfType ty go_co (SubCo co) = go_co co go_co (AxiomRuleCo _ cs) = go_co_s cs - go_prov (PhantomProv co) = go_co co - go_prov (ProofIrrelProv co) = go_co co - go_prov (PluginProv _) = emptyNameEnv - go_prov (CorePrepProv _) = emptyNameEnv + go_dco ReflDCo = emptyNameEnv + go_dco (GReflRightDCo co) = go_co co + go_dco (GReflLeftDCo co) = go_co co + go_dco (TyConAppDCo cs) = go_dco_s cs + go_dco (AppDCo co co') = go_dco co `plusNameEnv` go_dco co' + go_dco (ForAllDCo _ dco dco') = go_dco dco `plusNameEnv` go_dco dco' + go_dco (CoVarDCo _) = emptyNameEnv + go_dco AxiomInstDCo{} = emptyNameEnv + go_dco StepsDCo{} = emptyNameEnv + go_dco (TransDCo co1 co2) = go_dco co1 `plusNameEnv` go_dco co2 + go_dco (DehydrateCo co) = go_co co + go_dco (UnivDCo prov rhs) = go_prov go_dco prov `plusNameEnv` go rhs + go_dco (SubDCo dco) = go_dco dco + + go_prov syns (PhantomProv co) = syns co + go_prov syns (ProofIrrelProv co) = syns co + go_prov _ (PluginProv _) = emptyNameEnv + go_prov _ (CorePrepProv _) = emptyNameEnv go_tc tc | isTypeSynonymTyCon tc = unitNameEnv (tyConName tc) tc | otherwise = emptyNameEnv go_s tys = foldr (plusNameEnv . go) emptyNameEnv tys go_co_s cos = foldr (plusNameEnv . go_co) emptyNameEnv cos + go_dco_s dcos = foldr (plusNameEnv . go_dco) emptyNameEnv dcos -- | A monad for type synonym cycle checking, which keeps -- track of the TyCons which are known to be acyclic, or diff --git a/compiler/GHC/Tc/Types.hs b/compiler/GHC/Tc/Types.hs index 28668b7979..033327912d 100644 --- a/compiler/GHC/Tc/Types.hs +++ b/compiler/GHC/Tc/Types.hs @@ -293,8 +293,8 @@ data RewriteEnv -- ^ At what role are we rewriting? -- -- See Note [Rewriter EqRels] in GHC.Tc.Solver.Rewrite - - , re_rewriters :: !(TcRef RewriterSet) -- ^ See Note [Wanteds rewrite Wanteds] + , re_rewriters :: !(TcRef RewriterSet) + -- ^ See Note [Wanteds rewrite Wanteds] } -- RewriteEnv is mostly used in @GHC.Tc.Solver.Rewrite@, but it is defined -- here so that it can also be passed to rewriting plugins. diff --git a/compiler/GHC/Tc/Types/Evidence.hs b/compiler/GHC/Tc/Types/Evidence.hs index 4216613c4a..dbbe74faff 100644 --- a/compiler/GHC/Tc/Types/Evidence.hs +++ b/compiler/GHC/Tc/Types/Evidence.hs @@ -40,6 +40,7 @@ module GHC.Tc.Types.Evidence ( -- * TcCoercion TcCoercion, TcCoercionR, TcCoercionN, TcCoercionP, CoercionHole, TcMCoercion, TcMCoercionN, TcMCoercionR, + TcDCoercion, Role(..), LeftOrRight(..), pickLR, maybeSymCo, unwrapIP, wrapIP, @@ -109,6 +110,7 @@ type TcCoercionP = CoercionP -- a phantom coercion type TcMCoercion = MCoercion type TcMCoercionN = MCoercionN -- nominal type TcMCoercionR = MCoercionR -- representational +type TcDCoercion = DCoercion -- | If a 'SwapFlag' is 'IsSwapped', flip the orientation of a coercion maybeSymCo :: SwapFlag -> TcCoercion -> TcCoercion diff --git a/compiler/GHC/Tc/Utils/TcMType.hs b/compiler/GHC/Tc/Utils/TcMType.hs index 7db80cfccb..0e3e75ec38 100644 --- a/compiler/GHC/Tc/Utils/TcMType.hs +++ b/compiler/GHC/Tc/Utils/TcMType.hs @@ -79,7 +79,7 @@ module GHC.Tc.Utils.TcMType ( zonkTyCoVarsAndFV, zonkTcTypeAndFV, zonkDTyCoVarSetAndFV, zonkTyCoVarsAndFVList, - zonkTcType, zonkTcTypes, zonkCo, + zonkTcType, zonkTcTypes, zonkCo, zonkCtEvidence, zonkTyCoVarKind, zonkEvVar, zonkWC, zonkImplication, zonkSimples, zonkId, zonkCoVar, @@ -404,7 +404,7 @@ unpackCoercionHole_maybe (CoercionHole { ch_ref = ref }) = readTcRef ref -- itself is needed only for printing.) -- Always returns the checked coercion, but this return value is necessary -- so that the input coercion is forced only when the output is forced. -checkCoercionHole :: CoVar -> Coercion -> TcM Coercion +checkCoercionHole :: HasDebugCallStack => CoVar -> Coercion -> TcM Coercion checkCoercionHole cv co | debugIsOn = do { cv_ty <- zonkTcType (varType cv) @@ -412,8 +412,10 @@ checkCoercionHole cv co ; return $ assertPpr (ok cv_ty) (text "Bad coercion hole" <+> - ppr cv <> colon <+> vcat [ ppr t1, ppr t2, ppr role - , ppr cv_ty ]) + ppr cv <> colon <+> vcat [ text "t1:" <+> ppr t1 + , text "t2:" <+> ppr t2 + , text "role:" <+> ppr role + , text "cv_ty:" <+> ppr cv_ty ]) co } | otherwise = return co @@ -1542,26 +1544,43 @@ collect_cand_qtvs_co :: TcType -- original type at top of recursion; for errors -> VarSet -- bound variables -> CandidatesQTvs -> Coercion -> TcM CandidatesQTvs -collect_cand_qtvs_co orig_ty cur_lvl bound = go_co +collect_cand_qtvs_co orig_ty cur_lvl bound dv = fst $ collect_cand_qtvs_co_dco orig_ty cur_lvl bound dv + +collect_cand_qtvs_dco :: TcType -- original type at top of recursion; for errors + -> TcLevel + -> VarSet -- bound variables + -> CandidatesQTvs -> DCoercion + -> TcM CandidatesQTvs +collect_cand_qtvs_dco orig_ty cur_lvl bound dv = snd $ collect_cand_qtvs_co_dco orig_ty cur_lvl bound dv + +collect_cand_qtvs_co_dco :: TcType -- original type at top of recursion; for errors + -> TcLevel + -> VarSet -- bound variables + -> CandidatesQTvs + -> (Coercion -> TcM CandidatesQTvs, DCoercion -> TcM CandidatesQTvs) +collect_cand_qtvs_co_dco orig_ty cur_lvl bound dv = (go_co dv, go_dco dv) where - go_co dv (Refl ty) = collect_cand_qtvs orig_ty True cur_lvl bound dv ty - go_co dv (GRefl _ ty mco) = do { dv1 <- collect_cand_qtvs orig_ty True cur_lvl bound dv ty - ; go_mco dv1 mco } - go_co dv (TyConAppCo _ _ cos) = foldlM go_co dv cos - go_co dv (AppCo co1 co2) = foldlM go_co dv [co1, co2] + go_co :: CandidatesQTvs -> Coercion -> TcM CandidatesQTvs + go_co dv (Refl ty) = collect_cand_qtvs orig_ty True cur_lvl bound dv ty + go_co dv (GRefl _ ty mco) = do dv1 <- collect_cand_qtvs orig_ty True cur_lvl bound dv ty + go_mco dv1 mco + go_co dv (TyConAppCo _ _ cos) = foldlM go_co dv cos + go_co dv (AppCo co1 co2) = foldlM go_co dv [co1, co2] go_co dv (FunCo _ _ _ w co1 co2) = foldlM go_co dv [w, co1, co2] - go_co dv (AxiomInstCo _ _ cos) = foldlM go_co dv cos - go_co dv (AxiomRuleCo _ cos) = foldlM go_co dv cos - go_co dv (UnivCo prov _ t1 t2) = do { dv1 <- go_prov dv prov - ; dv2 <- collect_cand_qtvs orig_ty True cur_lvl bound dv1 t1 - ; collect_cand_qtvs orig_ty True cur_lvl bound dv2 t2 } - go_co dv (SymCo co) = go_co dv co - go_co dv (TransCo co1 co2) = foldlM go_co dv [co1, co2] - go_co dv (SelCo _ co) = go_co dv co - go_co dv (LRCo _ co) = go_co dv co - go_co dv (InstCo co1 co2) = foldlM go_co dv [co1, co2] - go_co dv (KindCo co) = go_co dv co - go_co dv (SubCo co) = go_co dv co + go_co dv (AxiomInstCo _ _ cos) = foldlM go_co dv cos + go_co dv (AxiomRuleCo _ cos) = foldlM go_co dv cos + go_co dv (HydrateDCo _ t1 dco _) = do dv1 <- collect_cand_qtvs orig_ty True cur_lvl bound dv t1 + go_dco dv1 dco + go_co dv (UnivCo prov _ t1 t2) = do dv1 <- go_prov go_co dv prov + dv2 <- collect_cand_qtvs orig_ty True cur_lvl bound dv1 t1 + collect_cand_qtvs orig_ty True cur_lvl bound dv2 t2 + go_co dv (SymCo co) = go_co dv co + go_co dv (TransCo co1 co2) = foldlM go_co dv [co1, co2] + go_co dv (SelCo _ co) = go_co dv co + go_co dv (LRCo _ co) = go_co dv co + go_co dv (InstCo co1 co2) = foldlM go_co dv [co1, co2] + go_co dv (KindCo co) = go_co dv co + go_co dv (SubCo co) = go_co dv co go_co dv (HoleCo hole) = do m_co <- unpackCoercionHole_maybe hole @@ -1575,13 +1594,33 @@ collect_cand_qtvs_co orig_ty cur_lvl bound = go_co = do { dv1 <- go_co dv kind_co ; collect_cand_qtvs_co orig_ty cur_lvl (bound `extendVarSet` tcv) dv1 co } + go_dco :: CandidatesQTvs -> DCoercion -> TcM CandidatesQTvs + go_dco dv ReflDCo = return dv + go_dco dv (GReflRightDCo co) = go_co dv co + go_dco dv (GReflLeftDCo co) = go_co dv co + go_dco dv (TyConAppDCo cos) = foldlM go_dco dv cos + go_dco dv (AppDCo co1 co2) = foldlM go_dco dv [co1, co2] + go_dco dv AxiomInstDCo{} = return dv + go_dco dv StepsDCo{} = return dv + go_dco dv (TransDCo co1 co2) = foldlM go_dco dv [co1, co2] + go_dco dv (CoVarDCo cv) = go_cv dv cv + + go_dco dv (ForAllDCo tcv kind_dco co) + = do { dv1 <- go_dco dv kind_dco + ; collect_cand_qtvs_dco orig_ty cur_lvl (bound `extendVarSet` tcv) dv1 co } + + go_dco dv (DehydrateCo co) = go_co dv co + go_dco dv (UnivDCo prov rhs) = do dv1 <- go_prov go_dco dv prov + collect_cand_qtvs orig_ty True cur_lvl bound dv1 rhs + go_dco dv (SubDCo dco) = go_dco dv dco + go_mco dv MRefl = return dv go_mco dv (MCo co) = go_co dv co - go_prov dv (PhantomProv co) = go_co dv co - go_prov dv (ProofIrrelProv co) = go_co dv co - go_prov dv (PluginProv _) = return dv - go_prov dv (CorePrepProv _) = return dv + go_prov collect dv (PhantomProv co) = collect dv co + go_prov collect dv (ProofIrrelProv co) = collect dv co + go_prov _ dv (PluginProv _) = return dv + go_prov _ dv (CorePrepProv _) = return dv go_cv :: CandidatesQTvs -> CoVar -> TcM CandidatesQTvs go_cv dv@(DV { dv_cvs = cvs }) cv @@ -2831,7 +2870,7 @@ zonkRewriterSet (RewriterSet set) check_ty :: Type -> UnfilledCoercionHoleMonoid check_co :: Coercion -> UnfilledCoercionHoleMonoid - (check_ty, _, check_co, _) = foldTyCo folder () + (check_ty, _, check_co, _, _, _) = foldTyCo folder () folder :: TyCoFolder () UnfilledCoercionHoleMonoid folder = TyCoFolder { tcf_view = noView diff --git a/compiler/GHC/Tc/Utils/TcType.hs b/compiler/GHC/Tc/Utils/TcType.hs index ae25678600..223caa961c 100644 --- a/compiler/GHC/Tc/Utils/TcType.hs +++ b/compiler/GHC/Tc/Utils/TcType.hs @@ -1088,7 +1088,7 @@ exactTyCoVarsOfTypes tys = runTyCoVars (exact_tys tys) exact_ty :: Type -> Endo TyCoVarSet exact_tys :: [Type] -> Endo TyCoVarSet -(exact_ty, exact_tys, _, _) = foldTyCo exactTcvFolder emptyVarSet +(exact_ty, exact_tys, _, _, _, _) = foldTyCo exactTcvFolder emptyVarSet exactTcvFolder :: TyCoFolder TyCoVarSet (Endo TyCoVarSet) exactTcvFolder = deepTcvFolder { tcf_view = coreView } diff --git a/compiler/GHC/Tc/Utils/Unify.hs b/compiler/GHC/Tc/Utils/Unify.hs index 428eba5d69..c030993b6c 100644 --- a/compiler/GHC/Tc/Utils/Unify.hs +++ b/compiler/GHC/Tc/Utils/Unify.hs @@ -2685,7 +2685,7 @@ mkOccFolders :: TcTyVar -> (TcType -> Bool, TcCoercion -> Bool) -- No expansion of type synonyms mkOccFolders lhs_tv = (getAny . check_ty, getAny . check_co) where - !(check_ty, _, check_co, _) = foldTyCo occ_folder emptyVarSet + !(check_ty, _, check_co, _, _check_dco, _) = foldTyCo occ_folder emptyVarSet occ_folder = TyCoFolder { tcf_view = noView -- Don't expand synonyms , tcf_tyvar = do_tcv, tcf_covar = do_tcv , tcf_hole = do_hole @@ -2786,7 +2786,7 @@ pprPur (PuFail prob) = text "PuFail:" <> ppr prob pprPur (PuOK {}) = text "PuOK" okCheckRefl :: TcType -> TcM (PuResult a Reduction) -okCheckRefl ty = return (PuOK emptyBag (mkReflRedn Nominal ty)) +okCheckRefl ty = return (PuOK emptyBag (mkReflRedn ty)) failCheckWith :: CheckTyEqResult -> TcM (PuResult a b) failCheckWith p = return (PuFail p) @@ -2898,9 +2898,12 @@ checkTyEqRhs flags ty -> failCheckWith impredicativeProblem -- Not allowed (TyEq:F) | otherwise -> do { w_res <- checkTyEqRhs flags w + -- ; a_rep <- fmap reductionDCoercion <$> checkTyEqRhs flags (getRuntimeRep a) ; a_res <- checkTyEqRhs flags a + -- ; r_rep <- fmap reductionDCoercion <$> checkTyEqRhs flags (getRuntimeRep r) ; r_res <- checkTyEqRhs flags r - ; return (mkFunRedn Nominal af <$> w_res <*> a_res <*> r_res) } + ; return (mkFunRedn af <$> w_res <*> pure ReflDCo <*> pure ReflDCo <*> a_res <*> r_res) } + -- SLD TODO not sure about this AppTy fun arg -> do { fun_res <- checkTyEqRhs flags fun ; arg_res <- checkTyEqRhs flags arg @@ -2908,10 +2911,10 @@ checkTyEqRhs flags ty CastTy ty co -> do { ty_res <- checkTyEqRhs flags ty ; co_res <- checkCo flags co - ; return (mkCastRedn1 Nominal ty <$> co_res <*> ty_res) } + ; return (mkCastRedn1 <$> co_res <*> ty_res) } CoercionTy co -> do { co_res <- checkCo flags co - ; return (mkReflCoRedn Nominal <$> co_res) } + ; return (mkReflCoRedn <$> co_res) } ForAllTy {} | tef_foralls flags -> okCheckRefl ty @@ -3095,7 +3098,7 @@ checkTyConApp flags@(TEF { tef_unifying = unifying, tef_foralls = foralls_ok }) recurseIntoTyConApp :: TyEqFlags a -> TyCon -> [TcType] -> TcM (PuResult a Reduction) recurseIntoTyConApp flags tc tys = do { tys_res <- mapCheck (checkTyEqRhs flags) tys - ; return (mkTyConAppRedn Nominal tc <$> tys_res) } + ; return (mkTyConAppRedn tc <$> tys_res) } ------------------- checkFamApp :: TyEqFlags a @@ -3123,12 +3126,12 @@ checkFamApp flags@(TEF { tef_unifying = unifying, tef_occurs = occ_prob TEFA_Recurse -> do { tys_res <- mapCheck (checkTyEqRhs arg_flags) tys ; traceTc "under" (ppr tc $$ pprPur tys_res $$ ppr flags) - ; return (mkTyConAppRedn Nominal tc <$> tys_res) } + ; return (mkTyConAppRedn tc <$> tys_res) } TEFA_Break breaker -- Recurse; and break if there is a problem -> do { tys_res <- mapCheck (checkTyEqRhs arg_flags) tys ; case tys_res of - PuOK cts redns -> return (PuOK cts (mkTyConAppRedn Nominal tc redns)) + PuOK cts redns -> return (PuOK cts (mkTyConAppRedn tc redns)) PuFail {} -> breaker fam_app } where arg_flags = famAppArgFlags flags diff --git a/compiler/GHC/Types/Id/Make.hs b/compiler/GHC/Types/Id/Make.hs index d50e3a52ec..f4122241e6 100644 --- a/compiler/GHC/Types/Id/Make.hs +++ b/compiler/GHC/Types/Id/Make.hs @@ -1048,9 +1048,9 @@ dataConSrcToImplBang bang_opts fam_envs arg_ty = HsLazy -- For !Int#, say, use HsLazy -- See Note [Data con wrappers and unlifted types] - | let mb_co = topNormaliseType_maybe fam_envs (scaledThing arg_ty) + | let mb_redn= topNormaliseType_maybe fam_envs (scaledThing arg_ty) -- Unwrap type families and newtypes - arg_ty' = case mb_co of + arg_ty' = case mb_redn of { Just redn -> scaledSet arg_ty (reductionReducedType redn) ; Nothing -> arg_ty } , all (not . isNewTyCon . fst) (splitTyConApp_maybe $ scaledThing arg_ty') @@ -1058,9 +1058,10 @@ dataConSrcToImplBang bang_opts fam_envs arg_ty = if bang_opt_unbox_disable bang_opts then HsStrict True -- Not unpacking because of -O0 -- See Note [Detecting useless UNPACK pragmas] in GHC.Core.DataCon - else case mb_co of + else case mb_redn of Nothing -> HsUnpack Nothing - Just redn -> HsUnpack (Just $ reductionCoercion redn) + Just redn -> HsUnpack $ Just $ + mkHydrateReductionDCoercion Representational (scaledThing arg_ty) redn | otherwise -- Record the strict-but-no-unpack decision = HsStrict False diff --git a/docs/users_guide/using-optimisation.rst b/docs/users_guide/using-optimisation.rst index c75d5e6097..f492f87af8 100644 --- a/docs/users_guide/using-optimisation.rst +++ b/docs/users_guide/using-optimisation.rst @@ -813,6 +813,21 @@ as such you shouldn't need to set any of them explicitly. A flag Turn off the coercion optimiser. +.. ghc-flag:: -fkeep-dcoercions + :shortdesc: Keep directed coercions in the coercion optimiser + :type: dynamic + :category: + + :default: Don't keep directed coercions in the coercion optimiser. + + Keep directed coercions in the coercion optimiser, instead of turning + them into coercions. Only applies when coercion optimisation is enabled. + Turning this flag on will ensure that coercions borne from type family reduction + remain small, but it means the coercion optimiser is less able to optimise them. + If your program crucially relies on coercion optimisation + (i.e. enabling :ghc-flag:`-fno-opt-coercion` causes a significant regression in compile-time), + then you might want to NOT enable this flag. + .. ghc-flag:: -fno-pre-inlining :shortdesc: Turn off pre-inlining :type: dynamic diff --git a/testsuite/tests/dcoercion/DCo_Array.hs b/testsuite/tests/dcoercion/DCo_Array.hs new file mode 100644 index 0000000000..cf3e389a09 --- /dev/null +++ b/testsuite/tests/dcoercion/DCo_Array.hs @@ -0,0 +1,31 @@ +{-# LANGUAGE + MagicHash + , UnboxedTuples + , UnliftedFFITypes + #-} + +module DCo_Array where + +import DCo_Array_aux + ( memcpy_thaw ) + +import GHC.Exts + ( Ptr, Int(I#), RealWorld + , MutableByteArray#, ByteArray# + , newByteArray# + ) +import GHC.IO ( IO(..) ) +import GHC.ST ( ST(..) ) + +data UArray e = UArray !Int ByteArray# +data STUArray s e = STUArray !Int (MutableByteArray# s) + +thawSTUArray :: UArray e -> ST RealWorld (STUArray RealWorld e) +thawSTUArray (UArray n@(I# n#) arr#) = ST $ \s1# -> + case newByteArray# n# s1# of + (# s2#, marr# #) -> + case memcpy_thaw marr# arr# (fromIntegral n) of + IO m -> + case m s2# of + (# s3#, _ #) -> + (# s3#, STUArray n marr# #) diff --git a/testsuite/tests/dcoercion/DCo_Array_aux.hs b/testsuite/tests/dcoercion/DCo_Array_aux.hs new file mode 100644 index 0000000000..dbaf804349 --- /dev/null +++ b/testsuite/tests/dcoercion/DCo_Array_aux.hs @@ -0,0 +1,21 @@ +{-# LANGUAGE + DerivingStrategies + , MagicHash + , UnliftedFFITypes + #-} + +module DCo_Array_aux + ( memcpy_thaw ) where + +import Data.Word + ( Word32 ) +import GHC.Exts + ( MutableByteArray#, ByteArray# + , Ptr + ) + +newtype CSize = CSize Word32 + deriving newtype Num + +foreign import ccall unsafe "memcpy" + memcpy_thaw :: MutableByteArray# s -> ByteArray# -> CSize -> IO (Ptr a) diff --git a/testsuite/tests/dcoercion/DCo_Coercion.hs b/testsuite/tests/dcoercion/DCo_Coercion.hs new file mode 100644 index 0000000000..7a9d697c1a --- /dev/null +++ b/testsuite/tests/dcoercion/DCo_Coercion.hs @@ -0,0 +1,24 @@ +{-# LANGUAGE TypeOperators #-} +{-# LANGUAGE ScopedTypeVariables #-} +{-# LANGUAGE GADTs #-} +{-# LANGUAGE FlexibleInstances #-} +{-# LANGUAGE PolyKinds #-} + +module DCo_Coercion where + +import Data.Type.Equality + ( (:~:)(..), (:~~:)(..) ) +import Data.Coerce + ( Coercible, coerce ) + +data Coercion a b where + Coercion :: Coercible a b => Coercion a b + +class TestCoercion f where + testCoercion :: f a -> f b -> Maybe (Coercion a b) + +instance TestCoercion ((:~:) a) where + testCoercion Refl Refl = Just Coercion + +instance TestCoercion ((:~~:) a) where + testCoercion HRefl HRefl = Just Coercion diff --git a/testsuite/tests/dcoercion/DCo_Hetero.hs b/testsuite/tests/dcoercion/DCo_Hetero.hs new file mode 100644 index 0000000000..fb1e479a96 --- /dev/null +++ b/testsuite/tests/dcoercion/DCo_Hetero.hs @@ -0,0 +1,25 @@ +{-# LANGUAGE DataKinds #-} +{-# LANGUAGE FlexibleInstances #-} +{-# LANGUAGE GADTs #-} +{-# LANGUAGE MultiParamTypeClasses #-} +{-# LANGUAGE NoImplicitPrelude #-} +{-# LANGUAGE PolyKinds #-} +{-# LANGUAGE RankNTypes #-} +{-# LANGUAGE StandaloneDeriving #-} +{-# LANGUAGE StandaloneKindSignatures #-} +{-# LANGUAGE Trustworthy #-} +{-# LANGUAGE TypeFamilies #-} +{-# LANGUAGE TypeOperators #-} +{-# LANGUAGE UndecidableInstances #-} + +module DCo_Hetero where + +import GHC.Enum +import GHC.Base + +type (:~~:) :: k1 -> k2 -> Type +data a :~~: b where + HRefl :: a :~~: a + +instance a ~~ b => Enum (a :~~: b) where + toEnum = error "toEnum" diff --git a/testsuite/tests/dcoercion/DCo_Hetero.stderr b/testsuite/tests/dcoercion/DCo_Hetero.stderr index 887e81669b..2332767804 100644 --- a/testsuite/tests/dcoercion/DCo_Hetero.stderr +++ b/testsuite/tests/dcoercion/DCo_Hetero.stderr @@ -1,5 +1,9 @@ +<<<<<<< HEAD DCo_Hetero.hs:24:10: warning: [GHC-06201] [-Wmissing-methods (in -Wdefault)] +======= +DCo_Hetero.hs:24:10: warning: [-Wmissing-methods (in -Wdefault)] +>>>>>>> efc617419c (Directed coercions) • No explicit implementation for ‘fromEnum’ • In the instance declaration for ‘Enum (a :~~: b)’ diff --git a/testsuite/tests/dcoercion/DCo_HsBinds.hs b/testsuite/tests/dcoercion/DCo_HsBinds.hs new file mode 100644 index 0000000000..668231e067 --- /dev/null +++ b/testsuite/tests/dcoercion/DCo_HsBinds.hs @@ -0,0 +1,34 @@ +{-# LANGUAGE FlexibleInstances #-} +{-# LANGUAGE ScopedTypeVariables #-} +{-# LANGUAGE GADTs #-} + +module DCo_HsBinds where + +import Prelude + +data GhcPass p where + GhcPs :: GhcPass Int + GhcRn :: GhcPass Float + GhcTc :: GhcPass Bool + +type HsPatSynDetails pass = [RecordPatSynField pass] +data RecordPatSynField pass = RecordPatSynField () + +----------------------------------------- + +class Outputable a where + methD :: a -> String + +instance Outputable (HsPatSynDetails (GhcPass r)) where + methD details = ppr_v =<< details + where + ppr_v v = case undefined :: GhcPass r of + GhcPs -> methD v + GhcRn -> methD v + GhcTc -> methD v + +instance Outputable (RecordPatSynField a) where + methD (RecordPatSynField v) = methD v + +instance Outputable () where + methD _ = "()" diff --git a/testsuite/tests/dcoercion/DCo_HsType.hs b/testsuite/tests/dcoercion/DCo_HsType.hs new file mode 100644 index 0000000000..067b5a8091 --- /dev/null +++ b/testsuite/tests/dcoercion/DCo_HsType.hs @@ -0,0 +1,47 @@ + +{-# LANGUAGE DataKinds #-} +{-# LANGUAGE ScopedTypeVariables #-} +{-# LANGUAGE TypeFamilies #-} + +module DCo_HsType ( hsWcScopedTvs ) where + +import Prelude (undefined) + +data GhcPass (c :: Pass) +data Pass = Renamed | Typechecked +type GhcRn = GhcPass 'Renamed + +data HsTyVarBndr pass +type LHsTyVarBndr pass = XRec pass (HsTyVarBndr pass) + +type LHsSigType pass = XRec pass (HsSigType pass) +type LHsSigWcType pass = HsWildCardBndrs pass (LHsSigType pass) + +type HsOuterSigTyVarBndrs = HsOuterTyVarBndrs +data HsSigType pass + = HsSig { sig_bndrs :: HsOuterSigTyVarBndrs pass } + +data HsWildCardBndrs pass thing + = HsWC { hswc_body :: thing } + +data HsOuterTyVarBndrs pass + +type family NoGhcTc p +type instance NoGhcTc (GhcPass pass) = GhcPass (NoGhcTcPass pass) + +type family NoGhcTcPass (p :: Pass) :: Pass where + NoGhcTcPass 'Typechecked = 'Renamed + NoGhcTcPass other = other + +type family XRec p a +type instance XRec (GhcPass p) a = a + +hsOuterExplicitBndrs :: HsOuterTyVarBndrs (GhcPass p) + -> LHsTyVarBndr (NoGhcTc (GhcPass p)) +hsOuterExplicitBndrs = undefined + +hsWcScopedTvs :: LHsSigWcType GhcRn -> LHsTyVarBndr GhcRn +hsWcScopedTvs sig_wc_ty + | HsWC { hswc_body = sig_ty } <- sig_wc_ty + , HsSig { sig_bndrs = outer_bndrs } <- sig_ty + = hsOuterExplicitBndrs outer_bndrs diff --git a/testsuite/tests/dcoercion/DCo_InScope.hs b/testsuite/tests/dcoercion/DCo_InScope.hs new file mode 100644 index 0000000000..083617f452 --- /dev/null +++ b/testsuite/tests/dcoercion/DCo_InScope.hs @@ -0,0 +1,37 @@ +{-# LANGUAGE + ScopedTypeVariables + , DataKinds + , GADTs + , RankNTypes + , TypeOperators + , PolyKinds -- Comment out PolyKinds and the bug goes away. + #-} +{-# OPTIONS_GHC -O #-} + +module DCo_InScope where + +import Data.Kind + +data AccValidation err a = AccFailure err | AccSuccess a + +data KeyValueError = MissingValue + +type WithKeyValueError = AccValidation [KeyValueError] + +missing :: forall f rs. RecApplicative rs -> Rec (WithKeyValueError :. f) rs +missing (RecApplicative rpure) = rpure missingField + where + missingField :: forall x. (WithKeyValueError :. f) x + missingField = Compose $ AccFailure [MissingValue] + +data Rec :: (u -> Type) -> [u] -> Type where + RNil :: Rec f '[] + (:&) :: !(f r) -> !(Rec f rs) -> Rec f (r ': rs) + +newtype Compose (f :: l -> Type) (g :: k -> l) (x :: k) + = Compose { getCompose :: f (g x) } + +type (:.) f g = Compose f g + +newtype RecApplicative rs = + RecApplicative ( forall f. (forall x. f x) -> Rec f rs ) diff --git a/testsuite/tests/dcoercion/DCo_LiftTyped.hs b/testsuite/tests/dcoercion/DCo_LiftTyped.hs new file mode 100644 index 0000000000..8b253743b4 --- /dev/null +++ b/testsuite/tests/dcoercion/DCo_LiftTyped.hs @@ -0,0 +1,26 @@ +{-# LANGUAGE + DefaultSignatures + , MultiParamTypeClasses + , GADTs + , PolyKinds + , ScopedTypeVariables + , StandaloneKindSignatures +#-} + +module ThSyntax where + +import Data.Kind +import GHC.Exts + +type Code :: forall r. TYPE r -> Type +data Code a = Code + +unTypeCode :: forall (r :: RuntimeRep) (a :: TYPE r) . Code a -> () +unTypeCode _ = () + +type Lift :: forall r -> TYPE r -> Constraint +class Lift r t where + lift :: t -> () + default lift :: (r ~ ('BoxedRep 'Lifted)) => t -> () + lift = unTypeCode . liftTyped + liftTyped :: t -> Code t diff --git a/testsuite/tests/dcoercion/DCo_Phantom.hs b/testsuite/tests/dcoercion/DCo_Phantom.hs new file mode 100644 index 0000000000..eceb3fc0ee --- /dev/null +++ b/testsuite/tests/dcoercion/DCo_Phantom.hs @@ -0,0 +1,35 @@ +{-# LANGUAGE DataKinds, PolyKinds, TypeOperators, TypeFamilies, + UndecidableInstances, ConstraintKinds #-} +module DCo_Phantom where + +import GHC.TypeLits as L +import Data.Type.Bool + + +-- We define a very simplistic O notation, with sufficient expressiveness +-- to capture the complexity of a few simple sorting algorithms +data AsympPoly = NLogN Nat Nat + +-- Synonyms for common terms +type N = NLogN 1 0 +type LogN = NLogN 0 1 +type One = NLogN 0 0 + +-- Just to be able to write it nicely +type O (a :: AsympPoly) = a + +type family (^.) (n :: AsympPoly) (m :: Nat) :: AsympPoly where + (NLogN a b) ^. n = (NLogN (a L.* n) (b L.* n)) + +infixl 7 ^. + +newtype Sorted (cpu :: AsympPoly) -- The minimum operational complexity + -- this algorithm satisfies. + (mem :: AsympPoly) -- The minimum space complexity this + -- algorithm satisfies. + (stable :: Bool) -- Whether the sort is stable or not. + a -- What was being sorted. + = Sorted {sortedBy :: [a]} + +mySortA :: Sorted (O(N^.2)) (O(N)) True Integer +mySortA = _a [3,1,2] diff --git a/testsuite/tests/dcoercion/DCo_PostProcess.hs b/testsuite/tests/dcoercion/DCo_PostProcess.hs new file mode 100644 index 0000000000..ffd5ae8eeb --- /dev/null +++ b/testsuite/tests/dcoercion/DCo_PostProcess.hs @@ -0,0 +1,28 @@ +{-# LANGUAGE GADTs #-} +{-# LANGUAGE TypeFamilies #-} +{-# LANGUAGE DataKinds #-} + +module DCo_PostProcess where + +data RdrName +data SrcSpanAnnN + +type family Anno a +type instance Anno RdrName = SrcSpanAnnN + +data Pass = Parsed +data GhcPass (c :: Pass) where + GhcPs :: GhcPass 'Parsed +type GhcPs = GhcPass 'Parsed + +type family IdP p +type instance IdP (GhcPass p) = IdGhcP p +type family IdGhcP pass where + IdGhcP 'Parsed = RdrName + +mkHsOpTy :: (Anno (IdGhcP p) ~ SrcSpanAnnN) + => IdP (GhcPass p) -> GhcPass p +mkHsOpTy = mkHsOpTy + +mkLHsOpTy :: RdrName -> GhcPs +mkLHsOpTy = mkHsOpTy diff --git a/testsuite/tests/dcoercion/DCo_Specialise.hs b/testsuite/tests/dcoercion/DCo_Specialise.hs new file mode 100644 index 0000000000..fde5bfb54f --- /dev/null +++ b/testsuite/tests/dcoercion/DCo_Specialise.hs @@ -0,0 +1,31 @@ +{-# LANGUAGE Haskell2010 #-} +{-# LANGUAGE ConstraintKinds #-} +{-# LANGUAGE FlexibleContexts #-} +{-# LANGUAGE ScopedTypeVariables #-} +{-# LANGUAGE TypeApplications #-} +{-# LANGUAGE TypeFamilies #-} +{-# LANGUAGE TypeOperators #-} + +module DCo_Specialise ( rnStmts1 ) where + +data RealWorld +newtype M a = M (RealWorld -> a) +fmapM :: (a -> b) -> M a -> M b +fmapM f (M k) = M (f . k) + +data HsExpr +data SrcSpanAnnA + +type family Anno a +type instance Anno HsExpr = SrcSpanAnnA + +type AnnoBody body0_ = ( Anno body0_ ~ SrcSpanAnnA ) + +rnStmts1 :: forall body1_ thing1_. AnnoBody body1_ => M (body1_, thing1_) +rnStmts1 = rnStmts2 @body1_ @thing1_ + +rnStmts2 :: forall body2_ thing2_. AnnoBody body2_ => M (body2_, thing2_) +rnStmts2 = rnStmts3 @(body2_, thing2_) + +rnStmts3 :: M thing3_ +rnStmts3 = fmapM snd $ rnStmts1 @HsExpr diff --git a/testsuite/tests/dcoercion/DCo_T15703_aux.hs b/testsuite/tests/dcoercion/DCo_T15703_aux.hs new file mode 100644 index 0000000000..306a39e7a0 --- /dev/null +++ b/testsuite/tests/dcoercion/DCo_T15703_aux.hs @@ -0,0 +1,48 @@ +{-# LANGUAGE AllowAmbiguousTypes #-} +{-# LANGUAGE ConstraintKinds #-} +{-# LANGUAGE DataKinds #-} +{-# LANGUAGE DefaultSignatures #-} +{-# LANGUAGE FlexibleContexts #-} +{-# LANGUAGE GADTs #-} +{-# LANGUAGE InstanceSigs #-} +{-# LANGUAGE RankNTypes #-} +{-# LANGUAGE ScopedTypeVariables #-} +{-# LANGUAGE TypeApplications #-} +{-# LANGUAGE TypeFamilies #-} +{-# LANGUAGE PolyKinds #-} +{-# LANGUAGE TypeOperators #-} +{-# LANGUAGE UndecidableInstances #-} + +module DCo_T15703_aux where + +import Data.Kind +import Data.Type.Equality +import GHC.Generics + +data family Sing :: forall k. k -> Type +data instance Sing :: forall i k c (p :: k). K1 i c p -> Type where + SK1 :: Sing x -> Sing ('K1 x) +data instance Sing :: forall k i (c :: Meta) (f :: k -> Type) (p :: k). + M1 i c f p -> Type where + SM1 :: Sing x -> Sing ('M1 x) + +data instance Sing :: forall k (f :: k -> Type) (g :: k -> Type) (p :: k). + (f :*: g) p -> Type where + (:%*:) :: Sing x -> Sing y -> Sing (x ':*: y) + +data instance Sing :: forall p. Par1 p -> Type where + SPar1 :: Sing x -> Sing ('Par1 x) + +class PGeneric1 (f :: k -> Type) where + type From1 (z :: f a) :: Rep1 f a + type To1 (z :: Rep1 f a) :: f a + +class VGeneric1 (f :: k -> Type) where + sFot1 :: forall (a :: k) (r :: Rep1 f a). Sing r -> From1 (To1 r :: f a) :~: r + +instance PGeneric1 ((,) a) where + type From1 '(x, y) = 'M1 ('M1 ('M1 ('K1 x) ':*: 'M1 ('Par1 y))) + type To1 ('M1 ('M1 ('M1 ('K1 x) ':*: 'M1 ('Par1 y)))) = '(x, y) + +instance VGeneric1 ((,) a) where + sFot1 (SM1 (SM1 (SM1 SK1{} :%*: SM1 SPar1{}))) = Refl diff --git a/testsuite/tests/dcoercion/DCo_TransOpt.hs b/testsuite/tests/dcoercion/DCo_TransOpt.hs new file mode 100644 index 0000000000..e89ac6f113 --- /dev/null +++ b/testsuite/tests/dcoercion/DCo_TransOpt.hs @@ -0,0 +1,108 @@ +{-# LANGUAGE BlockArguments #-} +{-# LANGUAGE LambdaCase #-} + +module Main where + +-- base +import Data.Foldable + ( for_ ) + +-- ghc +import GHC.Core.Coercion + ( DCoercion(ReflDCo, StepsDCo, TransDCo, TyConAppDCo) + , mkTransDCo + ) + +------------------------------------------------------------------------------- + +main :: IO () +main = + for_ test_dcos \ ( nm, dco ) -> + case unreducedTopTransitivities dco of + Nothing -> do + putStrLn $ "OK: " ++ nm + putStrLn $ " " ++ show_dco dco + Just ( i, l, r ) -> do + putStrLn $ "FAIL: " ++ nm + putStrLn $ " " ++ show_dco dco + putStrLn $ " unreduced pair at index " ++ show i + putStrLn $ " LHS:" ++ show_dco l + putStrLn $ " RHS:" ++ show_dco r + +unreducedTopTransitivities + :: DCoercion -> Maybe ( Int, DCoercion, DCoercion ) +unreducedTopTransitivities + = check_reductions . top_trans + +top_trans :: DCoercion -> [ DCoercion ] +top_trans = \case + ldco `TransDCo` rdco -> top_trans ldco ++ top_trans rdco + dco -> [dco] + +check_reductions :: [ DCoercion ] -> Maybe ( Int, DCoercion, DCoercion ) +check_reductions = go 0 + where + go i ( dco1 : dco2 : dcos ) + | should_cancel dco1 dco2 + = Just ( i, dco1, dco2 ) + | otherwise + = go (i+1) ( dco2 : dcos ) + go _ _ = Nothing + +should_cancel :: DCoercion -> DCoercion -> Bool +should_cancel ReflDCo _ = True +should_cancel _ ReflDCo = True +should_cancel (StepsDCo {}) (StepsDCo {}) = True +should_cancel _ _ = False + +-------------------------------------------------------------------------------- +-- Handwritten directed coercions used for testing... + +-- Assume the LHS cannot be simplified further. +test_lhs_dco_1 = ReflDCo +test_lhs_dco_2 = StepsDCo 3 +test_lhs_dco_3 = TyConAppDCo [] `TransDCo` StepsDCo 3 +test_lhs_dco_4 = ( TyConAppDCo [] `TransDCo` TyConAppDCo [] ) `TransDCo` StepsDCo 3 +test_lhs_dco_5 = TyConAppDCo [] `TransDCo` ( TyConAppDCo [] `TransDCo` StepsDCo 3 ) + +-- Don't make any such assumptions about the RHS. +test_rhs_dco_1 = ReflDCo +test_rhs_dco_2 = StepsDCo 3 +test_rhs_dco_3 = StepsDCo 3 `mkTransDCo` StepsDCo 10 +test_rhs_dco_4 = ReflDCo `mkTransDCo` TyConAppDCo [] +test_rhs_dco_5 = StepsDCo 4 `mkTransDCo` TyConAppDCo [] +test_rhs_dco_6 = ( ReflDCo `mkTransDCo` TyConAppDCo [] ) `mkTransDCo` TyConAppDCo [] +test_rhs_dco_7 = ( StepsDCo 4 `mkTransDCo` TyConAppDCo [] ) `mkTransDCo` TyConAppDCo [] +test_rhs_dco_8 = ReflDCo + `mkTransDCo` ( ReflDCo `mkTransDCo` StepsDCo 100 `mkTransDCo` ReflDCo ) + `mkTransDCo` ReflDCo + +test_lhs_dcos :: [ ( String, DCoercion ) ] +test_lhs_dcos = [ ( "lhs 1", test_lhs_dco_1 ) + , ( "lhs 2", test_lhs_dco_2 ) + , ( "lhs 3", test_lhs_dco_3 ) + , ( "lhs 4", test_lhs_dco_4 ) + , ( "lhs 5", test_lhs_dco_5 ) ] + +test_rhs_dcos :: [ ( String, DCoercion ) ] +test_rhs_dcos = [ ( "rhs 1", test_rhs_dco_1 ) + , ( "rhs 2", test_rhs_dco_2 ) + , ( "rhs 3", test_rhs_dco_3 ) + , ( "rhs 4", test_rhs_dco_4 ) + , ( "rhs 5", test_rhs_dco_5 ) + , ( "rhs 6", test_rhs_dco_6 ) + , ( "rhs 7", test_rhs_dco_7 ) + , ( "rhs 8", test_rhs_dco_8 )] + +test_dcos :: [ ( String, DCoercion ) ] +test_dcos = [ ( l_nm ++ ", " ++ r_nm, lhs `mkTransDCo` rhs ) + | (l_nm, lhs) <- test_lhs_dcos + , (r_nm, rhs) <- test_rhs_dcos ] + +show_dco :: DCoercion -> String +show_dco = \case + ReflDCo -> "Refl" + StepsDCo n -> show n + TyConAppDCo {} -> "TC" + l `TransDCo` r -> show_dco l ++ " ; " ++ show_dco r + _ -> "???" diff --git a/testsuite/tests/dcoercion/DCo_TransOpt.stdout b/testsuite/tests/dcoercion/DCo_TransOpt.stdout new file mode 100644 index 0000000000..d2a85459ba --- /dev/null +++ b/testsuite/tests/dcoercion/DCo_TransOpt.stdout @@ -0,0 +1,80 @@ +OK: lhs 1, rhs 1 + Refl +OK: lhs 1, rhs 2 + 3 +OK: lhs 1, rhs 3 + 13 +OK: lhs 1, rhs 4 + TC +OK: lhs 1, rhs 5 + 4 ; TC +OK: lhs 1, rhs 6 + TC ; TC +OK: lhs 1, rhs 7 + 4 ; TC ; TC +OK: lhs 1, rhs 8 + 100 +OK: lhs 2, rhs 1 + 3 +OK: lhs 2, rhs 2 + 6 +OK: lhs 2, rhs 3 + 16 +OK: lhs 2, rhs 4 + 3 ; TC +OK: lhs 2, rhs 5 + 7 ; TC +OK: lhs 2, rhs 6 + 3 ; TC ; TC +OK: lhs 2, rhs 7 + 7 ; TC ; TC +OK: lhs 2, rhs 8 + 103 +OK: lhs 3, rhs 1 + TC ; 3 +OK: lhs 3, rhs 2 + TC ; 6 +OK: lhs 3, rhs 3 + TC ; 16 +OK: lhs 3, rhs 4 + TC ; 3 ; TC +OK: lhs 3, rhs 5 + TC ; 7 ; TC +OK: lhs 3, rhs 6 + TC ; 3 ; TC ; TC +OK: lhs 3, rhs 7 + TC ; 7 ; TC ; TC +OK: lhs 3, rhs 8 + TC ; 103 +OK: lhs 4, rhs 1 + TC ; TC ; 3 +OK: lhs 4, rhs 2 + TC ; TC ; 6 +OK: lhs 4, rhs 3 + TC ; TC ; 16 +OK: lhs 4, rhs 4 + TC ; TC ; 3 ; TC +OK: lhs 4, rhs 5 + TC ; TC ; 7 ; TC +OK: lhs 4, rhs 6 + TC ; TC ; 3 ; TC ; TC +OK: lhs 4, rhs 7 + TC ; TC ; 7 ; TC ; TC +OK: lhs 4, rhs 8 + TC ; TC ; 103 +OK: lhs 5, rhs 1 + TC ; TC ; 3 +OK: lhs 5, rhs 2 + TC ; TC ; 6 +OK: lhs 5, rhs 3 + TC ; TC ; 16 +OK: lhs 5, rhs 4 + TC ; TC ; 3 ; TC +OK: lhs 5, rhs 5 + TC ; TC ; 7 ; TC +OK: lhs 5, rhs 6 + TC ; TC ; 3 ; TC ; TC +OK: lhs 5, rhs 7 + TC ; TC ; 7 ; TC ; TC +OK: lhs 5, rhs 8 + TC ; TC ; 103 diff --git a/testsuite/tests/dcoercion/DCo_TypeRep.hs b/testsuite/tests/dcoercion/DCo_TypeRep.hs new file mode 100644 index 0000000000..161b449fde --- /dev/null +++ b/testsuite/tests/dcoercion/DCo_TypeRep.hs @@ -0,0 +1,14 @@ +{-# LANGUAGE GADTs, RankNTypes, PatternSynonyms, PolyKinds, ViewPatterns, TypeOperators #-} + +module DCo_TypeRep where + +import Type.Reflection (SomeTypeRep(SomeTypeRep), pattern Fun, typeRepKind ) + +------------------------------------------------------------------------ + +getSomeTypeRep :: SomeTypeRep +getSomeTypeRep + | SomeTypeRep f <- getSomeTypeRep + = case typeRepKind f of + Fun _ _ -> error (show f) + _ -> error "not fun" diff --git a/testsuite/tests/dcoercion/DCo_Typeable.hs b/testsuite/tests/dcoercion/DCo_Typeable.hs new file mode 100644 index 0000000000..4470bafc17 --- /dev/null +++ b/testsuite/tests/dcoercion/DCo_Typeable.hs @@ -0,0 +1,28 @@ +{-# LANGUAGE GADTs #-} +{-# LANGUAGE LinearTypes #-} +{-# LANGUAGE NoImplicitPrelude #-} +{-# LANGUAGE PatternSynonyms #-} +{-# LANGUAGE PolyKinds #-} +{-# LANGUAGE ScopedTypeVariables #-} +{-# LANGUAGE StandaloneKindSignatures #-} + +module DCo_Typeable where + +import GHC.Prim ( TYPE ) +import GHC.Base ( Type, RuntimeRep(BoxedRep), Levity(Lifted), undefined ) + +splitApp :: TypeRep a -> AppOrCon a +splitApp TrType = IsApp trTYPE trLiftedRep + where + trTYPE :: TypeRep TYPE + trTYPE = undefined + trLiftedRep :: TypeRep ('BoxedRep 'Lifted) + trLiftedRep = undefined + +type TypeRep :: k -> Type +data TypeRep (a :: k) where + TrType :: TypeRep Type + +data AppOrCon (a :: k) where + IsApp :: forall k k' (f :: k' -> k) (x :: k'). () + => TypeRep f %1 -> TypeRep x %1 -> AppOrCon (f x) diff --git a/testsuite/tests/dcoercion/Makefile b/testsuite/tests/dcoercion/Makefile new file mode 100644 index 0000000000..9a36a1c5fe --- /dev/null +++ b/testsuite/tests/dcoercion/Makefile @@ -0,0 +1,3 @@ +TOP=../.. +include $(TOP)/mk/boilerplate.mk +include $(TOP)/mk/test.mk diff --git a/testsuite/tests/dcoercion/all.T b/testsuite/tests/dcoercion/all.T new file mode 100644 index 0000000000..63cd5f1a11 --- /dev/null +++ b/testsuite/tests/dcoercion/all.T @@ -0,0 +1,19 @@ + +## Correctness tests: these programs should compile and pass Core Lint. +test('DCo_Array', [extra_files(['DCo_Array_aux.hs'])], multimod_compile, ['DCo_Array.hs', '-v0 -O']) +test('DCo_Coercion', normal, compile, ['-O']) +test('DCo_Hetero', normal, compile, ['']) +test('DCo_HsBinds', normal, compile, ['-O']) +test('DCo_HsType', normal, compile, ['']) +test('DCo_InScope', normal, compile, ['']) +test('DCo_LiftTyped', normal, compile, ['']) +test('DCo_Phantom', normal, compile, ['-fdefer-type-errors']) +test('DCo_PostProcess', normal, compile, ['']) +test('DCo_Specialise', normal, compile, ['']) +test('DCo_T15703_aux', normal, compile, ['-O']) +test('DCo_Typeable', normal, compile, ['-O']) +test('DCo_TypeRep', normal, compile, ['']) + +## The following tests that we optimise away certain transitive coercions. +## However, this optimisation was too slow, so we comment this out for now. +#test('DCo_TransOpt', normal, compile_and_run, ['-package ghc']) diff --git a/testsuite/tests/dependent/should_compile/T14729.stderr b/testsuite/tests/dependent/should_compile/T14729.stderr index 0aa6ad7f10..1a9a78dac7 100644 --- a/testsuite/tests/dependent/should_compile/T14729.stderr +++ b/testsuite/tests/dependent/should_compile/T14729.stderr @@ -1,5 +1,7 @@ TYPE SIGNATURES - x :: forall (x :: Bool). P (F Int) (x |> Sym (T14729.D:R:FInt[0])) + x :: + forall (x :: Bool). + P (F Int) (x |> Sym (Hydrate nominal (F Int) T14729.D:R:FInt)) y :: forall {x :: Bool}. P Bool x TYPE CONSTRUCTORS type family F{1} :: * -> * diff --git a/testsuite/tests/perf/compiler/all.T b/testsuite/tests/perf/compiler/all.T index 14cd4cce94..d0c60235a0 100644 --- a/testsuite/tests/perf/compiler/all.T +++ b/testsuite/tests/perf/compiler/all.T @@ -171,7 +171,7 @@ test ('T8095', [ only_ways(['normal']), collect_compiler_stats('bytes allocated',2) ], compile, - ['-v0 -O']) + ['-v0 -O -fkeep-dcoercions']) test ('T13386', [ only_ways(['normal']), collect_compiler_stats('bytes allocated',1) ], @@ -208,7 +208,7 @@ test ('LargeRecord', , extra_files(['SuperRecord.hs']) ], multimod_compile, - ['LargeRecord', '-v0 -O']) + ['LargeRecord', '-v0 -O -fkeep-dcoercions']) test('T9961', [ only_ways(['normal']), @@ -245,7 +245,7 @@ test('T12227', ], compile, # Use `-M1G` to prevent memory thrashing with ghc-8.0.1. - ['-O2 -ddump-hi -ddump-to-file +RTS -M1G']) + ['-O2 -fkeep-dcoercions -ddump-hi -ddump-to-file +RTS -M1G']) test('T12425', [ only_ways(['optasm']), diff --git a/testsuite/tests/pmcheck/should_compile/T11195.hs b/testsuite/tests/pmcheck/should_compile/T11195.hs index 7a7a4b05c5..b377eb2851 100644 --- a/testsuite/tests/pmcheck/should_compile/T11195.hs +++ b/testsuite/tests/pmcheck/should_compile/T11195.hs @@ -34,7 +34,7 @@ optForAllCoBndr = undefined opt_trans :: InScopeSet -> NormalCo -> NormalCo -> NormalCo opt_trans = undefined -opt_univ :: LiftingContext -> SymFlag -> UnivCoProvenance -> Role +opt_univ :: LiftingContext -> SymFlag -> UnivCoProvenance Coercion -> Role -> Type -> Type -> Coercion opt_univ = undefined diff --git a/testsuite/tests/roles/should_compile/Roles13.stderr b/testsuite/tests/roles/should_compile/Roles13.stderr index 92e8cace91..46119f59b9 100644 --- a/testsuite/tests/roles/should_compile/Roles13.stderr +++ b/testsuite/tests/roles/should_compile/Roles13.stderr @@ -1,20 +1,25 @@ ==================== Tidy Core ==================== Result size of Tidy Core - = {terms: 98, types: 38, coercions: 6, joins: 0/0} + = {terms: 98, types: 38, coercions: 8, joins: 0/0} -- RHS size: {terms: 2, types: 2, coercions: 0, joins: 0/0} convert1 :: Wrap Age -> Wrap Age [GblId, Arity=1, Unf=OtherCon []] convert1 = \ (ds :: Wrap Age) -> ds --- RHS size: {terms: 1, types: 0, coercions: 6, joins: 0/0} +-- RHS size: {terms: 1, types: 0, coercions: 8, joins: 0/0} convert :: Wrap Age -> Int [GblId, Arity=1, Unf=OtherCon []] convert = convert1 `cast` (<Wrap Age>_R +<<<<<<< HEAD %<Many>_N ->_R Roles13.N:Wrap[0] (Roles13.N:Age[0]) +======= + %<'Many>_N ->_R Roles13.N:Wrap[0] <Age>_R + ; Roles13.N:Age[0] +>>>>>>> ea654ed05a (Directed coercions) :: (Wrap Age -> Wrap Age) ~R# (Wrap Age -> Int)) -- RHS size: {terms: 1, types: 0, coercions: 0, joins: 0/0} @@ -69,8 +74,13 @@ Roles13.$tcAge :: GHC.Types.TyCon [GblId, Unf=OtherCon []] Roles13.$tcAge = GHC.Types.TyCon +<<<<<<< HEAD 3456257068627873222#Word64 14056710845110756026#Word64 +======= + 3456257068627873222##64 + 14056710845110756026##64 +>>>>>>> ea654ed05a (Directed coercions) Roles13.$trModule $tcAge2 0# @@ -103,8 +113,13 @@ Roles13.$tc'MkAge :: GHC.Types.TyCon [GblId, Unf=OtherCon []] Roles13.$tc'MkAge = GHC.Types.TyCon +<<<<<<< HEAD 18264039750958872441#Word64 1870189534242358050#Word64 +======= + 18264039750958872441##64 + 1870189534242358050##64 +>>>>>>> ea654ed05a (Directed coercions) Roles13.$trModule $tc'MkAge2 0# @@ -125,8 +140,13 @@ Roles13.$tcWrap :: GHC.Types.TyCon [GblId, Unf=OtherCon []] Roles13.$tcWrap = GHC.Types.TyCon +<<<<<<< HEAD 13773534096961634492#Word64 15591525585626702988#Word64 +======= + 13773534096961634492##64 + 15591525585626702988##64 +>>>>>>> ea654ed05a (Directed coercions) Roles13.$trModule $tcWrap2 0# @@ -164,8 +184,13 @@ Roles13.$tc'MkWrap :: GHC.Types.TyCon [GblId, Unf=OtherCon []] Roles13.$tc'MkWrap = GHC.Types.TyCon +<<<<<<< HEAD 15580677875333883466#Word64 808508687714473149#Word64 +======= + 15580677875333883466##64 + 808508687714473149##64 +>>>>>>> ea654ed05a (Directed coercions) Roles13.$trModule $tc'MkWrap2 1# diff --git a/testsuite/tests/tcplugins/RewritePlugin.hs b/testsuite/tests/tcplugins/RewritePlugin.hs index 10aa7574a4..e6e8241b39 100644 --- a/testsuite/tests/tcplugins/RewritePlugin.hs +++ b/testsuite/tests/tcplugins/RewritePlugin.hs @@ -14,7 +14,7 @@ import GHC.Builtin.Types import GHC.Core ( Expr(Coercion) ) import GHC.Core.Coercion - ( Coercion, mkUnivCo ) + ( DCoercion, mkUnivDCo ) import GHC.Core.Predicate ( EqRel(NomEq), Pred(EqPred) , classifyPredType @@ -82,8 +82,7 @@ rewriteAdd _ _ _ _ = pure TcPluginNoRewrite mkTyFamReduction :: TyCon -> [ Type ] -> Type -> Reduction -mkTyFamReduction tyCon args res = Reduction co res +mkTyFamReduction tyCon args res = Reduction (mkTyConApp tyCon args) dco res where - co :: Coercion - co = mkUnivCo ( PluginProv "RewritePlugin" ) Nominal - ( mkTyConApp tyCon args ) res + dco :: DCoercion + dco = mkUnivDCo (PluginProv "RewritePlugin") res |