diff options
Diffstat (limited to 'compiler')
47 files changed, 642 insertions, 718 deletions
diff --git a/compiler/GHC/Core.hs-boot b/compiler/GHC/Core.hs-boot new file mode 100644 index 0000000000..648e0d659c --- /dev/null +++ b/compiler/GHC/Core.hs-boot @@ -0,0 +1,8 @@ +module GHC.Core where +import {-# SOURCE #-} GHC.Types.Var + +data Expr a + +type CoreBndr = Var + +type CoreExpr = Expr CoreBndr diff --git a/compiler/GHC/Core/Coercion.hs b/compiler/GHC/Core/Coercion.hs index 1416e231a9..d1a9efc843 100644 --- a/compiler/GHC/Core/Coercion.hs +++ b/compiler/GHC/Core/Coercion.hs @@ -97,7 +97,7 @@ module GHC.Core.Coercion ( liftCoSubstVarBndrUsing, isMappedByLC, mkSubstLiftingContext, zapLiftingContext, - substForAllCoBndrUsingLC, lcTCvSubst, lcInScopeSet, + substForAllCoBndrUsingLC, lcSubst, lcInScopeSet, LiftCoEnv, LiftingContext(..), liftEnvSubstLeft, liftEnvSubstRight, substRightCo, substLeftCo, swapLiftCoEnv, lcSubstLeft, lcSubstRight, @@ -469,13 +469,13 @@ decomposePiCos :: HasDebugCallStack decomposePiCos orig_co (Pair orig_k1 orig_k2) orig_args = go [] (orig_subst,orig_k1) orig_co (orig_subst,orig_k2) orig_args where - orig_subst = mkEmptyTCvSubst $ mkInScopeSet $ + orig_subst = mkEmptySubst $ mkInScopeSet $ tyCoVarsOfTypes orig_args `unionVarSet` tyCoVarsOfCo orig_co go :: [CoercionN] -- accumulator for argument coercions, reversed - -> (TCvSubst,Kind) -- Lhs kind of coercion + -> (Subst,Kind) -- Lhs kind of coercion -> CoercionN -- coercion originally applied to the function - -> (TCvSubst,Kind) -- Rhs kind of coercion + -> (Subst,Kind) -- Rhs kind of coercion -> [Type] -- Arguments to that function -> ([CoercionN], Coercion) -- Invariant: co :: subst1(k1) ~ subst2(k2) @@ -512,9 +512,9 @@ decomposePiCos orig_co (Pair orig_k1 orig_k2) orig_args go (arg_co : acc_arg_cos) (subst1,t1) res_co (subst2,t2) tys | not (isEmptyTCvSubst subst1) || not (isEmptyTCvSubst subst2) - = go acc_arg_cos (zapTCvSubst subst1, substTy subst1 k1) + = go acc_arg_cos (zapSubst subst1, substTy subst1 k1) co - (zapTCvSubst subst2, substTy subst1 k2) + (zapSubst subst2, substTy subst1 k2) (ty:tys) -- tys might not be empty, if the left-hand type of the original coercion @@ -1900,7 +1900,7 @@ This follows the lifting context extension definition in the -- See Note [Lifting coercions over types: liftCoSubst] -- ---------------------------------------------------- -data LiftingContext = LC TCvSubst LiftCoEnv +data LiftingContext = LC Subst LiftCoEnv -- in optCoercion, we need to lift when optimizing InstCo. -- See Note [Optimising InstCo] in GHC.Core.Coercion.Opt -- We thus propagate the substitution from GHC.Core.Coercion.Opt here. @@ -1941,14 +1941,14 @@ liftCoSubst r lc@(LC subst env) ty | otherwise = ty_co_subst lc r ty emptyLiftingContext :: InScopeSet -> LiftingContext -emptyLiftingContext in_scope = LC (mkEmptyTCvSubst in_scope) emptyVarEnv +emptyLiftingContext in_scope = LC (mkEmptySubst in_scope) emptyVarEnv mkLiftingContext :: [(TyCoVar,Coercion)] -> LiftingContext mkLiftingContext pairs - = LC (mkEmptyTCvSubst $ mkInScopeSet $ tyCoVarsOfCos (map snd pairs)) + = LC (mkEmptySubst $ mkInScopeSet $ tyCoVarsOfCos (map snd pairs)) (mkVarEnv pairs) -mkSubstLiftingContext :: TCvSubst -> LiftingContext +mkSubstLiftingContext :: Subst -> LiftingContext mkSubstLiftingContext subst = LC subst emptyVarEnv -- | Extend a lifting context with a new mapping. @@ -1969,7 +1969,7 @@ extendLiftingContextAndInScope :: LiftingContext -- ^ Original LC -> Coercion -- ^ to this coercion -> LiftingContext extendLiftingContextAndInScope (LC subst env) tv co - = extendLiftingContext (LC (extendTCvInScopeSet subst (tyCoVarsOfCo co)) env) tv co + = extendLiftingContext (LC (extendSubstInScopeSet subst (tyCoVarsOfCo co)) env) tv co -- | Extend a lifting context with existential-variable bindings. -- See Note [extendLiftingContextEx] @@ -1985,7 +1985,7 @@ extendLiftingContextEx lc@(LC subst env) ((v,ty):rest) -- works with existentially bound variables, which are considered to have -- nominal roles. | isTyVar v - = let lc' = LC (subst `extendTCvInScopeSet` tyCoVarsOfType ty) + = let lc' = LC (subst `extendSubstInScopeSet` tyCoVarsOfType ty) (extendVarEnv env v $ mkGReflRightCo Nominal ty @@ -2003,7 +2003,7 @@ extendLiftingContextEx lc@(LC subst env) ((v,ty):rest) kco = mkTyConAppCo Nominal (equalityTyCon r) [ mkKindCo lift_s1, mkKindCo lift_s2 , lift_s1 , lift_s2 ] - lc' = LC (subst `extendTCvInScopeSet` tyCoVarsOfCo co) + lc' = LC (subst `extendSubstInScopeSet` tyCoVarsOfCo co) (extendVarEnv env v (mkProofIrrelCo Nominal kco co $ (mkSymCo lift_s1) `mkTransCo` co `mkTransCo` lift_s2)) @@ -2014,7 +2014,7 @@ extendLiftingContextEx lc@(LC subst env) ((v,ty):rest) -- | Erase the environments in a lifting context zapLiftingContext :: LiftingContext -> LiftingContext -zapLiftingContext (LC subst _) = LC (zapTCvSubst subst) emptyVarEnv +zapLiftingContext (LC subst _) = LC (zapSubst subst) emptyVarEnv -- | Like 'substForAllCoBndr', but works on a lifting context substForAllCoBndrUsingLC :: Bool @@ -2165,14 +2165,14 @@ liftCoSubstTyVarBndrUsing :: (r -> CoercionN) -- ^ coercion getter -> (LiftingContext, TyVar, r) liftCoSubstTyVarBndrUsing view_co fun lc@(LC subst cenv) old_var = assert (isTyVar old_var) $ - ( LC (subst `extendTCvInScope` new_var) new_cenv + ( LC (subst `extendSubstInScope` new_var) new_cenv , new_var, stuff ) where old_kind = tyVarKind old_var stuff = fun lc old_kind eta = view_co stuff k1 = coercionLKind eta - new_var = uniqAway (getTCvInScope subst) (setVarType old_var k1) + new_var = uniqAway (getSubstInScope subst) (setVarType old_var k1) lifted = mkGReflRightCo Nominal (TyVarTy new_var) eta -- :: new_var ~ new_var |> eta @@ -2185,14 +2185,14 @@ liftCoSubstCoVarBndrUsing :: (r -> CoercionN) -- ^ coercion getter -> (LiftingContext, CoVar, r) liftCoSubstCoVarBndrUsing view_co fun lc@(LC subst cenv) old_var = assert (isCoVar old_var) $ - ( LC (subst `extendTCvInScope` new_var) new_cenv + ( LC (subst `extendSubstInScope` new_var) new_cenv , new_var, stuff ) where old_kind = coVarKind old_var stuff = fun lc old_kind eta = view_co stuff k1 = coercionLKind eta - new_var = uniqAway (getTCvInScope subst) (setVarType old_var k1) + new_var = uniqAway (getSubstInScope subst) (setVarType old_var k1) -- old_var :: s1 ~r s2 -- eta :: (s1' ~r s2') ~N (t1 ~r t2) @@ -2232,21 +2232,21 @@ substRightCo lc co swapLiftCoEnv :: LiftCoEnv -> LiftCoEnv swapLiftCoEnv = mapVarEnv mkSymCo -lcSubstLeft :: LiftingContext -> TCvSubst +lcSubstLeft :: LiftingContext -> Subst lcSubstLeft (LC subst lc_env) = liftEnvSubstLeft subst lc_env -lcSubstRight :: LiftingContext -> TCvSubst +lcSubstRight :: LiftingContext -> Subst lcSubstRight (LC subst lc_env) = liftEnvSubstRight subst lc_env -liftEnvSubstLeft :: TCvSubst -> LiftCoEnv -> TCvSubst +liftEnvSubstLeft :: Subst -> LiftCoEnv -> Subst liftEnvSubstLeft = liftEnvSubst pFst -liftEnvSubstRight :: TCvSubst -> LiftCoEnv -> TCvSubst +liftEnvSubstRight :: Subst -> LiftCoEnv -> Subst liftEnvSubstRight = liftEnvSubst pSnd -liftEnvSubst :: (forall a. Pair a -> a) -> TCvSubst -> LiftCoEnv -> TCvSubst +liftEnvSubst :: (forall a. Pair a -> a) -> Subst -> LiftCoEnv -> Subst liftEnvSubst selector subst lc_env - = composeTCvSubst (TCvSubst emptyInScopeSet tenv cenv) subst + = composeTCvSubst (Subst emptyInScopeSet emptyIdSubstEnv tenv cenv) subst where pairs = nonDetUFMToList lc_env -- It's OK to use nonDetUFMToList here because we @@ -2266,12 +2266,12 @@ liftEnvSubst selector subst lc_env equality_ty = selector (coercionKind co) -- | Extract the underlying substitution from the LiftingContext -lcTCvSubst :: LiftingContext -> TCvSubst -lcTCvSubst (LC subst _) = subst +lcSubst :: LiftingContext -> Subst +lcSubst (LC subst _) = subst -- | Get the 'InScopeSet' from a 'LiftingContext' lcInScopeSet :: LiftingContext -> InScopeSet -lcInScopeSet (LC subst _) = getTCvInScope subst +lcInScopeSet (LC subst _) = getSubstInScope subst {- %************************************************************************ @@ -2431,7 +2431,7 @@ coercionRKind co -- kind_co always has kind @Type@, thus @isGReflCo@ | otherwise = go_forall empty_subst co where - empty_subst = mkEmptyTCvSubst (mkInScopeSet $ tyCoVarsOfCo co) + empty_subst = mkEmptySubst (mkInScopeSet $ tyCoVarsOfCo co) go_ax_inst ax ind tys | CoAxBranch { cab_tvs = tvs, cab_cvs = cvs @@ -2457,9 +2457,9 @@ coercionRKind co where k2 = coercionRKind k_co tv2 = setTyVarKind tv1 (substTy subst k2) - subst' | isGReflCo k_co = extendTCvInScope subst tv1 + subst' | isGReflCo k_co = extendSubstInScope subst tv1 -- kind_co always has kind @Type@, thus @isGReflCo@ - | otherwise = extendTvSubst (extendTCvInScope subst tv2) tv1 $ + | otherwise = extendTvSubst (extendSubstInScope subst tv2) tv1 $ TyVarTy tv2 `mkCastTy` mkSymCo k_co go_forall subst (ForAllCo cv1 k_co co) @@ -2482,8 +2482,8 @@ coercionRKind co cv2 = setVarType cv1 (substTy subst k2) n_subst = eta1 `mkTransCo` (mkCoVarCo cv2) `mkTransCo` (mkSymCo eta2) - subst' | isReflCo k_co = extendTCvInScope subst cv1 - | otherwise = extendCvSubst (extendTCvInScope subst cv2) + subst' | isReflCo k_co = extendSubstInScope subst cv1 + | otherwise = extendCvSubst (extendSubstInScope subst cv2) cv1 n_subst go_forall subst other_co @@ -2666,7 +2666,7 @@ buildCoercion orig_ty1 orig_ty2 = go orig_ty1 orig_ty2 eta1 = mkNthCo r 2 kind_co' eta2 = mkNthCo r 3 kind_co' - subst = mkEmptyTCvSubst $ mkInScopeSet $ + subst = mkEmptySubst $ mkInScopeSet $ tyCoVarsOfType ty2 `unionVarSet` tyCoVarsOfCo kind_co ty2' = substTy (extendCvSubst subst cv2 $ mkSymCo eta1 `mkTransCo` mkCoVarCo cv1 `mkTransCo` diff --git a/compiler/GHC/Core/Coercion/Opt.hs b/compiler/GHC/Core/Coercion/Opt.hs index 27375c5fe3..927d67ddab 100644 --- a/compiler/GHC/Core/Coercion/Opt.hs +++ b/compiler/GHC/Core/Coercion/Opt.hs @@ -119,14 +119,14 @@ newtype OptCoercionOpts = OptCoercionOpts { optCoercionEnabled :: Bool -- ^ Enable coercion optimisation (reduce its size) } -optCoercion :: OptCoercionOpts -> TCvSubst -> Coercion -> NormalCo +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 | otherwise = substCo env co -optCoercion' :: TCvSubst -> Coercion -> NormalCo +optCoercion' :: Subst -> Coercion -> NormalCo optCoercion' env co | debugIsOn = let out_co = opt_co1 lc False co @@ -280,7 +280,7 @@ opt_co4 env sym rep r (FunCo _r cow co1 co2) cow' = opt_co1 env sym cow opt_co4 env sym rep r (CoVarCo cv) - | Just co <- lookupCoVar (lcTCvSubst env) cv + | Just co <- lookupCoVar (lcSubst env) cv = opt_co4_wrap (zapLiftingContext env) sym rep r co | ty1 `eqType` ty2 -- See Note [Optimise CoVarCo to Refl] diff --git a/compiler/GHC/Core/DataCon.hs b/compiler/GHC/Core/DataCon.hs index 4f82cd3d68..887a293e88 100644 --- a/compiler/GHC/Core/DataCon.hs +++ b/compiler/GHC/Core/DataCon.hs @@ -789,7 +789,7 @@ eqSpecPreds spec = [ mkPrimEqPred (mkTyVarTy tv) ty -- | Substitute in an 'EqSpec'. Precondition: if the LHS of the EqSpec -- is mapped in the substitution, it is mapped to a type variable, not -- a full type. -substEqSpec :: TCvSubst -> EqSpec -> EqSpec +substEqSpec :: Subst -> EqSpec -> EqSpec substEqSpec subst (EqSpec tv ty) = EqSpec tv' (substTy subst ty) where diff --git a/compiler/GHC/Core/Lint.hs b/compiler/GHC/Core/Lint.hs index cf87106e45..b92938e92f 100644 --- a/compiler/GHC/Core/Lint.hs +++ b/compiler/GHC/Core/Lint.hs @@ -1437,7 +1437,7 @@ lintCaseExpr scrut var alt_ty alts = -- Don't use lintIdBndr on var, because unboxed tuple is legitimate - ; subst <- getTCvSubst + ; subst <- getSubst ; ensureEqTys var_ty scrut_ty (mkScrutMsg var var_ty scrut_ty subst) -- See GHC.Core Note [Case expression invariants] item (7) @@ -1602,15 +1602,15 @@ lintTyBndr = lintTyCoBndr -- We could specialise it, I guess lintTyCoBndr :: TyCoVar -> (LintedTyCoVar -> LintM a) -> LintM a lintTyCoBndr tcv thing_inside - = do { subst <- getTCvSubst + = do { subst <- getSubst ; kind' <- lintType (varType tcv) - ; let tcv' = uniqAway (getTCvInScope subst) $ + ; let tcv' = uniqAway (getSubstInScope subst) $ setVarType tcv kind' subst' = extendTCvSubstWithClone subst tcv tcv' ; when (isCoVar tcv) $ lintL (isCoVarType kind') (text "CoVar with non-coercion type:" <+> pprTyVar tcv) - ; updateTCvSubst subst' (thing_inside tcv') } + ; updateSubst subst' (thing_inside tcv') } lintIdBndrs :: forall a. TopLevelFlag -> [Id] -> ([LintedId] -> LintM a) -> LintM a lintIdBndrs top_lvl ids thing_inside @@ -1710,7 +1710,7 @@ lintType (TyVarTy tv) = failWithL (mkBadTyVarMsg tv) | otherwise - = do { subst <- getTCvSubst + = do { subst <- getSubst ; case lookupTyVar subst tv of Just linted_ty -> return linted_ty @@ -1926,7 +1926,7 @@ lint_app doc kfn arg_tys ; unless (ka `eqType` kv_kind) $ addErrL (fail_msg (text "Forall:" <+> (ppr kv $$ ppr kv_kind $$ ppr ta <+> dcolon <+> ppr ka))) - ; return $ substTy (extendTCvSubst (mkEmptyTCvSubst in_scope) kv ta) kfn } + ; return $ substTy (extendTCvSubst (mkEmptySubst in_scope) kv ta) kfn } go_app _ kfn ta = failWithL (fail_msg (text "Not a fun:" <+> (ppr kfn $$ ppr ta))) @@ -2071,7 +2071,7 @@ lintCoercion (CoVarCo cv) 2 (text "With offending type:" <+> ppr (varType cv))) | otherwise - = do { subst <- getTCvSubst + = do { subst <- getSubst ; case lookupCoVar subst cv of Just linted_co -> return linted_co ; Nothing @@ -2371,8 +2371,8 @@ lintCoercion co@(AxiomInstCo con ind cos) ; unless (cos `equalLength` (ktvs ++ cvs)) $ bad_ax (text "lengths") ; cos' <- mapM lintCoercion cos - ; subst <- getTCvSubst - ; let empty_subst = zapTCvSubst subst + ; subst <- getSubst + ; let empty_subst = zapSubst subst ; _ <- foldlM check_ki (empty_subst, empty_subst) (zip3 (ktvs ++ cvs) roles cos') ; let fam_tc = coAxiomTyCon con @@ -2601,7 +2601,7 @@ compatible_branches (CoAxBranch { cab_tvs = tvs1 = -- we need to freshen ax2 w.r.t. ax1 -- do this by pretending tvs1 are in scope when processing tvs2 let in_scope = mkInScopeSetList tvs1 - subst0 = mkEmptyTCvSubst in_scope + subst0 = mkEmptySubst in_scope (subst, _) = substTyVarBndrs subst0 tvs2 lhs2' = substTys subst lhs2 rhs2' = substTy subst rhs2 @@ -2625,13 +2625,13 @@ data LintEnv = LE { le_flags :: LintFlags -- Linting the result of this pass , le_loc :: [LintLocInfo] -- Locations - , le_subst :: TCvSubst -- Current TyCo substitution + , le_subst :: Subst -- Current TyCo substitution -- See Note [Linting type lets] -- /Only/ substitutes for type variables; -- but might clone CoVars -- We also use le_subst to keep track of -- in-scope TyVars and CoVars (but not Ids) - -- Range of the TCvSubst is LintedType/LintedCo + -- Range of the Subst is LintedType/LintedCo , le_ids :: VarEnv (Id, LintedType) -- In-scope Ids -- Used to check that occurrences have an enclosing binder. @@ -2858,7 +2858,7 @@ initL cfg m where (tcvs, ids) = partition isTyCoVar $ l_vars cfg env = LE { le_flags = l_flags cfg - , le_subst = mkEmptyTCvSubst (mkInScopeSetList tcvs) + , le_subst = mkEmptySubst (mkInScopeSetList tcvs) , le_ids = mkVarEnv [(id, (id,idType id)) | id <- ids] , le_joins = emptyVarSet , le_loc = [] @@ -2961,8 +2961,8 @@ extendTvSubstL tv ty m = LintM $ \ env errs -> unLintM m (env { le_subst = Type.extendTvSubst (le_subst env) tv ty }) errs -updateTCvSubst :: TCvSubst -> LintM a -> LintM a -updateTCvSubst subst' m +updateSubst :: Subst -> LintM a -> LintM a +updateSubst subst' m = LintM $ \ env errs -> unLintM m (env { le_subst = subst' }) errs markAllJoinsBad :: LintM a -> LintM a @@ -2976,14 +2976,14 @@ markAllJoinsBadIf False m = m getValidJoins :: LintM IdSet getValidJoins = LintM (\ env errs -> (Just (le_joins env), errs)) -getTCvSubst :: LintM TCvSubst -getTCvSubst = LintM (\ env errs -> (Just (le_subst env), errs)) +getSubst :: LintM Subst +getSubst = LintM (\ env errs -> (Just (le_subst env), errs)) getUEAliases :: LintM (NameEnv UsageEnv) getUEAliases = LintM (\ env errs -> (Just (le_ue_aliases env), errs)) getInScope :: LintM InScopeSet -getInScope = LintM (\ env errs -> (Just (getTCvInScope $ le_subst env), errs)) +getInScope = LintM (\ env errs -> (Just (getSubstInScope $ le_subst env), errs)) lookupIdInScope :: Id -> LintM (Id, LintedType) lookupIdInScope id_occ @@ -3183,7 +3183,7 @@ mkCaseAltMsg e ty1 ty2 text "Annotation on case:" <+> ppr ty2, text "Alt Rhs:" <+> ppr e ]) -mkScrutMsg :: Id -> Type -> Type -> TCvSubst -> SDoc +mkScrutMsg :: Id -> Type -> Type -> Subst -> SDoc mkScrutMsg var var_ty scrut_ty subst = vcat [text "Result binder in case doesn't match scrutinee:" <+> ppr var, text "Result binder type:" <+> ppr var_ty,--(idType var), diff --git a/compiler/GHC/Core/Opt/Arity.hs b/compiler/GHC/Core/Opt/Arity.hs index 9312e7d48b..33e2e44cf2 100644 --- a/compiler/GHC/Core/Opt/Arity.hs +++ b/compiler/GHC/Core/Opt/Arity.hs @@ -56,7 +56,7 @@ import GHC.Core.Predicate ( isDictTy, isEvVar, isCallStackPredTy ) import GHC.Core.Multiplicity -- We have two sorts of substitution: --- GHC.Core.Subst.Subst, and GHC.Core.TyCo.TCvSubst +-- GHC.Core.Subst.Subst, and GHC.Core.TyCo.Subst -- Both have substTy, substCo Hence need for qualification import GHC.Core.Subst as Core import GHC.Core.Type as Type @@ -1877,7 +1877,7 @@ etaInfoApp in_scope expr eis where (subst1, b1) = Core.substBndr subst b alts' = map subst_alt alts - ty' = etaInfoAppTy (Core.substTy subst ty) eis + ty' = etaInfoAppTy (substTyUnchecked subst ty) eis subst_alt (Alt con bs rhs) = Alt con bs' (go subst2 rhs eis) where (subst2,bs') = Core.substBndrs subst1 bs @@ -1940,18 +1940,18 @@ mkEtaWW mkEtaWW orig_oss ppr_orig_expr in_scope orig_ty = go 0 orig_oss empty_subst orig_ty where - empty_subst = mkEmptyTCvSubst in_scope + empty_subst = mkEmptySubst in_scope go :: Int -- For fresh names -> [OneShotInfo] -- Number of value args to expand to - -> TCvSubst -> Type -- We are really looking at subst(ty) + -> Subst -> Type -- We are really looking at subst(ty) -> (InScopeSet, EtaInfo) -- (go [o1,..,on] subst ty) = (in_scope, EI [b1,..,bn] co) -- co :: subst(ty) ~ b1_ty -> ... -> bn_ty -> tr go _ [] subst _ ----------- Done! No more expansion needed - = (getTCvInScope subst, EI [] MRefl) + = (getSubstInScope subst, EI [] MRefl) go n oss@(one_shot:oss1) subst ty ----------- Forall types (forall a. ty) @@ -1998,7 +1998,7 @@ mkEtaWW orig_oss ppr_orig_expr in_scope orig_ty -- but its type isn't a function, or a binder -- does not have a fixed runtime representation = warnPprTrace True "mkEtaWW" ((ppr orig_oss <+> ppr orig_ty) $$ ppr_orig_expr) - (getTCvInScope subst, EI [] MRefl) + (getSubstInScope subst, EI [] MRefl) -- This *can* legitimately happen: -- e.g. coerce Int (\x. x) Essentially the programmer is -- playing fast and loose with types (Happy does this a lot). @@ -2846,12 +2846,12 @@ etaBodyForJoinPoint need_args body = pprPanic "etaBodyForJoinPoint" $ int need_args $$ ppr body $$ ppr (exprType body) - init_subst e = mkEmptyTCvSubst (mkInScopeSet (exprFreeVars e)) + init_subst e = mkEmptySubst (mkInScopeSet (exprFreeVars e)) -------------- -freshEtaId :: Int -> TCvSubst -> Scaled Type -> (TCvSubst, Id) +freshEtaId :: Int -> Subst -> Scaled Type -> (Subst, Id) -- Make a fresh Id, with specified type (after applying substitution) -- It should be "fresh" in the sense that it's not in the in-scope set -- of the TvSubstEnv; and it should itself then be added to the in-scope @@ -2863,8 +2863,8 @@ freshEtaId n subst ty = (subst', eta_id') where Scaled mult' ty' = Type.substScaledTyUnchecked subst ty - eta_id' = uniqAway (getTCvInScope subst) $ + eta_id' = uniqAway (getSubstInScope subst) $ mkSysLocalOrCoVar (fsLit "eta") (mkBuiltinUnique n) mult' ty' -- "OrCoVar" since this can be used to eta-expand -- coercion abstractions - subst' = extendTCvInScope subst eta_id' + subst' = extendSubstInScope subst eta_id' diff --git a/compiler/GHC/Core/Opt/CSE.hs b/compiler/GHC/Core/Opt/CSE.hs index 03e7a2e7d1..23baf90742 100644 --- a/compiler/GHC/Core/Opt/CSE.hs +++ b/compiler/GHC/Core/Opt/CSE.hs @@ -696,7 +696,7 @@ cseOneExpr e = cseExpr env e where env = emptyCSEnv {cs_subst = mkEmptySubst (mkInScopeSet (exprFreeVars e)) } cseExpr :: CSEnv -> InExpr -> OutExpr -cseExpr env (Type t) = Type (substTy (csEnvSubst env) t) +cseExpr env (Type t) = Type (substTyUnchecked (csEnvSubst env) t) cseExpr env (Coercion c) = Coercion (substCo (csEnvSubst env) c) cseExpr _ (Lit lit) = Lit lit cseExpr env (Var v) = lookupSubst env v @@ -714,7 +714,7 @@ cseCase env scrut bndr ty alts = Case scrut1 bndr3 ty' $ combineAlts (map cse_alt alts) where - ty' = substTy (csEnvSubst env) ty + ty' = substTyUnchecked (csEnvSubst env) ty (cse_done, scrut1) = try_for_cse env scrut bndr1 = zapIdOccInfo bndr diff --git a/compiler/GHC/Core/Opt/SetLevels.hs b/compiler/GHC/Core/Opt/SetLevels.hs index 8dea553ad5..85ac7e2e86 100644 --- a/compiler/GHC/Core/Opt/SetLevels.hs +++ b/compiler/GHC/Core/Opt/SetLevels.hs @@ -1,4 +1,3 @@ - {-# LANGUAGE PatternSynonyms #-} {-# OPTIONS_GHC -Wno-incomplete-uni-patterns #-} @@ -363,7 +362,7 @@ don't want @lvlExpr@ to turn the scrutinee of the @case@ into an MFE If there were another lambda in @r@'s rhs, it would get level-2 as well. -} -lvlExpr env (_, AnnType ty) = return (Type (GHC.Core.Subst.substTy (le_subst env) ty)) +lvlExpr env (_, AnnType ty) = return (Type (substTyUnchecked (le_subst env) ty)) lvlExpr env (_, AnnCoercion co) = return (Coercion (substCo (le_subst env) co)) lvlExpr env (_, AnnVar v) = return (lookupVar env v) lvlExpr _ (_, AnnLit lit) = return (Lit lit) @@ -492,7 +491,7 @@ lvlCase env scrut_fvs scrut' case_bndr ty alts ; alts' <- mapM (lvl_alt alts_env) alts ; return (Case scrut' case_bndr' ty' alts') } where - ty' = substTy (le_subst env) ty + ty' = substTyUnchecked (le_subst env) ty incd_lvl = incMinorLvl (le_ctxt_lvl env) dest_lvl = maxFvLevel (const True) env scrut_fvs @@ -623,7 +622,7 @@ lvlMFE :: LevelEnv -- Level of in-scope names/tyvars -- the expression, so that it can itself be floated. lvlMFE env _ (_, AnnType ty) - = return (Type (GHC.Core.Subst.substTy (le_subst env) ty)) + = return (Type (substTyUnchecked (le_subst env) ty)) -- No point in floating out an expression wrapped in a coercion or note -- If we do we'll transform lvl = e |> co @@ -1719,7 +1718,7 @@ newPolyBndrs dest_lvl mkSysLocal (mkFastString str) uniq (idMult bndr) poly_ty where str = "poly_" ++ occNameString (getOccName bndr) - poly_ty = mkLamTypes abs_vars (GHC.Core.Subst.substTy subst (idType bndr)) + poly_ty = mkLamTypes abs_vars (substTyUnchecked subst (idType bndr)) -- If we are floating a join point to top level, it stops being -- a join point. Otherwise it continues to be a join point, diff --git a/compiler/GHC/Core/Opt/Simplify/Env.hs b/compiler/GHC/Core/Opt/Simplify/Env.hs index b8cf447634..cd3548781a 100644 --- a/compiler/GHC/Core/Opt/Simplify/Env.hs +++ b/compiler/GHC/Core/Opt/Simplify/Env.hs @@ -30,7 +30,7 @@ module GHC.Core.Opt.Simplify.Env ( -- * Simplifying 'Id' binders simplNonRecBndr, simplNonRecJoinBndr, simplRecBndrs, simplRecJoinBndrs, simplBinder, simplBinders, - substTy, substTyVar, getTCvSubst, + substTy, substTyVar, getSubst, substCo, substCoVar, -- * Floats @@ -60,6 +60,7 @@ import GHC.Core import GHC.Core.Utils import GHC.Core.Multiplicity ( scaleScaled ) import GHC.Core.Unfold +import GHC.Core.TyCo.Subst (emptyIdSubstEnv) import GHC.Types.Var import GHC.Types.Var.Env import GHC.Types.Var.Set @@ -368,7 +369,7 @@ pprSimplEnv env | otherwise = ppr v type SimplIdSubst = IdEnv SimplSR -- IdId |--> OutExpr - -- See Note [Extending the Subst] in GHC.Core.Subst + -- See Note [Extending the IdSubstEnv] in GHC.Core.Subst -- | A substitution result. data SimplSR @@ -1223,34 +1224,34 @@ See also Note [Return type for join points] and Note [Join points and case-of-ca ************************************************************************ -} -getTCvSubst :: SimplEnv -> TCvSubst -getTCvSubst (SimplEnv { seInScope = in_scope, seTvSubst = tv_env +getSubst :: SimplEnv -> Subst +getSubst (SimplEnv { seInScope = in_scope, seTvSubst = tv_env , seCvSubst = cv_env }) - = mkTCvSubst in_scope (tv_env, cv_env) + = mkSubst in_scope tv_env cv_env emptyIdSubstEnv substTy :: HasDebugCallStack => SimplEnv -> Type -> Type -substTy env ty = Type.substTy (getTCvSubst env) ty +substTy env ty = Type.substTy (getSubst env) ty substTyVar :: SimplEnv -> TyVar -> Type -substTyVar env tv = Type.substTyVar (getTCvSubst env) tv +substTyVar env tv = Type.substTyVar (getSubst env) tv substTyVarBndr :: SimplEnv -> TyVar -> (SimplEnv, TyVar) substTyVarBndr env tv - = case Type.substTyVarBndr (getTCvSubst env) tv of - (TCvSubst in_scope' tv_env' cv_env', tv') + = case Type.substTyVarBndr (getSubst env) tv of + (Subst in_scope' _ tv_env' cv_env', tv') -> (env { seInScope = in_scope', seTvSubst = tv_env', seCvSubst = cv_env' }, tv') substCoVar :: SimplEnv -> CoVar -> Coercion -substCoVar env tv = Coercion.substCoVar (getTCvSubst env) tv +substCoVar env tv = Coercion.substCoVar (getSubst env) tv substCoVarBndr :: SimplEnv -> CoVar -> (SimplEnv, CoVar) substCoVarBndr env cv - = case Coercion.substCoVarBndr (getTCvSubst env) cv of - (TCvSubst in_scope' tv_env' cv_env', cv') + = case Coercion.substCoVarBndr (getSubst env) cv of + (Subst in_scope' _ tv_env' cv_env', cv') -> (env { seInScope = in_scope', seTvSubst = tv_env', seCvSubst = cv_env' }, cv') substCo :: SimplEnv -> Coercion -> Coercion -substCo env co = Coercion.substCo (getTCvSubst env) co +substCo env co = Coercion.substCo (getSubst env) co ------------------ substIdType :: SimplEnv -> Id -> Id @@ -1264,6 +1265,6 @@ substIdType (SimplEnv { seInScope = in_scope, seTvSubst = tv_env, seCvSubst = cv -- in a Note in the id's type itself where no_free_vars = noFreeVarsOfType old_ty && noFreeVarsOfType old_w - subst = TCvSubst in_scope tv_env cv_env + subst = Subst in_scope emptyIdSubstEnv tv_env cv_env old_ty = idType id old_w = varMult id diff --git a/compiler/GHC/Core/Opt/Simplify/Iteration.hs b/compiler/GHC/Core/Opt/Simplify/Iteration.hs index ab03872365..29639b99ab 100644 --- a/compiler/GHC/Core/Opt/Simplify/Iteration.hs +++ b/compiler/GHC/Core/Opt/Simplify/Iteration.hs @@ -1312,7 +1312,7 @@ simplCoercionF env co cont simplCoercion :: SimplEnv -> InCoercion -> SimplM OutCoercion simplCoercion env co - = do { let opt_co = optCoercion opts (getTCvSubst env) co + = do { let opt_co = optCoercion opts (getSubst env) co ; seqCo opt_co `seq` return opt_co } where opts = seOptCoercionOpts env diff --git a/compiler/GHC/Core/Opt/SpecConstr.hs b/compiler/GHC/Core/Opt/SpecConstr.hs index d3cf764be0..55822d8132 100644 --- a/compiler/GHC/Core/Opt/SpecConstr.hs +++ b/compiler/GHC/Core/Opt/SpecConstr.hs @@ -972,13 +972,13 @@ scSubstId :: ScEnv -> InId -> OutExpr scSubstId env v = lookupIdSubst (sc_subst env) v scSubstTy :: ScEnv -> InType -> OutType -scSubstTy env ty = substTy (sc_subst env) ty +scSubstTy env ty = substTyUnchecked (sc_subst env) ty scSubstCo :: ScEnv -> Coercion -> Coercion scSubstCo env co = substCo (sc_subst env) co zapScSubst :: ScEnv -> ScEnv -zapScSubst env = env { sc_subst = zapSubstEnv (sc_subst env) } +zapScSubst env = env { sc_subst = zapSubst (sc_subst env) } extendScInScope :: ScEnv -> [Var] -> ScEnv -- Bring the quantified variables into scope @@ -2345,7 +2345,7 @@ callToPats :: ScEnv -> [ArgOcc] -> Call -> UniqSM (Maybe CallPat) -- over the following term variables -- The [CoreExpr] are the argument patterns for the rule callToPats env bndr_occs call@(Call fn args con_env) - = do { let in_scope = substInScope (sc_subst env) + = do { let in_scope = getSubstInScope (sc_subst env) ; arg_tripples <- zipWith3M (argToPat env in_scope con_env) args bndr_occs (map (const NotMarkedStrict) args) -- This zip trims the args to be no longer than diff --git a/compiler/GHC/Core/Opt/Specialise.hs b/compiler/GHC/Core/Opt/Specialise.hs index 29addb02a7..2dc2257525 100644 --- a/compiler/GHC/Core/Opt/Specialise.hs +++ b/compiler/GHC/Core/Opt/Specialise.hs @@ -1,5 +1,3 @@ - - {-# OPTIONS_GHC -Wno-incomplete-uni-patterns #-} {- @@ -19,7 +17,7 @@ import GHC.Driver.Config.Core.Rules ( initRuleOpts ) import GHC.Tc.Utils.TcType hiding( substTy ) -import GHC.Core.Type hiding( substTy, extendTvSubstList ) +import GHC.Core.Type hiding( substTy, extendTvSubstList, zapSubst ) import GHC.Core.Multiplicity import GHC.Core.Predicate import GHC.Core.Coercion( Coercion ) @@ -1650,7 +1648,7 @@ specLookupRule env fn args rules = lookupRule ropts (in_scope, realIdUnfolding) (const True) fn args rules where dflags = se_dflags env - in_scope = Core.substInScope (se_subst env) + in_scope = getSubstInScope (se_subst env) ropts = initRuleOpts dflags {- Note [Specialising DFuns] @@ -3063,10 +3061,10 @@ extendInScope env@(SE { se_subst = subst }) bndr zapSubst :: SpecEnv -> SpecEnv zapSubst env@(SE { se_subst = subst }) - = env { se_subst = Core.zapSubstEnv subst } + = env { se_subst = Core.zapSubst subst } substTy :: SpecEnv -> Type -> Type -substTy env ty = Core.substTy (se_subst env) ty +substTy env ty = substTyUnchecked (se_subst env) ty substCo :: SpecEnv -> Coercion -> Coercion substCo env co = Core.substCo (se_subst env) co @@ -3101,7 +3099,7 @@ newDictBndr :: SpecEnv -> CoreBndr -> SpecM (SpecEnv, CoreBndr) newDictBndr env@(SE { se_subst = subst }) b = do { uniq <- getUniqueM ; let n = idName b - ty' = Core.substTy subst (idType b) + ty' = substTyUnchecked subst (idType b) b' = mkUserLocal (nameOccName n) uniq Many ty' (getSrcSpan n) env' = env { se_subst = subst `Core.extendSubstInScope` b' } ; pure (env', b') } diff --git a/compiler/GHC/Core/Opt/WorkWrap/Utils.hs b/compiler/GHC/Core/Opt/WorkWrap/Utils.hs index d3f3928f7a..0c6aa2def5 100644 --- a/compiler/GHC/Core/Opt/WorkWrap/Utils.hs +++ b/compiler/GHC/Core/Opt/WorkWrap/Utils.hs @@ -220,7 +220,7 @@ mkWwBodies opts fun_id arg_vars res_ty demands res_cpr empty_subst = mkEmptySubst (mkInScopeSet args_free_tcvs) zapped_arg_vars = map zap_var arg_vars (subst, cloned_arg_vars) = cloneBndrs empty_subst uniq_supply zapped_arg_vars - res_ty' = GHC.Core.Subst.substTy subst res_ty + res_ty' = substTyUnchecked subst res_ty init_str_marks = map (const NotMarkedStrict) cloned_arg_vars ; (useful1, work_args_str, wrap_fn_str, fn_args) @@ -1166,7 +1166,7 @@ dubiousDataConInstArgTys dc tc_args = arg_tys where univ_tvs = dataConUnivTyVars dc ex_tvs = dataConExTyCoVars dc - subst = extendTCvInScopeList (zipTvSubst univ_tvs tc_args) ex_tvs + subst = extendSubstInScopeList (zipTvSubst univ_tvs tc_args) ex_tvs arg_tys = map (GHC.Core.Type.substTy subst . scaledThing) (dataConRepArgTys dc) findTypeShape :: FamInstEnvs -> Type -> TypeShape diff --git a/compiler/GHC/Core/Ppr.hs-boot b/compiler/GHC/Core/Ppr.hs-boot new file mode 100644 index 0000000000..3aa7a7711f --- /dev/null +++ b/compiler/GHC/Core/Ppr.hs-boot @@ -0,0 +1,11 @@ +{-# OPTIONS_GHC -fno-warn-orphans #-} + +module GHC.Core.Ppr where + +import {-# SOURCE #-} GHC.Core +import {-# SOURCE #-} GHC.Types.Var (Var) +import GHC.Utils.Outputable (OutputableBndr, Outputable) + +instance OutputableBndr b => Outputable (Expr b) + +instance OutputableBndr Var diff --git a/compiler/GHC/Core/Rules.hs b/compiler/GHC/Core/Rules.hs index e2d6487267..d1a1d982f6 100644 --- a/compiler/GHC/Core/Rules.hs +++ b/compiler/GHC/Core/Rules.hs @@ -49,8 +49,8 @@ import GHC.Core.Utils ( exprType, mkTick, mkTicks import GHC.Core.Ppr ( pprRules ) import GHC.Core.Unify as Unify ( ruleMatchTyKiX ) import GHC.Core.Type as Type - ( Type, TCvSubst, extendTvSubst, extendCvSubst - , mkEmptyTCvSubst, substTy, getTyVar_maybe ) + ( Type, extendTvSubst, extendCvSubst + , substTy, getTyVar_maybe ) import GHC.Core.TyCo.Ppr( pprParendType ) import GHC.Core.Coercion as Coercion import GHC.Core.Tidy ( tidyRules ) @@ -600,7 +600,7 @@ matchN :: InScopeEnv matchN (in_scope, id_unf) rule_name tmpl_vars tmpl_es target_es rhs = do { rule_subst <- match_exprs init_menv emptyRuleSubst tmpl_es target_es ; let (_, matched_es) = mapAccumL (lookup_tmpl rule_subst) - (mkEmptyTCvSubst in_scope) $ + (mkEmptySubst in_scope) $ tmpl_vars `zip` tmpl_vars1 bind_wrapper = rs_binds rule_subst -- Floated bindings; see Note [Matching lets] @@ -615,7 +615,7 @@ matchN (in_scope, id_unf) rule_name tmpl_vars tmpl_es target_es rhs , rv_fltR = mkEmptySubst (rnInScopeSet init_rn_env) , rv_unf = id_unf } - lookup_tmpl :: RuleSubst -> TCvSubst -> (InVar,OutVar) -> (TCvSubst, CoreExpr) + lookup_tmpl :: RuleSubst -> Subst -> (InVar,OutVar) -> (Subst, CoreExpr) -- Need to return a RuleSubst solely for the benefit of mk_fake_ty lookup_tmpl (RS { rs_tv_subst = tv_subst, rs_id_subst = id_subst }) tcv_subst (tmpl_var, tmpl_var1) diff --git a/compiler/GHC/Core/SimpleOpt.hs b/compiler/GHC/Core/SimpleOpt.hs index 1d604120b9..d40136634d 100644 --- a/compiler/GHC/Core/SimpleOpt.hs +++ b/compiler/GHC/Core/SimpleOpt.hs @@ -212,10 +212,10 @@ emptyEnv opts = SOE { soe_inl = emptyVarEnv soeZapSubst :: SimpleOptEnv -> SimpleOptEnv soeZapSubst env@(SOE { soe_subst = subst }) - = env { soe_inl = emptyVarEnv, soe_subst = zapSubstEnv subst } + = env { soe_inl = emptyVarEnv, soe_subst = zapSubst subst } soeInScope :: SimpleOptEnv -> InScopeSet -soeInScope (SOE { soe_subst = subst }) = substInScope subst +soeInScope (SOE { soe_subst = subst }) = getSubstInScope subst soeSetInScope :: InScopeSet -> SimpleOptEnv -> SimpleOptEnv soeSetInScope in_scope env2@(SOE { soe_subst = subst2 }) @@ -241,7 +241,7 @@ simple_opt_expr env expr where rec_ids = soe_rec_ids env subst = soe_subst env - in_scope = substInScope subst + in_scope = getSubstInScope subst in_scope_env = (in_scope, simpleUnfoldingFun) --------------- @@ -252,7 +252,7 @@ simple_opt_expr env expr = lookupIdSubst (soe_subst env) v go (App e1 e2) = simple_app env e1 [(env,e2)] - go (Type ty) = Type (substTy subst ty) + go (Type ty) = Type (substTyUnchecked subst ty) go (Coercion co) = Coercion (go_co co) go (Lit lit) = Lit lit go (Tick tickish e) = mkTick (substTickish subst tickish) (go e) @@ -285,14 +285,14 @@ simple_opt_expr env expr = go rhs | otherwise - = Case e' b' (substTy subst ty) + = Case e' b' (substTyUnchecked subst ty) (map (go_alt env') as) where e' = go e (env', b') = subst_opt_bndr env b ---------------------- - go_co co = optCoercion (so_co_opts (soe_opts env)) (getTCvSubst subst) co + go_co co = optCoercion (so_co_opts (soe_opts env)) subst co ---------------------- go_alt env (Alt con bndrs rhs) @@ -452,12 +452,12 @@ simple_bind_pair env@(SOE { soe_inl = inl_env, soe_subst = subst }) in_bndr mb_out_bndr clo@(rhs_env, in_rhs) top_level | Type ty <- in_rhs -- let a::* = TYPE ty in <body> - , let out_ty = substTy (soe_subst rhs_env) ty + , let out_ty = substTyUnchecked (soe_subst rhs_env) ty = assertPpr (isTyVar in_bndr) (ppr in_bndr $$ ppr in_rhs) $ (env { soe_subst = extendTvSubst subst in_bndr out_ty }, Nothing) | Coercion co <- in_rhs - , let out_co = optCoercion (so_co_opts (soe_opts env)) (getTCvSubst (soe_subst rhs_env)) co + , let out_co = optCoercion (so_co_opts (soe_opts env)) (soe_subst rhs_env) co = assert (isCoVar in_bndr) (env { soe_subst = extendCvSubst subst in_bndr out_co }, Nothing) @@ -474,7 +474,7 @@ simple_bind_pair env@(SOE { soe_inl = inl_env, soe_subst = subst }) stable_unf = isStableUnfolding (idUnfolding in_bndr) active = isAlwaysActive (idInlineActivation in_bndr) occ = idOccInfo in_bndr - in_scope = substInScope subst + in_scope = getSubstInScope subst out_rhs | Just join_arity <- isJoinId_maybe in_bndr = simple_join_rhs join_arity @@ -712,7 +712,7 @@ subst_opt_id_bndr env@(SOE { soe_subst = subst, soe_inl = inl }) old_id Subst in_scope id_subst tv_subst cv_subst = subst id1 = uniqAway in_scope old_id - id2 = updateIdTypeAndMult (substTy subst) id1 + id2 = updateIdTypeAndMult (substTyUnchecked subst) id1 new_id = zapFragileIdInfo id2 -- Zaps rules, unfolding, and fragile OccInfo -- The unfolding and rules will get added back later, by add_info @@ -1258,7 +1258,7 @@ exprIsConApp_maybe (in_scope, id_unf) expr go subst'' (float:floats) expr cont go (Right sub) floats (Var v) cont - = go (Left (substInScope sub)) + = go (Left (getSubstInScope sub)) floats (lookupIdSubst sub v) cont @@ -1330,7 +1330,7 @@ exprIsConApp_maybe (in_scope, id_unf) expr -- The Left case is wildly dominant subst_in_scope (Left in_scope) = in_scope - subst_in_scope (Right s) = substInScope s + subst_in_scope (Right s) = getSubstInScope s subst_extend_in_scope (Left in_scope) v = Left (in_scope `extendInScopeSet` v) subst_extend_in_scope (Right s) v = Right (s `extendSubstInScope` v) diff --git a/compiler/GHC/Core/Subst.hs b/compiler/GHC/Core/Subst.hs index 12a3e79559..8d5fd9422c 100644 --- a/compiler/GHC/Core/Subst.hs +++ b/compiler/GHC/Core/Subst.hs @@ -15,18 +15,19 @@ module GHC.Core.Subst ( -- ** Substituting into expressions and related types deShadowBinds, substRuleInfo, substRulesForImportedIds, - substTy, substCo, substExpr, substExprSC, substBind, substBindSC, + substTyUnchecked, substCo, substExpr, substExprSC, substBind, substBindSC, substUnfolding, substUnfoldingSC, lookupIdSubst, substIdType, substIdOcc, substTickish, substDVarSet, substIdInfo, -- ** Operations on substitutions - emptySubst, mkEmptySubst, mkSubst, mkOpenSubst, substInScope, isEmptySubst, + emptySubst, mkEmptySubst, mkSubst, mkOpenSubst, isEmptySubst, extendIdSubst, extendIdSubstList, extendTCvSubst, extendTvSubstList, - extendSubst, extendSubstList, extendSubstWithVar, zapSubstEnv, + extendIdSubstWithClone, + extendSubst, extendSubstList, extendSubstWithVar, extendSubstInScope, extendSubstInScopeList, extendSubstInScopeSet, - isInScope, setInScope, getTCvSubst, extendTvSubst, extendCvSubst, - delBndr, delBndrs, + isInScope, setInScope, extendTvSubst, extendCvSubst, + delBndr, delBndrs, zapSubst, -- ** Substituting and cloning binders substBndr, substBndrs, substRecBndrs, substTyVarBndr, substCoVarBndr, @@ -40,14 +41,12 @@ import GHC.Core import GHC.Core.FVs import GHC.Core.Seq import GHC.Core.Utils -import qualified GHC.Core.Type as Type -import qualified GHC.Core.Coercion as Coercion +import GHC.Core.TyCo.Subst ( substCo ) -- We are defining local versions -import GHC.Core.Type hiding - ( substTy, extendTvSubst, extendCvSubst, extendTvSubstList - , isInScope, substTyVarBndr, cloneTyVarBndr ) -import GHC.Core.Coercion hiding ( substCo, substCoVarBndr ) +import GHC.Core.Type hiding ( substTy ) +import GHC.Core.Coercion + ( tyCoFVsOfCo, mkCoVarCo, substCoVarBndr ) import GHC.Types.Var.Set import GHC.Types.Var.Env as InScopeSet @@ -68,8 +67,6 @@ import GHC.Utils.Panic.Plain import Data.List (mapAccumL) - - {- ************************************************************************ * * @@ -78,37 +75,12 @@ import Data.List (mapAccumL) ************************************************************************ -} --- | A substitution environment, containing 'Id', 'TyVar', and 'CoVar' --- substitutions. --- --- Some invariants apply to how you use the substitution: --- --- 1. Note [The substitution invariant] in "GHC.Core.TyCo.Subst" --- --- 2. Note [Substitutions apply only once] in "GHC.Core.TyCo.Subst" -data Subst - = Subst InScopeSet -- Variables in scope (both Ids and TyVars) /after/ - -- applying the substitution - IdSubstEnv -- Substitution from NcIds to CoreExprs - TvSubstEnv -- Substitution from TyVars to Types - CvSubstEnv -- Substitution from CoVars to Coercions - - -- INVARIANT 1: See TyCoSubst Note [The substitution invariant] - -- This is what lets us deal with name capture properly - -- It's a hard invariant to check... - -- - -- INVARIANT 2: The substitution is apply-once; - -- see Note [Substitutions apply only once] in GHC.Core.TyCo.Subst - -- - -- INVARIANT 3: See Note [Extending the Subst] - {- -Note [Extending the Subst] +Note [Extending the IdSubstEnv] ~~~~~~~~~~~~~~~~~~~~~~~~~~ -For a core Subst, which binds Ids as well, we make a different choice for Ids -than we do for TyVars. +We make a different choice for Ids than we do for TyVars. -For TyVars, see Note [Extending the TCvSubstEnv] in GHC.Core.TyCo.Subst. +For TyVars, see Note [Extending the TvSubstEnv and CvSubstEnv] in GHC.Core.TyCo.Subst. For Ids, we have a different invariant The IdSubstEnv is extended *only* when the Unique on an Id changes @@ -158,31 +130,13 @@ TvSubstEnv and CvSubstEnv? easy to spot -} --- | An environment for substituting for 'Id's -type IdSubstEnv = IdEnv CoreExpr -- Domain is NcIds, i.e. not coercions - ---------------------------- -isEmptySubst :: Subst -> Bool -isEmptySubst (Subst _ id_env tv_env cv_env) - = isEmptyVarEnv id_env && isEmptyVarEnv tv_env && isEmptyVarEnv cv_env - -emptySubst :: Subst -emptySubst = Subst emptyInScopeSet emptyVarEnv emptyVarEnv emptyVarEnv - -mkEmptySubst :: InScopeSet -> Subst -mkEmptySubst in_scope = Subst in_scope emptyVarEnv emptyVarEnv emptyVarEnv -mkSubst :: InScopeSet -> TvSubstEnv -> CvSubstEnv -> IdSubstEnv -> Subst -mkSubst in_scope tvs cvs ids = Subst in_scope ids tvs cvs - --- | Find the in-scope set: see "GHC.Core.TyCo.Subst" Note [The substitution invariant] -substInScope :: Subst -> InScopeSet -substInScope (Subst in_scope _ _ _) = in_scope - --- | Remove all substitutions for 'Id's and 'Var's that might have been built up --- while preserving the in-scope set -zapSubstEnv :: Subst -> Subst -zapSubstEnv (Subst in_scope _ _ _) = Subst in_scope emptyVarEnv emptyVarEnv emptyVarEnv +-- We keep GHC.Core.Subst separate from GHC.Core.TyCo.Subst to avoid creating +-- circular dependencies. Functions in this file that don't depend on +-- the definition of CoreExpr can be moved to GHC.Core.TyCo.Subst, as long +-- as it does not require importing too many additional hs-boot files and +-- cause a significant drop in performance. -- | Add a substitution for an 'Id' to the 'Subst': you must ensure that the in-scope set is -- such that TyCoSubst Note [The substitution invariant] @@ -193,38 +147,20 @@ extendIdSubst (Subst in_scope ids tvs cvs) v r = assertPpr (isNonCoVarId v) (ppr v $$ ppr r) $ Subst in_scope (extendVarEnv ids v r) tvs cvs +extendIdSubstWithClone :: Subst -> Id -> Id -> Subst +extendIdSubstWithClone (Subst in_scope ids tvs cvs) v v' + = assertPpr (isNonCoVarId v) (ppr v $$ ppr v') $ + Subst (extendInScopeSetSet in_scope new_in_scope) + (extendVarEnv ids v (varToCoreExpr v')) tvs cvs + where + new_in_scope = tyCoVarsOfType (varType v') `extendVarSet` v' + -- | Adds multiple 'Id' substitutions to the 'Subst': see also 'extendIdSubst' extendIdSubstList :: Subst -> [(Id, CoreExpr)] -> Subst extendIdSubstList (Subst in_scope ids tvs cvs) prs = assert (all (isNonCoVarId . fst) prs) $ Subst in_scope (extendVarEnvList ids prs) tvs cvs --- | Add a substitution for a 'TyVar' to the 'Subst' --- The 'TyVar' *must* be a real TyVar, and not a CoVar --- You must ensure that the in-scope set is such that --- "GHC.Core.TyCo.Subst" Note [The substitution invariant] holds --- after extending the substitution like this. -extendTvSubst :: Subst -> TyVar -> Type -> Subst -extendTvSubst (Subst in_scope ids tvs cvs) tv ty - = assert (isTyVar tv) $ - Subst in_scope ids (extendVarEnv tvs tv ty) cvs - --- | Adds multiple 'TyVar' substitutions to the 'Subst': see also 'extendTvSubst' -extendTvSubstList :: Subst -> [(TyVar,Type)] -> Subst -extendTvSubstList subst vrs - = foldl' extend subst vrs - where - extend subst (v, r) = extendTvSubst subst v r - --- | Add a substitution from a 'CoVar' to a 'Coercion' to the 'Subst': --- you must ensure that the in-scope set satisfies --- "GHC.Core.TyCo.Subst" Note [The substitution invariant] --- after extending the substitution like this -extendCvSubst :: Subst -> CoVar -> Coercion -> Subst -extendCvSubst (Subst in_scope ids tvs cvs) v r - = assert (isCoVar v) $ - Subst in_scope ids tvs (extendVarEnv cvs v r) - -- | Add a substitution appropriate to the thing being substituted -- (whether an expression, type, or coercion). See also -- 'extendIdSubst', 'extendTvSubst', 'extendCvSubst' @@ -254,7 +190,7 @@ lookupIdSubst (Subst in_scope ids _ _) v | not (isLocalId v) = Var v | Just e <- lookupVarEnv ids v = e | Just v' <- lookupInScope in_scope v = Var v' - -- Vital! See Note [Extending the Subst] + -- Vital! See Note [Extending the IdSubstEnv] -- If v isn't in the InScopeSet, we panic, because -- it's a bad bug and we reallly want to know | otherwise = pprPanic "lookupIdSubst" (ppr v $$ ppr in_scope) @@ -281,41 +217,6 @@ mkOpenSubst in_scope pairs = Subst in_scope (mkVarEnv [(v,co) | (v, Coercion co) <- pairs]) ------------------------------ -isInScope :: Var -> Subst -> Bool -isInScope v (Subst in_scope _ _ _) = v `elemInScopeSet` in_scope - --- | Add the 'Var' to the in-scope set -extendSubstInScope :: Subst -> Var -> Subst -extendSubstInScope (Subst in_scope ids tvs cvs) v - = Subst (in_scope `InScopeSet.extendInScopeSet` v) - ids tvs cvs - --- | Add the 'Var's to the in-scope set: see also 'extendInScope' -extendSubstInScopeList :: Subst -> [Var] -> Subst -extendSubstInScopeList (Subst in_scope ids tvs cvs) vs - = Subst (in_scope `extendInScopeSetList` vs) - ids tvs cvs - --- | Add the 'Var's to the in-scope set: see also 'extendInScope' -extendSubstInScopeSet :: Subst -> VarSet -> Subst -extendSubstInScopeSet (Subst in_scope ids tvs cvs) vs - = Subst (in_scope `extendInScopeSetSet` vs) - ids tvs cvs - -setInScope :: Subst -> InScopeSet -> Subst -setInScope (Subst _ ids tvs cvs) in_scope = Subst in_scope ids tvs cvs - --- Pretty printing, for debugging only - -instance Outputable Subst where - ppr (Subst in_scope ids tvs cvs) - = text "<InScope =" <+> in_scope_doc - $$ text " IdSubst =" <+> ppr ids - $$ text " TvSubst =" <+> ppr tvs - $$ text " CvSubst =" <+> ppr cvs - <> char '>' - where - in_scope_doc = pprVarSet (getInScopeVars in_scope) (braces . fsep . map ppr) {- ************************************************************************ @@ -339,14 +240,14 @@ substExprSC subst orig_expr -- See Note [Substitutions apply only once] in "GHC.Core.TyCo.Subst" -- -- Do *not* attempt to short-cut in the case of an empty substitution! --- See Note [Extending the Subst] +-- See Note [Extending the IdSubstEnv] substExpr :: HasDebugCallStack => Subst -> CoreExpr -> CoreExpr -- HasDebugCallStack so we can track failures in lookupIdSubst substExpr subst expr = go expr where go (Var v) = lookupIdSubst subst v - go (Type ty) = Type (substTy subst ty) + go (Type ty) = Type (substTyUnchecked subst ty) go (Coercion co) = Coercion (substCo subst co) go (Lit lit) = Lit lit go (App fun arg) = App (go fun) (go arg) @@ -366,7 +267,7 @@ substExpr subst expr where (subst', bind') = substBind subst bind - go (Case scrut bndr ty alts) = Case (go scrut) bndr' (substTy subst ty) (map (go_alt subst') alts) + go (Case scrut bndr ty alts) = Case (go scrut) bndr' (substTyUnchecked subst ty) (map (go_alt subst') alts) where (subst', bndr') = substBndr subst bndr @@ -464,7 +365,7 @@ substIdBndr _doc rec_subst subst@(Subst in_scope env tvs cvs) old_id where id1 = uniqAway in_scope old_id -- id1 is cloned if necessary id2 | no_type_change = id1 - | otherwise = updateIdTypeAndMult (substTy subst) id1 + | otherwise = updateIdTypeAndMult (substTyUnchecked subst) id1 old_ty = idType old_id old_w = idMult old_id @@ -484,7 +385,7 @@ substIdBndr _doc rec_subst subst@(Subst in_scope env tvs cvs) old_id | otherwise = extendVarEnv env old_id (Var new_id) no_change = id1 == old_id - -- See Note [Extending the Subst] + -- See Note [Extending the IdSubstEnv] -- it's /not/ necessary to check mb_new_info and no_type_change {- @@ -547,41 +448,8 @@ clone_id rec_subst subst@(Subst in_scope idvs tvs cvs) (old_id, uniq) Types and Coercions * * ************************************************************************ - -For types and coercions we just call the corresponding functions in -Type and Coercion, but we have to repackage the substitution, from a -Subst to a TCvSubst. -} -substTyVarBndr :: Subst -> TyVar -> (Subst, TyVar) -substTyVarBndr (Subst in_scope id_env tv_env cv_env) tv - = case Type.substTyVarBndr (TCvSubst in_scope tv_env cv_env) tv of - (TCvSubst in_scope' tv_env' cv_env', tv') - -> (Subst in_scope' id_env tv_env' cv_env', tv') - -cloneTyVarBndr :: Subst -> TyVar -> Unique -> (Subst, TyVar) -cloneTyVarBndr (Subst in_scope id_env tv_env cv_env) tv uniq - = case Type.cloneTyVarBndr (TCvSubst in_scope tv_env cv_env) tv uniq of - (TCvSubst in_scope' tv_env' cv_env', tv') - -> (Subst in_scope' id_env tv_env' cv_env', tv') - -substCoVarBndr :: Subst -> CoVar -> (Subst, CoVar) -substCoVarBndr (Subst in_scope id_env tv_env cv_env) cv - = case Coercion.substCoVarBndr (TCvSubst in_scope tv_env cv_env) cv of - (TCvSubst in_scope' tv_env' cv_env', cv') - -> (Subst in_scope' id_env tv_env' cv_env', cv') - --- | See 'GHC.Core.Type.substTy'. -substTy :: Subst -> Type -> Type -substTy subst ty = Type.substTyUnchecked (getTCvSubst subst) ty - -getTCvSubst :: Subst -> TCvSubst -getTCvSubst (Subst in_scope _ tenv cenv) = TCvSubst in_scope tenv cenv - --- | See 'Coercion.substCo' -substCo :: HasCallStack => Subst -> Coercion -> Coercion -substCo subst co = Coercion.substCo (getTCvSubst subst) co - {- ************************************************************************ * * @@ -595,7 +463,7 @@ substIdType subst@(Subst _ _ tv_env cv_env) id | (isEmptyVarEnv tv_env && isEmptyVarEnv cv_env) || (noFreeVarsOfType old_ty && noFreeVarsOfType old_w) = id | otherwise = - updateIdTypeAndMult (substTy subst) id + updateIdTypeAndMult (substTyUnchecked subst) id -- The tyCoVarsOfType is cheaper than it looks -- because we cache the free tyvars of the type -- in a Note in the id's type itself diff --git a/compiler/GHC/Core/TyCo/Subst.hs b/compiler/GHC/Core/TyCo/Subst.hs index 069270a1a5..d9d674bb30 100644 --- a/compiler/GHC/Core/TyCo/Subst.hs +++ b/compiler/GHC/Core/TyCo/Subst.hs @@ -12,21 +12,20 @@ Type and Coercion - friends' interface module GHC.Core.TyCo.Subst ( -- * Substitutions - TCvSubst(..), TvSubstEnv, CvSubstEnv, - emptyTvSubstEnv, emptyCvSubstEnv, composeTCvSubstEnv, composeTCvSubst, - emptyTCvSubst, mkEmptyTCvSubst, isEmptyTCvSubst, - mkTCvSubst, mkTvSubst, mkCvSubst, - getTvSubstEnv, - getCvSubstEnv, getTCvInScope, getTCvSubstRangeFVs, - isInScope, elemTCvSubst, notElemTCvSubst, - setTvSubstEnv, setCvSubstEnv, zapTCvSubst, - extendTCvInScope, extendTCvInScopeList, extendTCvInScopeSet, + Subst(..), TvSubstEnv, CvSubstEnv, IdSubstEnv, + emptyIdSubstEnv, emptyTvSubstEnv, emptyCvSubstEnv, composeTCvSubst, + emptySubst, mkEmptySubst, isEmptyTCvSubst, isEmptySubst, + mkSubst, mkTvSubst, mkCvSubst, mkIdSubst, + getTvSubstEnv, getIdSubstEnv, + getCvSubstEnv, getSubstInScope, setInScope, getSubstRangeTyCoFVs, + isInScope, elemSubst, notElemSubst, zapSubst, + extendSubstInScope, extendSubstInScopeList, extendSubstInScopeSet, extendTCvSubst, extendTCvSubstWithClone, extendCvSubst, extendCvSubstWithClone, extendTvSubst, extendTvSubstBinderAndInScope, extendTvSubstWithClone, extendTvSubstList, extendTvSubstAndInScope, extendTCvSubstList, - unionTCvSubst, zipTyEnv, zipCoEnv, + unionSubst, zipTyEnv, zipCoEnv, zipTvSubst, zipCvSubst, zipTCvSubst, mkTvSubstPrs, @@ -65,6 +64,8 @@ import {-# SOURCE #-} GHC.Core.Coercion , mkCoercionType , coercionKind, coercionLKind, coVarKindsTypesRole ) import {-# SOURCE #-} GHC.Core.TyCo.Ppr ( pprTyVar ) +import {-# SOURCE #-} GHC.Core.Ppr ( ) +import {-# SOURCE #-} GHC.Core ( CoreExpr ) import GHC.Core.TyCo.Rep import GHC.Core.TyCo.FVs @@ -95,27 +96,33 @@ import Data.List (mapAccumL) %************************************************************************ -} --- | Type & coercion substitution +-- | Type & coercion & id substitution -- --- #tcvsubst_invariant# --- The following invariants must hold of a 'TCvSubst': --- --- 1. The in-scope set is needed /only/ to --- guide the generation of fresh uniques --- --- 2. In particular, the /kind/ of the type variables in --- the in-scope set is not relevant --- --- 3. The substitution is only applied ONCE! This is because --- in general such application will not reach a fixed point. -data TCvSubst - = TCvSubst InScopeSet -- The in-scope type and kind variables - TvSubstEnv -- Substitutes both type and kind variables - CvSubstEnv -- Substitutes coercion variables - -- See Note [Substitutions apply only once] - -- and Note [Extending the TCvSubstEnv] - -- and Note [Substituting types and coercions] - -- and Note [The substitution invariant] +-- The "Subst" data type defined in this module contains substitution +-- for tyvar, covar and id. However, operations on IdSubstEnv (mapping +-- from "Id" to "CoreExpr") that require the definition of the "Expr" +-- data type are defined in GHC.Core.Subst to avoid circular module +-- dependency. +data Subst + = Subst InScopeSet -- Variables in scope (both Ids and TyVars) /after/ + -- applying the substitution + IdSubstEnv -- Substitution from NcIds to CoreExprs + TvSubstEnv -- Substitution from TyVars to Types + CvSubstEnv -- Substitution from CoVars to Coercions + + -- INVARIANT 1: See Note [The substitution invariant] + -- This is what lets us deal with name capture properly + -- + -- INVARIANT 2: The substitution is apply-once; + -- see Note [Substitutions apply only once] + -- + -- INVARIANT 3: See Note [Extending the IdSubstEnv] in "GHC.Core.Subst" + -- and Note [Extending the TvSubstEnv and CvSubstEnv] + -- + -- INVARIANT 4: See Note [Substituting types, coercions, and expressions] + +-- | A substitution of 'Expr's for non-coercion 'Id's +type IdSubstEnv = IdEnv CoreExpr -- Domain is NonCoVarIds, i.e. not coercions -- | A substitution of 'Type's for 'TyVar's -- and 'Kind's for 'KindVar's @@ -139,8 +146,6 @@ the in-scope set in the substitution is a superset of both: (SIa) The free vars of the range of the substitution (SIb) The free vars of ty minus the domain of the substitution -The same rules apply to other substitutions (notably GHC.Core.Subst.Subst) - * Reason for (SIa). Consider substTy [a :-> Maybe b] (forall b. b->a) we must rename the forall b, to get @@ -179,7 +184,7 @@ variations happen to; for example [a -> (a, b)]. A TCvSubst is not idempotent, but, unlike the non-idempotent substitution we use during unifications, it must not be repeatedly applied. -Note [Extending the TCvSubstEnv] +Note [Extending the TvSubstEnv and CvSubstEnv] ~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~ See #tcvsubst_invariant# for the invariants that must hold. @@ -203,128 +208,145 @@ This invariant has several crucial consequences: * In substTy, substTheta, we can short-circuit when the TvSubstEnv is empty -Note [Substituting types and coercions] +Note [Substituting types, coercions, and expressions] ~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~ Types and coercions are mutually recursive, and either may have variables "belonging" to the other. Thus, every time we wish to substitute in a type, we may also need to substitute in a coercion, and vice versa. -However, the constructor used to create type variables is distinct from -that of coercion variables, so we carry two VarEnvs in a TCvSubst. Note -that it would be possible to use the CoercionTy constructor to combine -these environments, but that seems like a false economy. - -Note that the TvSubstEnv should *never* map a CoVar (built with the Id -constructor) and the CvSubstEnv should *never* map a TyVar. Furthermore, -the range of the TvSubstEnv should *never* include a type headed with +Likewise, expressions may contain type variables or coercion variables. +However, we use different constructors for constructing expression variables, +coercion variables, and type variables, so we carry three VarEnvs for each +variable type. Note that it would be possible to use the CoercionTy constructor +and the Type constructor to combine these environments, but that seems like a +false economy. + +Note that the domain of the VarEnvs must be respected, despite the fact that +TyVar, Id, and CoVar are all type synonyms of the Var type. For example, +TvSubstEnv should *never* map a CoVar (built with the Id constructor) +and the CvSubstEnv should *never* map a TyVar. Furthermore, the range +of the TvSubstEnv should *never* include a type headed with CoercionTy. -} +emptyIdSubstEnv :: IdSubstEnv +emptyIdSubstEnv = emptyVarEnv + emptyTvSubstEnv :: TvSubstEnv emptyTvSubstEnv = emptyVarEnv emptyCvSubstEnv :: CvSubstEnv emptyCvSubstEnv = emptyVarEnv -composeTCvSubstEnv :: InScopeSet - -> (TvSubstEnv, CvSubstEnv) - -> (TvSubstEnv, CvSubstEnv) - -> (TvSubstEnv, CvSubstEnv) --- ^ @(compose env1 env2)(x)@ is @env1(env2(x))@; i.e. apply @env2@ then @env1@. --- It assumes that both are idempotent. --- Typically, @env1@ is the refinement to a base substitution @env2@ -composeTCvSubstEnv in_scope (tenv1, cenv1) (tenv2, cenv2) - = ( tenv1 `plusVarEnv` mapVarEnv (substTy subst1) tenv2 - , cenv1 `plusVarEnv` mapVarEnv (substCo subst1) cenv2 ) - -- First apply env1 to the range of env2 - -- Then combine the two, making sure that env1 loses if - -- both bind the same variable; that's why env1 is the - -- *left* argument to plusVarEnv, because the right arg wins - where - subst1 = TCvSubst in_scope tenv1 cenv1 - -- | Composes two substitutions, applying the second one provided first, --- like in function composition. -composeTCvSubst :: TCvSubst -> TCvSubst -> TCvSubst -composeTCvSubst (TCvSubst is1 tenv1 cenv1) (TCvSubst is2 tenv2 cenv2) - = TCvSubst is3 tenv3 cenv3 +-- like in function composition. This function leaves IdSubstEnv untouched +-- because IdSubstEnv is not used during substitution for types. +composeTCvSubst :: Subst -> Subst -> Subst +composeTCvSubst subst1@(Subst is1 ids1 tenv1 cenv1) (Subst is2 _ tenv2 cenv2) + = Subst is3 ids1 tenv3 cenv3 where is3 = is1 `unionInScope` is2 - (tenv3, cenv3) = composeTCvSubstEnv is3 (tenv1, cenv1) (tenv2, cenv2) + tenv3 = tenv1 `plusVarEnv` mapVarEnv (substTy subst1) tenv2 + cenv3 = cenv1 `plusVarEnv` mapVarEnv (substCo subst1) cenv2 + +emptySubst :: Subst +emptySubst = Subst emptyInScopeSet emptyVarEnv emptyVarEnv emptyVarEnv + +mkEmptySubst :: InScopeSet -> Subst +mkEmptySubst in_scope = Subst in_scope emptyVarEnv emptyVarEnv emptyVarEnv -emptyTCvSubst :: TCvSubst -emptyTCvSubst = TCvSubst emptyInScopeSet emptyTvSubstEnv emptyCvSubstEnv +isEmptySubst :: Subst -> Bool +isEmptySubst (Subst _ id_env tv_env cv_env) + = isEmptyVarEnv id_env && isEmptyVarEnv tv_env && isEmptyVarEnv cv_env -mkEmptyTCvSubst :: InScopeSet -> TCvSubst -mkEmptyTCvSubst is = TCvSubst is emptyTvSubstEnv emptyCvSubstEnv +-- | Checks whether the tyvar and covar environments are empty. +-- This function should be used over 'isEmptySubst' when substituting +-- for types, because types currently do not contain expressions; we can +-- safely disregard the expression environment when deciding whether +-- to skip a substitution. Using 'isEmptyTCvSubst' gives us a non-trivial +-- performance boost (up to 70% less allocation for T18223) +isEmptyTCvSubst :: Subst -> Bool +isEmptyTCvSubst (Subst _ _ tv_env cv_env) + = isEmptyVarEnv tv_env && isEmptyVarEnv cv_env -isEmptyTCvSubst :: TCvSubst -> Bool - -- See Note [Extending the TCvSubstEnv] -isEmptyTCvSubst (TCvSubst _ tenv cenv) = isEmptyVarEnv tenv && isEmptyVarEnv cenv +mkSubst :: InScopeSet -> TvSubstEnv -> CvSubstEnv -> IdSubstEnv -> Subst +mkSubst in_scope tvs cvs ids = Subst in_scope ids tvs cvs -mkTCvSubst :: InScopeSet -> (TvSubstEnv, CvSubstEnv) -> TCvSubst -mkTCvSubst in_scope (tenv, cenv) = TCvSubst in_scope tenv cenv +mkIdSubst :: InScopeSet -> IdSubstEnv -> Subst +mkIdSubst in_scope ids = Subst in_scope ids emptyTvSubstEnv emptyCvSubstEnv -mkTvSubst :: InScopeSet -> TvSubstEnv -> TCvSubst +mkTvSubst :: InScopeSet -> TvSubstEnv -> Subst -- ^ Make a TCvSubst with specified tyvar subst and empty covar subst -mkTvSubst in_scope tenv = TCvSubst in_scope tenv emptyCvSubstEnv +mkTvSubst in_scope tenv = Subst in_scope emptyIdSubstEnv tenv emptyCvSubstEnv -mkCvSubst :: InScopeSet -> CvSubstEnv -> TCvSubst +mkCvSubst :: InScopeSet -> CvSubstEnv -> Subst -- ^ Make a TCvSubst with specified covar subst and empty tyvar subst -mkCvSubst in_scope cenv = TCvSubst in_scope emptyTvSubstEnv cenv +mkCvSubst in_scope cenv = Subst in_scope emptyIdSubstEnv emptyTvSubstEnv cenv -getTvSubstEnv :: TCvSubst -> TvSubstEnv -getTvSubstEnv (TCvSubst _ env _) = env +getIdSubstEnv :: Subst -> IdSubstEnv +getIdSubstEnv (Subst _ ids _ _) = ids -getCvSubstEnv :: TCvSubst -> CvSubstEnv -getCvSubstEnv (TCvSubst _ _ env) = env +getTvSubstEnv :: Subst -> TvSubstEnv +getTvSubstEnv (Subst _ _ tenv _) = tenv -getTCvInScope :: TCvSubst -> InScopeSet -getTCvInScope (TCvSubst in_scope _ _) = in_scope +getCvSubstEnv :: Subst -> CvSubstEnv +getCvSubstEnv (Subst _ _ _ cenv) = cenv + +-- | Find the in-scope set: see Note [The substitution invariant] +getSubstInScope :: Subst -> InScopeSet +getSubstInScope (Subst in_scope _ _ _) = in_scope + +setInScope :: Subst -> InScopeSet -> Subst +setInScope (Subst _ ids tvs cvs) in_scope = Subst in_scope ids tvs cvs -- | Returns the free variables of the types in the range of a substitution as -- a non-deterministic set. -getTCvSubstRangeFVs :: TCvSubst -> VarSet -getTCvSubstRangeFVs (TCvSubst _ tenv cenv) - = unionVarSet tenvFVs cenvFVs +getSubstRangeTyCoFVs :: Subst -> VarSet +getSubstRangeTyCoFVs (Subst _ _ tenv cenv) + = tenvFVs `unionVarSet` cenvFVs where tenvFVs = shallowTyCoVarsOfTyVarEnv tenv cenvFVs = shallowTyCoVarsOfCoVarEnv cenv -isInScope :: Var -> TCvSubst -> Bool -isInScope v (TCvSubst in_scope _ _) = v `elemInScopeSet` in_scope +isInScope :: Var -> Subst -> Bool +isInScope v (Subst in_scope _ _ _) = v `elemInScopeSet` in_scope -elemTCvSubst :: Var -> TCvSubst -> Bool -elemTCvSubst v (TCvSubst _ tenv cenv) +elemSubst :: Var -> Subst -> Bool +elemSubst v (Subst _ ids tenv cenv) | isTyVar v = v `elemVarEnv` tenv - | otherwise + | isCoVar v = v `elemVarEnv` cenv - -notElemTCvSubst :: Var -> TCvSubst -> Bool -notElemTCvSubst v = not . elemTCvSubst v - -setTvSubstEnv :: TCvSubst -> TvSubstEnv -> TCvSubst -setTvSubstEnv (TCvSubst in_scope _ cenv) tenv = TCvSubst in_scope tenv cenv - -setCvSubstEnv :: TCvSubst -> CvSubstEnv -> TCvSubst -setCvSubstEnv (TCvSubst in_scope tenv _) cenv = TCvSubst in_scope tenv cenv - -zapTCvSubst :: TCvSubst -> TCvSubst -zapTCvSubst (TCvSubst in_scope _ _) = TCvSubst in_scope emptyVarEnv emptyVarEnv - -extendTCvInScope :: TCvSubst -> Var -> TCvSubst -extendTCvInScope (TCvSubst in_scope tenv cenv) var - = TCvSubst (extendInScopeSet in_scope var) tenv cenv - -extendTCvInScopeList :: TCvSubst -> [Var] -> TCvSubst -extendTCvInScopeList (TCvSubst in_scope tenv cenv) vars - = TCvSubst (extendInScopeSetList in_scope vars) tenv cenv - -extendTCvInScopeSet :: TCvSubst -> VarSet -> TCvSubst -extendTCvInScopeSet (TCvSubst in_scope tenv cenv) vars - = TCvSubst (extendInScopeSetSet in_scope vars) tenv cenv - -extendTCvSubst :: TCvSubst -> TyCoVar -> Type -> TCvSubst + | otherwise + = v `elemVarEnv` ids + +notElemSubst :: Var -> Subst -> Bool +notElemSubst v = not . elemSubst v + +-- | Remove all substitutions that might have been built up +-- while preserving the in-scope set +-- originally called zapSubstEnv +zapSubst :: Subst -> Subst +zapSubst (Subst in_scope _ _ _) = Subst in_scope emptyVarEnv emptyVarEnv emptyVarEnv + +-- | Add the 'Var' to the in-scope set +extendSubstInScope :: Subst -> Var -> Subst +extendSubstInScope (Subst in_scope ids tvs cvs) v + = Subst (in_scope `extendInScopeSet` v) + ids tvs cvs + +-- | Add the 'Var's to the in-scope set: see also 'extendInScope' +extendSubstInScopeList :: Subst -> [Var] -> Subst +extendSubstInScopeList (Subst in_scope ids tvs cvs) vs + = Subst (in_scope `extendInScopeSetList` vs) + ids tvs cvs + +-- | Add the 'Var's to the in-scope set: see also 'extendInScope' +extendSubstInScopeSet :: Subst -> VarSet -> Subst +extendSubstInScopeSet (Subst in_scope ids tvs cvs) vs + = Subst (in_scope `extendInScopeSetSet` vs) + ids tvs cvs + +extendTCvSubst :: Subst -> TyCoVar -> Type -> Subst extendTCvSubst subst v ty | isTyVar v = extendTvSubst subst v ty @@ -333,102 +355,119 @@ extendTCvSubst subst v ty | otherwise = pprPanic "extendTCvSubst" (ppr v <+> text "|->" <+> ppr ty) -extendTCvSubstWithClone :: TCvSubst -> TyCoVar -> TyCoVar -> TCvSubst +extendTCvSubstWithClone :: Subst -> TyCoVar -> TyCoVar -> Subst extendTCvSubstWithClone subst tcv | isTyVar tcv = extendTvSubstWithClone subst tcv | otherwise = extendCvSubstWithClone subst tcv -extendTvSubst :: TCvSubst -> TyVar -> Type -> TCvSubst -extendTvSubst (TCvSubst in_scope tenv cenv) tv ty - = TCvSubst in_scope (extendVarEnv tenv tv ty) cenv +-- | Add a substitution for a 'TyVar' to the 'Subst' +-- The 'TyVar' *must* be a real TyVar, and not a CoVar +-- You must ensure that the in-scope set is such that +-- Note [The substitution invariant] holds +-- after extending the substitution like this. +extendTvSubst :: Subst -> TyVar -> Type -> Subst +extendTvSubst (Subst in_scope ids tvs cvs) tv ty + = assert (isTyVar tv) $ + Subst in_scope ids (extendVarEnv tvs tv ty) cvs -extendTvSubstBinderAndInScope :: TCvSubst -> TyCoBinder -> Type -> TCvSubst +extendTvSubstBinderAndInScope :: Subst -> TyCoBinder -> Type -> Subst extendTvSubstBinderAndInScope subst (Named (Bndr v _)) ty = assert (isTyVar v ) extendTvSubstAndInScope subst v ty extendTvSubstBinderAndInScope subst (Anon {}) _ = subst -extendTvSubstWithClone :: TCvSubst -> TyVar -> TyVar -> TCvSubst +extendTvSubstWithClone :: Subst -> TyVar -> TyVar -> Subst -- Adds a new tv -> tv mapping, /and/ extends the in-scope set with the clone -- Does not look in the kind of the new variable; -- those variables should be in scope already -extendTvSubstWithClone (TCvSubst in_scope tenv cenv) tv tv' - = TCvSubst (extendInScopeSet in_scope tv') +extendTvSubstWithClone (Subst in_scope idenv tenv cenv) tv tv' + = Subst (extendInScopeSet in_scope tv') + idenv (extendVarEnv tenv tv (mkTyVarTy tv')) cenv -extendCvSubst :: TCvSubst -> CoVar -> Coercion -> TCvSubst -extendCvSubst (TCvSubst in_scope tenv cenv) v co - = TCvSubst in_scope tenv (extendVarEnv cenv v co) - -extendCvSubstWithClone :: TCvSubst -> CoVar -> CoVar -> TCvSubst -extendCvSubstWithClone (TCvSubst in_scope tenv cenv) cv cv' - = TCvSubst (extendInScopeSetSet in_scope new_in_scope) +-- | Add a substitution from a 'CoVar' to a 'Coercion' to the 'Subst': +-- you must ensure that the in-scope set satisfies +-- Note [The substitution invariant] +-- after extending the substitution like this +extendCvSubst :: Subst -> CoVar -> Coercion -> Subst +extendCvSubst (Subst in_scope ids tvs cvs) v r + = assert (isCoVar v) $ + Subst in_scope ids tvs (extendVarEnv cvs v r) + +extendCvSubstWithClone :: Subst -> CoVar -> CoVar -> Subst +extendCvSubstWithClone (Subst in_scope ids tenv cenv) cv cv' + = Subst (extendInScopeSetSet in_scope new_in_scope) + ids tenv (extendVarEnv cenv cv (mkCoVarCo cv')) where new_in_scope = tyCoVarsOfType (varType cv') `extendVarSet` cv' -extendTvSubstAndInScope :: TCvSubst -> TyVar -> Type -> TCvSubst +extendTvSubstAndInScope :: Subst -> TyVar -> Type -> Subst -- Also extends the in-scope set -extendTvSubstAndInScope (TCvSubst in_scope tenv cenv) tv ty - = TCvSubst (in_scope `extendInScopeSetSet` tyCoVarsOfType ty) +extendTvSubstAndInScope (Subst in_scope ids tenv cenv) tv ty + = Subst (in_scope `extendInScopeSetSet` tyCoVarsOfType ty) + ids (extendVarEnv tenv tv ty) cenv -extendTvSubstList :: TCvSubst -> [Var] -> [Type] -> TCvSubst -extendTvSubstList subst tvs tys - = foldl2 extendTvSubst subst tvs tys +-- | Adds multiple 'TyVar' substitutions to the 'Subst': see also 'extendTvSubst' +extendTvSubstList :: Subst -> [(TyVar,Type)] -> Subst +extendTvSubstList subst vrs + = foldl' extend subst vrs + where + extend subst (v, r) = extendTvSubst subst v r -extendTCvSubstList :: TCvSubst -> [Var] -> [Type] -> TCvSubst +extendTCvSubstList :: Subst -> [Var] -> [Type] -> Subst extendTCvSubstList subst tvs tys = foldl2 extendTCvSubst subst tvs tys -unionTCvSubst :: TCvSubst -> TCvSubst -> TCvSubst +unionSubst :: Subst -> Subst -> Subst -- Works when the ranges are disjoint -unionTCvSubst (TCvSubst in_scope1 tenv1 cenv1) (TCvSubst in_scope2 tenv2 cenv2) - = assert (tenv1 `disjointVarEnv` tenv2 +unionSubst (Subst in_scope1 ids1 tenv1 cenv1) (Subst in_scope2 ids2 tenv2 cenv2) + = assert (ids1 `disjointVarEnv` ids2 + && tenv1 `disjointVarEnv` tenv2 && cenv1 `disjointVarEnv` cenv2 ) - TCvSubst (in_scope1 `unionInScope` in_scope2) - (tenv1 `plusVarEnv` tenv2) - (cenv1 `plusVarEnv` cenv2) - --- mkTvSubstPrs and zipTvSubst generate the in-scope set from --- the types given; but it's just a thunk so with a bit of luck --- it'll never be evaluated - --- | Generates the in-scope set for the 'TCvSubst' from the types in the incoming --- environment. No CoVars, please! -zipTvSubst :: HasDebugCallStack => [TyVar] -> [Type] -> TCvSubst + Subst (in_scope1 `unionInScope` in_scope2) + (ids1 `plusVarEnv` ids2) + (tenv1 `plusVarEnv` tenv2) + (cenv1 `plusVarEnv` cenv2) + +-- | Generates the in-scope set for the 'Subst' from the types in the incoming +-- environment. No CoVars or Ids, please! +zipTvSubst :: HasDebugCallStack => [TyVar] -> [Type] -> Subst zipTvSubst tvs tys = mkTvSubst (mkInScopeSet (shallowTyCoVarsOfTypes tys)) tenv where tenv = zipTyEnv tvs tys --- | Generates the in-scope set for the 'TCvSubst' from the types in the incoming +-- | Generates the in-scope set for the 'Subst' from the types in the incoming -- environment. No TyVars, please! -zipCvSubst :: HasDebugCallStack => [CoVar] -> [Coercion] -> TCvSubst +zipCvSubst :: HasDebugCallStack => [CoVar] -> [Coercion] -> Subst zipCvSubst cvs cos - = TCvSubst (mkInScopeSet (shallowTyCoVarsOfCos cos)) emptyTvSubstEnv cenv + = mkCvSubst (mkInScopeSet (shallowTyCoVarsOfCos cos)) cenv where cenv = zipCoEnv cvs cos -zipTCvSubst :: HasDebugCallStack => [TyCoVar] -> [Type] -> TCvSubst + +zipTCvSubst :: HasDebugCallStack => [TyCoVar] -> [Type] -> Subst zipTCvSubst tcvs tys = zip_tcvsubst tcvs tys $ - mkEmptyTCvSubst $ mkInScopeSet $ shallowTyCoVarsOfTypes tys - where zip_tcvsubst :: [TyCoVar] -> [Type] -> TCvSubst -> TCvSubst + mkEmptySubst $ mkInScopeSet $ shallowTyCoVarsOfTypes tys + where zip_tcvsubst :: [TyCoVar] -> [Type] -> Subst -> Subst zip_tcvsubst (tv:tvs) (ty:tys) subst = zip_tcvsubst tvs tys (extendTCvSubst subst tv ty) zip_tcvsubst [] [] subst = subst -- empty case zip_tcvsubst _ _ _ = pprPanic "zipTCvSubst: length mismatch" - (ppr tcvs <+> ppr tys) + (ppr tcvs <+> ppr tys) -- | Generates the in-scope set for the 'TCvSubst' from the types in the --- incoming environment. No CoVars, please! -mkTvSubstPrs :: [(TyVar, Type)] -> TCvSubst -mkTvSubstPrs [] = emptyTCvSubst +-- incoming environment. No CoVars, please! The InScopeSet is just a thunk +-- so with a bit of luck it'll never be evaluated +mkTvSubstPrs :: [(TyVar, Type)] -> Subst +mkTvSubstPrs [] = emptySubst mkTvSubstPrs prs = assertPpr onlyTyVarsAndNoCoercionTy (text "prs" <+> ppr prs) $ mkTvSubst in_scope tenv @@ -438,6 +477,7 @@ mkTvSubstPrs prs = and [ isTyVar tv && not (isCoercionTy ty) | (tv, ty) <- prs ] +-- | The InScopeSet is just a thunk so with a bit of luck it'll never be evaluated zipTyEnv :: HasDebugCallStack => [TyVar] -> [Type] -> TvSubstEnv zipTyEnv tyvars tys | debugIsOn @@ -467,12 +507,17 @@ zipCoEnv cvs cos | otherwise = mkVarEnv (zipEqual "zipCoEnv" cvs cos) -instance Outputable TCvSubst where - ppr (TCvSubst ins tenv cenv) - = brackets $ sep[ text "TCvSubst", - nest 2 (text "In scope:" <+> ppr ins), - nest 2 (text "Type env:" <+> ppr tenv), - nest 2 (text "Co env:" <+> ppr cenv) ] +-- Pretty printing, for debugging only + +instance Outputable Subst where + ppr (Subst in_scope ids tvs cvs) + = text "<InScope =" <+> in_scope_doc + $$ text " IdSubst =" <+> ppr ids + $$ text " TvSubst =" <+> ppr tvs + $$ text " CvSubst =" <+> ppr cvs + <> char '>' + where + in_scope_doc = pprVarSet (getInScopeVars in_scope) (braces . fsep . map ppr) {- %************************************************************************ @@ -614,16 +659,17 @@ substTysWithCoVars cvs cos = assert (cvs `equalLength` cos ) -- to the in-scope set. This is useful for the case when the free variables -- aren't already in the in-scope set or easily available. -- See also Note [The substitution invariant]. -substTyAddInScope :: TCvSubst -> Type -> Type +substTyAddInScope :: Subst -> Type -> Type substTyAddInScope subst ty = - substTy (extendTCvInScopeSet subst $ tyCoVarsOfType ty) ty + substTy (extendSubstInScopeSet subst $ tyCoVarsOfType ty) ty -- | When calling `substTy` it should be the case that the in-scope set in -- the substitution is a superset of the free vars of the range of the -- substitution. -- See also Note [The substitution invariant]. -isValidTCvSubst :: TCvSubst -> Bool -isValidTCvSubst (TCvSubst in_scope tenv cenv) = +-- TODO: take into account ids and rename as isValidSubst +isValidTCvSubst :: Subst -> Bool +isValidTCvSubst (Subst in_scope _ tenv cenv) = (tenvFVs `varSetInScope` in_scope) && (cenvFVs `varSetInScope` in_scope) where @@ -632,8 +678,8 @@ isValidTCvSubst (TCvSubst in_scope tenv cenv) = -- | This checks if the substitution satisfies the invariant from -- Note [The substitution invariant]. -checkValidSubst :: HasDebugCallStack => TCvSubst -> [Type] -> [Coercion] -> a -> a -checkValidSubst subst@(TCvSubst in_scope tenv cenv) tys cos a +checkValidSubst :: HasDebugCallStack => Subst -> [Type] -> [Coercion] -> a -> a +checkValidSubst subst@(Subst in_scope _ tenv cenv) tys cos a = assertPpr (isValidTCvSubst subst) (text "in_scope" <+> ppr in_scope $$ text "tenv" <+> ppr tenv $$ @@ -663,9 +709,9 @@ checkValidSubst subst@(TCvSubst in_scope tenv cenv) tys cos a -- | Substitute within a 'Type' -- The substitution has to satisfy the invariants described in -- Note [The substitution invariant]. -substTy :: HasDebugCallStack => TCvSubst -> Type -> Type +substTy :: HasDebugCallStack => Subst -> Type -> Type substTy subst ty - | isEmptyTCvSubst subst = ty + | isEmptyTCvSubst subst = ty | otherwise = checkValidSubst subst [ty] [] $ subst_ty subst ty @@ -674,26 +720,26 @@ substTy subst ty -- Note [The substitution invariant]. -- The goal of #11371 is to migrate all the calls of substTyUnchecked to -- substTy and remove this function. Please don't use in new code. -substTyUnchecked :: TCvSubst -> Type -> Type +substTyUnchecked :: Subst -> Type -> Type substTyUnchecked subst ty - | isEmptyTCvSubst subst = ty + | isEmptyTCvSubst subst = ty | otherwise = subst_ty subst ty -substScaledTy :: HasDebugCallStack => TCvSubst -> Scaled Type -> Scaled Type +substScaledTy :: HasDebugCallStack => Subst -> Scaled Type -> Scaled Type substScaledTy subst scaled_ty = mapScaledType (substTy subst) scaled_ty -substScaledTyUnchecked :: HasDebugCallStack => TCvSubst -> Scaled Type -> Scaled Type +substScaledTyUnchecked :: HasDebugCallStack => Subst -> Scaled Type -> Scaled Type substScaledTyUnchecked subst scaled_ty = mapScaledType (substTyUnchecked subst) scaled_ty -- | Substitute within several 'Type's -- The substitution has to satisfy the invariants described in -- Note [The substitution invariant]. -substTys :: HasDebugCallStack => TCvSubst -> [Type] -> [Type] +substTys :: HasDebugCallStack => Subst -> [Type] -> [Type] substTys subst tys | isEmptyTCvSubst subst = tys | otherwise = checkValidSubst subst tys [] $ map (subst_ty subst) tys -substScaledTys :: HasDebugCallStack => TCvSubst -> [Scaled Type] -> [Scaled Type] +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) [] $ @@ -704,12 +750,12 @@ substScaledTys subst scaled_tys -- Note [The substitution invariant]. -- The goal of #11371 is to migrate all the calls of substTysUnchecked to -- substTys and remove this function. Please don't use in new code. -substTysUnchecked :: TCvSubst -> [Type] -> [Type] +substTysUnchecked :: Subst -> [Type] -> [Type] substTysUnchecked subst tys | isEmptyTCvSubst subst = tys | otherwise = map (subst_ty subst) tys -substScaledTysUnchecked :: TCvSubst -> [Scaled Type] -> [Scaled Type] +substScaledTysUnchecked :: Subst -> [Scaled Type] -> [Scaled Type] substScaledTysUnchecked subst tys | isEmptyTCvSubst subst = tys | otherwise = map (mapScaledType (subst_ty subst)) tys @@ -717,7 +763,7 @@ substScaledTysUnchecked subst tys -- | Substitute within a 'ThetaType' -- The substitution has to satisfy the invariants described in -- Note [The substitution invariant]. -substTheta :: HasDebugCallStack => TCvSubst -> ThetaType -> ThetaType +substTheta :: HasDebugCallStack => Subst -> ThetaType -> ThetaType substTheta = substTys -- | Substitute within a 'ThetaType' disabling the sanity checks. @@ -725,11 +771,11 @@ substTheta = substTys -- Note [The substitution invariant]. -- The goal of #11371 is to migrate all the calls of substThetaUnchecked to -- substTheta and remove this function. Please don't use in new code. -substThetaUnchecked :: TCvSubst -> ThetaType -> ThetaType +substThetaUnchecked :: Subst -> ThetaType -> ThetaType substThetaUnchecked = substTysUnchecked -subst_ty :: TCvSubst -> Type -> Type +subst_ty :: Subst -> Type -> Type -- subst_ty is the main workhorse for type substitution -- -- Note that the in_scope set is poked only if we hit a forall @@ -762,34 +808,34 @@ subst_ty subst ty go (CastTy ty co) = (mkCastTy $! (go ty)) $! (subst_co subst co) go (CoercionTy co) = CoercionTy $! (subst_co subst co) -substTyVar :: TCvSubst -> TyVar -> Type -substTyVar (TCvSubst _ tenv _) tv +substTyVar :: Subst -> TyVar -> Type +substTyVar (Subst _ _ tenv _) tv = assert (isTyVar tv) $ case lookupVarEnv tenv tv of Just ty -> ty Nothing -> TyVarTy tv -substTyVars :: TCvSubst -> [TyVar] -> [Type] +substTyVars :: Subst -> [TyVar] -> [Type] substTyVars subst = map $ substTyVar subst -substTyCoVars :: TCvSubst -> [TyCoVar] -> [Type] +substTyCoVars :: Subst -> [TyCoVar] -> [Type] substTyCoVars subst = map $ substTyCoVar subst -substTyCoVar :: TCvSubst -> TyCoVar -> Type +substTyCoVar :: Subst -> TyCoVar -> Type substTyCoVar subst tv | isTyVar tv = substTyVar subst tv | otherwise = CoercionTy $ substCoVar subst tv -lookupTyVar :: TCvSubst -> TyVar -> Maybe Type - -- See Note [Extending the TCvSubstEnv] -lookupTyVar (TCvSubst _ tenv _) tv +lookupTyVar :: Subst -> TyVar -> Maybe Type + -- See Note [Extending the TvSubstEnv and CvSubstEnv] +lookupTyVar (Subst _ _ tenv _) tv = assert (isTyVar tv ) lookupVarEnv tenv tv -- | Substitute within a 'Coercion' -- The substitution has to satisfy the invariants described in -- Note [The substitution invariant]. -substCo :: HasDebugCallStack => TCvSubst -> Coercion -> Coercion +substCo :: HasDebugCallStack => Subst -> Coercion -> Coercion substCo subst co | isEmptyTCvSubst subst = co | otherwise = checkValidSubst subst [] [co] $ subst_co subst co @@ -799,7 +845,7 @@ substCo subst co -- Note [The substitution invariant]. -- The goal of #11371 is to migrate all the calls of substCoUnchecked to -- substCo and remove this function. Please don't use in new code. -substCoUnchecked :: TCvSubst -> Coercion -> Coercion +substCoUnchecked :: Subst -> Coercion -> Coercion substCoUnchecked subst co | isEmptyTCvSubst subst = co | otherwise = subst_co subst co @@ -807,12 +853,12 @@ substCoUnchecked subst co -- | Substitute within several 'Coercion's -- The substitution has to satisfy the invariants described in -- Note [The substitution invariant]. -substCos :: HasDebugCallStack => TCvSubst -> [Coercion] -> [Coercion] +substCos :: HasDebugCallStack => Subst -> [Coercion] -> [Coercion] substCos subst cos | isEmptyTCvSubst subst = cos | otherwise = checkValidSubst subst [] cos $ map (subst_co subst) cos -subst_co :: TCvSubst -> Coercion -> Coercion +subst_co :: Subst -> Coercion -> Coercion subst_co subst co = go co where @@ -858,8 +904,8 @@ subst_co subst co go_hole h@(CoercionHole { ch_co_var = cv }) = h { ch_co_var = updateVarType go_ty cv } -substForAllCoBndr :: TCvSubst -> TyCoVar -> KindCoercion - -> (TCvSubst, TyCoVar, Coercion) +substForAllCoBndr :: Subst -> TyCoVar -> KindCoercion + -> (Subst, TyCoVar, Coercion) substForAllCoBndr subst = substForAllCoBndrUsing False (substCo subst) subst @@ -868,27 +914,27 @@ substForAllCoBndr subst -- Note [The substitution invariant]. -- The goal of #11371 is to migrate all the calls of substCoUnchecked to -- substCo and remove this function. Please don't use in new code. -substForAllCoBndrUnchecked :: TCvSubst -> TyCoVar -> KindCoercion - -> (TCvSubst, TyCoVar, Coercion) +substForAllCoBndrUnchecked :: Subst -> TyCoVar -> KindCoercion + -> (Subst, TyCoVar, Coercion) substForAllCoBndrUnchecked subst = substForAllCoBndrUsing False (substCoUnchecked subst) subst -- See Note [Sym and ForAllCo] substForAllCoBndrUsing :: Bool -- apply sym to binder? -> (Coercion -> Coercion) -- transformation to kind co - -> TCvSubst -> TyCoVar -> KindCoercion - -> (TCvSubst, TyCoVar, KindCoercion) + -> 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 - -> TCvSubst -> TyVar -> KindCoercion - -> (TCvSubst, TyVar, KindCoercion) -substForAllCoTyVarBndrUsing sym sco (TCvSubst in_scope tenv cenv) old_var old_kind_co + -> Subst -> TyVar -> KindCoercion + -> (Subst, TyVar, KindCoercion) +substForAllCoTyVarBndrUsing sym sco (Subst in_scope idenv tenv cenv) old_var old_kind_co = assert (isTyVar old_var ) - ( TCvSubst (in_scope `extendInScopeSet` new_var) new_env cenv + ( 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 @@ -912,12 +958,12 @@ substForAllCoTyVarBndrUsing sym sco (TCvSubst in_scope tenv cenv) old_var old_ki substForAllCoCoVarBndrUsing :: Bool -- apply sym to binder? -> (Coercion -> Coercion) -- transformation to kind co - -> TCvSubst -> CoVar -> KindCoercion - -> (TCvSubst, CoVar, KindCoercion) -substForAllCoCoVarBndrUsing sym sco (TCvSubst in_scope tenv cenv) + -> Subst -> CoVar -> KindCoercion + -> (Subst, CoVar, KindCoercion) +substForAllCoCoVarBndrUsing sym sco (Subst in_scope idenv tenv cenv) old_var old_kind_co = assert (isCoVar old_var ) - ( TCvSubst (in_scope `extendInScopeSet` new_var) tenv new_cenv + ( 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 @@ -935,31 +981,31 @@ substForAllCoCoVarBndrUsing sym sco (TCvSubst in_scope tenv cenv) new_var_type | sym = h2 | otherwise = h1 -substCoVar :: TCvSubst -> CoVar -> Coercion -substCoVar (TCvSubst _ _ cenv) cv +substCoVar :: Subst -> CoVar -> Coercion +substCoVar (Subst _ _ _ cenv) cv = case lookupVarEnv cenv cv of Just co -> co Nothing -> CoVarCo cv -substCoVars :: TCvSubst -> [CoVar] -> [Coercion] +substCoVars :: Subst -> [CoVar] -> [Coercion] substCoVars subst cvs = map (substCoVar subst) cvs -lookupCoVar :: TCvSubst -> Var -> Maybe Coercion -lookupCoVar (TCvSubst _ _ cenv) v = lookupVarEnv cenv v +lookupCoVar :: Subst -> Var -> Maybe Coercion +lookupCoVar (Subst _ _ _ cenv) v = lookupVarEnv cenv v -substTyVarBndr :: HasDebugCallStack => TCvSubst -> TyVar -> (TCvSubst, TyVar) +substTyVarBndr :: HasDebugCallStack => Subst -> TyVar -> (Subst, TyVar) substTyVarBndr = substTyVarBndrUsing substTy -substTyVarBndrs :: HasDebugCallStack => TCvSubst -> [TyVar] -> (TCvSubst, [TyVar]) +substTyVarBndrs :: HasDebugCallStack => Subst -> [TyVar] -> (Subst, [TyVar]) substTyVarBndrs = mapAccumL substTyVarBndr -substVarBndr :: HasDebugCallStack => TCvSubst -> TyCoVar -> (TCvSubst, TyCoVar) +substVarBndr :: HasDebugCallStack => Subst -> TyCoVar -> (Subst, TyCoVar) substVarBndr = substVarBndrUsing substTy -substVarBndrs :: HasDebugCallStack => TCvSubst -> [TyCoVar] -> (TCvSubst, [TyCoVar]) +substVarBndrs :: HasDebugCallStack => Subst -> [TyCoVar] -> (Subst, [TyCoVar]) substVarBndrs = mapAccumL substVarBndr -substCoVarBndr :: HasDebugCallStack => TCvSubst -> CoVar -> (TCvSubst, CoVar) +substCoVarBndr :: HasDebugCallStack => Subst -> CoVar -> (Subst, CoVar) substCoVarBndr = substCoVarBndrUsing substTy -- | Like 'substVarBndr', but disables sanity checks. @@ -967,11 +1013,11 @@ substCoVarBndr = substCoVarBndrUsing substTy -- Note [The substitution invariant]. -- The goal of #11371 is to migrate all the calls of substTyUnchecked to -- substTy and remove this function. Please don't use in new code. -substVarBndrUnchecked :: TCvSubst -> TyCoVar -> (TCvSubst, TyCoVar) +substVarBndrUnchecked :: Subst -> TyCoVar -> (Subst, TyCoVar) substVarBndrUnchecked = substVarBndrUsing substTyUnchecked -substVarBndrUsing :: (TCvSubst -> Type -> Type) - -> TCvSubst -> TyCoVar -> (TCvSubst, TyCoVar) +substVarBndrUsing :: (Subst -> Type -> Type) + -> Subst -> TyCoVar -> (Subst, TyCoVar) substVarBndrUsing subst_fn subst v | isTyVar v = substTyVarBndrUsing subst_fn subst v | otherwise = substCoVarBndrUsing subst_fn subst v @@ -980,12 +1026,12 @@ substVarBndrUsing subst_fn subst v -- extended subst and a new tyvar. -- Use the supplied function to substitute in the kind substTyVarBndrUsing - :: (TCvSubst -> Type -> Type) -- ^ Use this to substitute in the kind - -> TCvSubst -> TyVar -> (TCvSubst, TyVar) -substTyVarBndrUsing subst_fn subst@(TCvSubst in_scope tenv cenv) old_var + :: (Subst -> Type -> Type) -- ^ Use this to substitute in the kind + -> Subst -> TyVar -> (Subst, TyVar) +substTyVarBndrUsing subst_fn subst@(Subst in_scope idenv tenv cenv) old_var = assertPpr _no_capture (pprTyVar old_var $$ pprTyVar new_var $$ ppr subst) $ assert (isTyVar old_var ) - (TCvSubst (in_scope `extendInScopeSet` new_var) new_env cenv, new_var) + (Subst (in_scope `extendInScopeSet` new_var) idenv new_env cenv, new_var) where new_env | no_change = delVarEnv tenv old_var | otherwise = extendVarEnv tenv old_var (TyVarTy new_var) @@ -998,7 +1044,7 @@ substTyVarBndrUsing subst_fn subst@(TCvSubst in_scope tenv cenv) old_var no_change = no_kind_change && (new_var == old_var) -- no_change means that the new_var is identical in -- all respects to the old_var (same unique, same kind) - -- See Note [Extending the TCvSubstEnv] + -- See Note [Extending the TvSubstEnv and CvSubstEnv] -- -- In that case we don't need to extend the substitution -- to map old to new. But instead we must zap any @@ -1015,11 +1061,11 @@ substTyVarBndrUsing subst_fn subst@(TCvSubst in_scope tenv cenv) old_var -- extended subst and a new covar. -- Use the supplied function to substitute in the kind substCoVarBndrUsing - :: (TCvSubst -> Type -> Type) - -> TCvSubst -> CoVar -> (TCvSubst, CoVar) -substCoVarBndrUsing subst_fn subst@(TCvSubst in_scope tenv cenv) old_var + :: (Subst -> Type -> Type) + -> Subst -> CoVar -> (Subst, CoVar) +substCoVarBndrUsing subst_fn subst@(Subst in_scope idenv tenv cenv) old_var = assert (isCoVar old_var) - (TCvSubst (in_scope `extendInScopeSet` new_var) tenv new_cenv, new_var) + (Subst (in_scope `extendInScopeSet` new_var) idenv tenv new_cenv, new_var) where new_co = mkCoVarCo new_var no_kind_change = noFreeVarsOfTypes [t1, t2] @@ -1038,11 +1084,14 @@ substCoVarBndrUsing subst_fn subst@(TCvSubst in_scope tenv cenv) old_var -- It's important to do the substitution for coercions, -- because they can have free type variables -cloneTyVarBndr :: TCvSubst -> TyVar -> Unique -> (TCvSubst, TyVar) -cloneTyVarBndr subst@(TCvSubst in_scope tv_env cv_env) tv uniq +cloneTyVarBndr :: Subst -> TyVar -> Unique -> (Subst, TyVar) +cloneTyVarBndr subst@(Subst in_scope id_env tv_env cv_env) tv uniq = assertPpr (isTyVar tv) (ppr tv) -- I think it's only called on TyVars - (TCvSubst (extendInScopeSet in_scope tv') - (extendVarEnv tv_env tv (mkTyVarTy tv')) cv_env, tv') + ( Subst (extendInScopeSet in_scope tv') + id_env + (extendVarEnv tv_env tv (mkTyVarTy tv')) + cv_env + , tv') where old_ki = tyVarKind tv no_kind_change = noFreeVarsOfType old_ki -- verify that kind is closed @@ -1052,7 +1101,7 @@ cloneTyVarBndr subst@(TCvSubst in_scope tv_env cv_env) tv uniq tv' = setVarUnique tv1 uniq -cloneTyVarBndrs :: TCvSubst -> [TyVar] -> UniqSupply -> (TCvSubst, [TyVar]) +cloneTyVarBndrs :: Subst -> [TyVar] -> UniqSupply -> (Subst, [TyVar]) cloneTyVarBndrs subst [] _usupply = (subst, []) cloneTyVarBndrs subst (t:ts) usupply = (subst'', tv:tvs) where @@ -1060,9 +1109,8 @@ cloneTyVarBndrs subst (t:ts) usupply = (subst'', tv:tvs) (subst' , tv ) = cloneTyVarBndr subst t uniq (subst'', tvs) = cloneTyVarBndrs subst' ts usupply' -substTyCoBndr :: TCvSubst -> TyCoBinder -> (TCvSubst, TyCoBinder) +substTyCoBndr :: Subst -> TyCoBinder -> (Subst, TyCoBinder) substTyCoBndr subst (Anon af ty) = (subst, Anon af (substScaledTy subst ty)) substTyCoBndr subst (Named (Bndr tv vis)) = (subst', Named (Bndr tv' vis)) where (subst', tv') = substVarBndr subst tv - diff --git a/compiler/GHC/Core/Type.hs b/compiler/GHC/Core/Type.hs index 166a56cabb..5e769acaa9 100644 --- a/compiler/GHC/Core/Type.hs +++ b/compiler/GHC/Core/Type.hs @@ -193,25 +193,26 @@ module GHC.Core.Type ( -- * Main type substitution data types TvSubstEnv, -- Representation widely visible - TCvSubst(..), -- Representation visible to a few friends + IdSubstEnv, + Subst(..), -- Representation visible to a few friends -- ** Manipulating type substitutions - emptyTvSubstEnv, emptyTCvSubst, mkEmptyTCvSubst, + emptyTvSubstEnv, emptySubst, mkEmptySubst, - mkTCvSubst, zipTvSubst, mkTvSubstPrs, + mkSubst, zipTvSubst, mkTvSubstPrs, zipTCvSubst, - notElemTCvSubst, - getTvSubstEnv, setTvSubstEnv, - zapTCvSubst, getTCvInScope, getTCvSubstRangeFVs, - extendTCvInScope, extendTCvInScopeList, extendTCvInScopeSet, + notElemSubst, + getTvSubstEnv, + zapSubst, getSubstInScope, setInScope, getSubstRangeTyCoFVs, + extendSubstInScope, extendSubstInScopeList, extendSubstInScopeSet, extendTCvSubst, extendCvSubst, extendTvSubst, extendTvSubstBinderAndInScope, extendTvSubstList, extendTvSubstAndInScope, extendTCvSubstList, extendTvSubstWithClone, extendTCvSubstWithClone, - isInScope, composeTCvSubstEnv, composeTCvSubst, zipTyEnv, zipCoEnv, - isEmptyTCvSubst, unionTCvSubst, + isInScope, composeTCvSubst, zipTyEnv, zipCoEnv, + isEmptySubst, unionSubst, isEmptyTCvSubst, -- ** Performing substitution on types and kinds substTy, substTys, substScaledTy, substScaledTys, substTyWith, substTysWith, substTheta, @@ -486,7 +487,7 @@ expand_syn tvs rhs arg_tys | null tvs = mkAppTys rhs arg_tys | otherwise = go empty_subst tvs arg_tys where - empty_subst = mkEmptyTCvSubst in_scope + empty_subst = mkEmptySubst in_scope in_scope = mkInScopeSet $ shallowTyCoVarsOfTypes $ arg_tys -- The free vars of 'rhs' should all be bound by 'tenv', -- so we only need the free vars of tys @@ -550,7 +551,7 @@ expandTypeSynonyms :: Type -> Type -- -- Keep this synchronized with 'synonymTyConsOfType' expandTypeSynonyms ty - = go (mkEmptyTCvSubst in_scope) ty + = go (mkEmptySubst in_scope) ty where in_scope = mkInScopeSet (tyCoVarsOfType ty) @@ -1360,7 +1361,7 @@ piResultTy_maybe ty arg = case coreFullView ty of FunTy { ft_res = res } -> Just res ForAllTy (Bndr tv _) res - -> let empty_subst = mkEmptyTCvSubst $ mkInScopeSet $ + -> let empty_subst = mkEmptySubst $ mkInScopeSet $ tyCoVarsOfTypes [arg,res] in Just (substTy (extendTCvSubst empty_subst tv arg) res) @@ -1402,9 +1403,9 @@ piResultTys ty orig_args@(arg:args) | otherwise = pprPanic "piResultTys1" (ppr ty $$ ppr orig_args) where - init_subst = mkEmptyTCvSubst $ mkInScopeSet (tyCoVarsOfTypes (ty:orig_args)) + init_subst = mkEmptySubst $ mkInScopeSet (tyCoVarsOfTypes (ty:orig_args)) - go :: TCvSubst -> Type -> [Type] -> Type + go :: Subst -> Type -> [Type] -> Type go subst ty [] = substTyUnchecked subst ty go subst ty all_args@(arg:args) @@ -1641,7 +1642,7 @@ mk_cast_ty orig_ty co = go orig_ty , let fvs = tyCoVarsOfCo co = -- have to make sure that pushing the co in doesn't capture the bound var! if tv `elemVarSet` fvs - then let empty_subst = mkEmptyTCvSubst (mkInScopeSet fvs) + then let empty_subst = mkEmptySubst (mkInScopeSet fvs) (subst, tv') = substVarBndr empty_subst tv in ForAllTy (Bndr tv' vis) (substTy subst inner_ty `mk_cast_ty` co) else ForAllTy (Bndr tv vis) (inner_ty `mk_cast_ty` co) @@ -2281,7 +2282,7 @@ appTyArgFlags ty = fun_kind_arg_flags (typeKind ty) -- kind aligns with the corresponding position in the argument kind), determine -- each argument's visibility ('Inferred', 'Specified', or 'Required'). fun_kind_arg_flags :: Kind -> [Type] -> [ArgFlag] -fun_kind_arg_flags = go emptyTCvSubst +fun_kind_arg_flags = go emptySubst where go subst ki arg_tys | Just ki' <- coreView ki = go subst ki' arg_tys diff --git a/compiler/GHC/Core/Unify.hs b/compiler/GHC/Core/Unify.hs index 0c3e28f0e1..188d5ff32f 100644 --- a/compiler/GHC/Core/Unify.hs +++ b/compiler/GHC/Core/Unify.hs @@ -38,7 +38,7 @@ import GHC.Core.Coercion hiding ( getCvSubstEnv ) import GHC.Core.TyCon import GHC.Core.TyCo.Rep import GHC.Core.TyCo.FVs ( tyCoVarsOfCoList, tyCoFVsOfTypes ) -import GHC.Core.TyCo.Subst ( mkTvSubst ) +import GHC.Core.TyCo.Subst ( mkTvSubst, emptyIdSubstEnv ) import GHC.Core.RoughMap import GHC.Core.Map.Type import GHC.Utils.FV( FV, fvVarList ) @@ -133,27 +133,27 @@ type BindFun = TyCoVar -> Type -> BindFlag -- always used on top-level types, so we can bind any of the -- free variables of the LHS. -- See also Note [tcMatchTy vs tcMatchTyKi] -tcMatchTy :: Type -> Type -> Maybe TCvSubst +tcMatchTy :: Type -> Type -> Maybe Subst tcMatchTy ty1 ty2 = tcMatchTys [ty1] [ty2] -tcMatchTyX_BM :: BindFun -> TCvSubst - -> Type -> Type -> Maybe TCvSubst +tcMatchTyX_BM :: BindFun -> Subst + -> Type -> Type -> Maybe Subst tcMatchTyX_BM bind_me subst ty1 ty2 = tc_match_tys_x bind_me False subst [ty1] [ty2] -- | Like 'tcMatchTy', but allows the kinds of the types to differ, -- and thus matches them as well. -- See also Note [tcMatchTy vs tcMatchTyKi] -tcMatchTyKi :: Type -> Type -> Maybe TCvSubst +tcMatchTyKi :: Type -> Type -> Maybe Subst tcMatchTyKi ty1 ty2 = tc_match_tys alwaysBindFun True [ty1] [ty2] -- | This is similar to 'tcMatchTy', but extends a substitution -- See also Note [tcMatchTy vs tcMatchTyKi] -tcMatchTyX :: TCvSubst -- ^ Substitution to extend +tcMatchTyX :: Subst -- ^ Substitution to extend -> Type -- ^ Template -> Type -- ^ Target - -> Maybe TCvSubst + -> Maybe Subst tcMatchTyX subst ty1 ty2 = tc_match_tys_x alwaysBindFun False subst [ty1] [ty2] @@ -161,7 +161,7 @@ tcMatchTyX subst ty1 ty2 -- See also Note [tcMatchTy vs tcMatchTyKi] tcMatchTys :: [Type] -- ^ Template -> [Type] -- ^ Target - -> Maybe TCvSubst -- ^ One-shot; in principle the template + -> Maybe Subst -- ^ One-shot; in principle the template -- variables could be free in the target tcMatchTys tys1 tys2 = tc_match_tys alwaysBindFun False tys1 tys2 @@ -170,25 +170,25 @@ tcMatchTys tys1 tys2 -- See also Note [tcMatchTy vs tcMatchTyKi] tcMatchTyKis :: [Type] -- ^ Template -> [Type] -- ^ Target - -> Maybe TCvSubst -- ^ One-shot substitution + -> Maybe Subst -- ^ One-shot substitution tcMatchTyKis tys1 tys2 = tc_match_tys alwaysBindFun True tys1 tys2 -- | Like 'tcMatchTys', but extending a substitution -- See also Note [tcMatchTy vs tcMatchTyKi] -tcMatchTysX :: TCvSubst -- ^ Substitution to extend +tcMatchTysX :: Subst -- ^ Substitution to extend -> [Type] -- ^ Template -> [Type] -- ^ Target - -> Maybe TCvSubst -- ^ One-shot substitution + -> Maybe Subst -- ^ One-shot substitution tcMatchTysX subst tys1 tys2 = tc_match_tys_x alwaysBindFun False subst tys1 tys2 -- | Like 'tcMatchTyKis', but extending a substitution -- See also Note [tcMatchTy vs tcMatchTyKi] -tcMatchTyKisX :: TCvSubst -- ^ Substitution to extend +tcMatchTyKisX :: Subst -- ^ Substitution to extend -> [Type] -- ^ Template -> [Type] -- ^ Target - -> Maybe TCvSubst -- ^ One-shot substitution + -> Maybe Subst -- ^ One-shot substitution tcMatchTyKisX subst tys1 tys2 = tc_match_tys_x alwaysBindFun True subst tys1 tys2 @@ -197,27 +197,27 @@ tc_match_tys :: BindFun -> Bool -- ^ match kinds? -> [Type] -> [Type] - -> Maybe TCvSubst + -> Maybe Subst tc_match_tys bind_me match_kis tys1 tys2 - = tc_match_tys_x bind_me match_kis (mkEmptyTCvSubst in_scope) tys1 tys2 + = tc_match_tys_x bind_me match_kis (mkEmptySubst in_scope) tys1 tys2 where in_scope = mkInScopeSet (tyCoVarsOfTypes tys1 `unionVarSet` tyCoVarsOfTypes tys2) -- | Worker for 'tcMatchTysX' and 'tcMatchTyKisX' tc_match_tys_x :: BindFun -> Bool -- ^ match kinds? - -> TCvSubst + -> Subst -> [Type] -> [Type] - -> Maybe TCvSubst -tc_match_tys_x bind_me match_kis (TCvSubst in_scope tv_env cv_env) tys1 tys2 + -> Maybe Subst +tc_match_tys_x bind_me match_kis (Subst in_scope id_env tv_env cv_env) tys1 tys2 = case tc_unify_tys bind_me False -- Matching, not unifying False -- Not an injectivity check match_kis (mkRnEnv2 in_scope) tv_env cv_env tys1 tys2 of Unifiable (tv_env', cv_env') - -> Just $ TCvSubst in_scope tv_env' cv_env' + -> Just $ Subst in_scope id_env tv_env' cv_env' _ -> Nothing -- | This one is called from the expression matcher, @@ -460,12 +460,12 @@ indexed-types/should_compile/Overlap14. -- | Simple unification of two types; all type variables are bindable -- Precondition: the kinds are already equal tcUnifyTy :: Type -> Type -- All tyvars are bindable - -> Maybe TCvSubst + -> Maybe Subst -- A regular one-shot (idempotent) substitution tcUnifyTy t1 t2 = tcUnifyTys alwaysBindFun [t1] [t2] -- | Like 'tcUnifyTy', but also unifies the kinds -tcUnifyTyKi :: Type -> Type -> Maybe TCvSubst +tcUnifyTyKi :: Type -> Type -> Maybe Subst tcUnifyTyKi t1 t2 = tcUnifyTyKis alwaysBindFun [t1] [t2] -- | Unify two types, treating type family applications as possibly unifying @@ -476,7 +476,7 @@ tcUnifyTyWithTFs :: Bool -- ^ True <=> do two-way unification; -- See end of sec 5.2 from the paper -> InScopeSet -- Should include the free tyvars of both Type args -> Type -> Type -- Types to unify - -> Maybe TCvSubst + -> Maybe Subst -- This algorithm is an implementation of the "Algorithm U" presented in -- the paper "Injective type families for Haskell", Figures 2 and 3. -- The code is incorporated with the standard unifier for convenience, but @@ -493,14 +493,14 @@ tcUnifyTyWithTFs twoWay in_scope t1 t2 where rn_env = mkRnEnv2 in_scope - maybe_fix | twoWay = niFixTCvSubst in_scope + maybe_fix | twoWay = niFixSubst in_scope | otherwise = mkTvSubst in_scope -- when matching, don't confuse -- domain with range ----------------- tcUnifyTys :: BindFun -> [Type] -> [Type] - -> Maybe TCvSubst + -> Maybe Subst -- ^ A regular one-shot (idempotent) substitution -- that unifies the erased types. See comments -- for 'tcUnifyTysFG' @@ -515,7 +515,7 @@ tcUnifyTys bind_fn tys1 tys2 -- | Like 'tcUnifyTys' but also unifies the kinds tcUnifyTyKis :: BindFun -> [Type] -> [Type] - -> Maybe TCvSubst + -> Maybe Subst tcUnifyTyKis bind_fn tys1 tys2 = case tcUnifyTyKisFG bind_fn tys1 tys2 of Unifiable result -> Just result @@ -523,7 +523,7 @@ tcUnifyTyKis bind_fn tys1 tys2 -- This type does double-duty. It is used in the UM (unifier monad) and to -- return the final result. See Note [Fine-grained unification] -type UnifyResult = UnifyResultM TCvSubst +type UnifyResult = UnifyResultM Subst -- | See Note [Unification result] data UnifyResultM a = Unifiable a -- the subst that unifies the types @@ -591,7 +591,7 @@ tc_unify_tys_fg match_kis bind_fn tys1 tys2 = do { (env, _) <- tc_unify_tys bind_fn True False match_kis rn_env emptyTvSubstEnv emptyCvSubstEnv tys1 tys2 - ; return $ niFixTCvSubst in_scope env } + ; return $ niFixSubst in_scope env } where in_scope = mkInScopeSet $ tyCoVarsOfTypes tys1 `unionVarSet` tyCoVarsOfTypes tys2 rn_env = mkRnEnv2 in_scope @@ -727,13 +727,13 @@ variables in the in-scope set; it is used only to ensure no shadowing. -} -niFixTCvSubst :: InScopeSet -> TvSubstEnv -> TCvSubst +niFixSubst :: InScopeSet -> TvSubstEnv -> Subst -- Find the idempotent fixed point of the non-idempotent substitution -- This is surprisingly tricky: -- see Note [Finding the substitution fixpoint] -- ToDo: use laziness instead of iteration? -niFixTCvSubst in_scope tenv - | not_fixpoint = niFixTCvSubst in_scope (mapVarEnv (substTy subst) tenv) +niFixSubst in_scope tenv + | not_fixpoint = niFixSubst in_scope (mapVarEnv (substTy subst) tenv) | otherwise = subst where range_fvs :: FV @@ -754,7 +754,7 @@ niFixTCvSubst in_scope tenv (mkTvSubst in_scope tenv) free_tvs - add_free_tv :: TCvSubst -> TyVar -> TCvSubst + add_free_tv :: Subst -> TyVar -> Subst add_free_tv subst tv = extendTvSubst subst tv (mkTyVarTy tv') where @@ -1435,11 +1435,11 @@ getTvSubstEnv = UM $ \state -> Unifiable (state, um_tv_env state) getCvSubstEnv :: UM CvSubstEnv getCvSubstEnv = UM $ \state -> Unifiable (state, um_cv_env state) -getSubst :: UMEnv -> UM TCvSubst +getSubst :: UMEnv -> UM Subst getSubst env = do { tv_env <- getTvSubstEnv ; cv_env <- getCvSubstEnv ; let in_scope = rnInScopeSet (um_rn_env env) - ; return (mkTCvSubst in_scope (tv_env, cv_env)) } + ; return (mkSubst in_scope tv_env cv_env emptyIdSubstEnv) } extendTvEnv :: TyVar -> Type -> UM () extendTvEnv tv ty = UM $ \state -> @@ -1529,7 +1529,7 @@ liftCoMatch tmpls ty co = do { cenv1 <- ty_co_match menv emptyVarEnv ki ki_co ki_ki_co ki_ki_co ; cenv2 <- ty_co_match menv cenv1 ty co (mkNomReflCo co_lkind) (mkNomReflCo co_rkind) - ; return (LC (mkEmptyTCvSubst in_scope) cenv2) } + ; return (LC (mkEmptySubst in_scope) cenv2) } where menv = ME { me_tmpls = tmpls, me_env = mkRnEnv2 in_scope } in_scope = mkInScopeSet (tmpls `unionVarSet` tyCoVarsOfCo co) @@ -1577,7 +1577,7 @@ ty_co_match menv subst ty co lkco rkco ty_co_match menv subst ty co lkco rkco | CastTy ty' co' <- ty -- See Note [Matching in the presence of casts (1)] - = let empty_subst = mkEmptyTCvSubst (rnInScopeSet (me_env menv)) + = let empty_subst = mkEmptySubst (rnInScopeSet (me_env menv)) substed_co_l = substCo (liftEnvSubstLeft empty_subst subst) co' substed_co_r = substCo (liftEnvSubstRight empty_subst subst) co' in @@ -1867,7 +1867,7 @@ There are wrinkles, of course: variables outside of their scope: note that its domain is the *unrenamed* variables. This means that the substitution gets "pushed down" (like a reader monad) while the in-scope set gets threaded (like a state monad). - Because a TCvSubst contains its own in-scope set, we don't carry a TCvSubst; + Because a Subst contains its own in-scope set, we don't carry a Subst; instead, we just carry a TvSubstEnv down, tying it to the InScopeSet traveling separately as necessary. @@ -2039,7 +2039,7 @@ coreFlattenTyFamApp tv_subst env fam_tc fam_args in (env'', ty') where arity = tyConArity fam_tc - tcv_subst = TCvSubst (fe_in_scope env) tv_subst emptyVarEnv + tcv_subst = Subst (fe_in_scope env) emptyIdSubstEnv tv_subst emptyVarEnv (sat_fam_args, leftover_args) = assert (arity <= length fam_args) $ splitAt arity fam_args -- Apply the substitution before looking up an application in the diff --git a/compiler/GHC/Core/Utils.hs b/compiler/GHC/Core/Utils.hs index 5ae6bf235a..30597dd8e5 100644 --- a/compiler/GHC/Core/Utils.hs +++ b/compiler/GHC/Core/Utils.hs @@ -2101,7 +2101,7 @@ dataConInstPat fss uniqs mult con inst_tys (full_subst, ex_bndrs) = mapAccumL mk_ex_var univ_subst (zip3 ex_tvs ex_fss ex_uniqs) - mk_ex_var :: TCvSubst -> (TyCoVar, FastString, Unique) -> (TCvSubst, TyCoVar) + mk_ex_var :: Subst -> (TyCoVar, FastString, Unique) -> (Subst, TyCoVar) mk_ex_var subst (tv, fs, uniq) = (Type.extendTCvSubstWithClone subst tv new_tv , new_tv) diff --git a/compiler/GHC/CoreToIface.hs b/compiler/GHC/CoreToIface.hs index 8f476fb41d..2564320eaa 100644 --- a/compiler/GHC/CoreToIface.hs +++ b/compiler/GHC/CoreToIface.hs @@ -1,4 +1,3 @@ - {-# LANGUAGE Strict #-} -- See Note [Avoiding space leaks in toIface*] -- | Functions for converting Core things to interface file things. @@ -338,7 +337,7 @@ toIfaceAppArgsX :: VarSet -> Kind -> [Type] -> IfaceAppArgs -- Is 'blib' visible? It depends on the visibility flag on j, -- so we have to substitute for k. Annoying! toIfaceAppArgsX fr kind ty_args - = go (mkEmptyTCvSubst in_scope) kind ty_args + = go (mkEmptySubst in_scope) kind ty_args where in_scope = mkInScopeSet (tyCoVarsOfTypes ty_args) @@ -363,7 +362,7 @@ toIfaceAppArgsX fr kind ty_args go env ty ts@(t1:ts1) | not (isEmptyTCvSubst env) - = go (zapTCvSubst env) (substTy env ty) ts + = go (zapSubst env) (substTy env ty) ts -- See Note [Care with kind instantiation] in GHC.Core.Type | otherwise diff --git a/compiler/GHC/HsToCore/Pmc/Solver.hs b/compiler/GHC/HsToCore/Pmc/Solver.hs index fadd969db8..26dac390b4 100644 --- a/compiler/GHC/HsToCore/Pmc/Solver.hs +++ b/compiler/GHC/HsToCore/Pmc/Solver.hs @@ -1,4 +1,3 @@ - {-# LANGUAGE LambdaCase #-} {-# LANGUAGE ScopedTypeVariables #-} {-# LANGUAGE ViewPatterns #-} @@ -75,7 +74,7 @@ import GHC.Builtin.Names import GHC.Builtin.Types import GHC.Builtin.Types.Prim (tYPETyCon) import GHC.Core.TyCo.Rep -import GHC.Core.TyCo.Subst (elemTCvSubst) +import GHC.Core.TyCo.Subst (elemSubst) import GHC.Core.Type import GHC.Tc.Solver (tcNormalise, tcCheckGivens, tcCheckWanteds) import GHC.Core.Unify (tcMatchTy) @@ -918,7 +917,7 @@ addCoreCt nabla x e = do ex_tys = map exprToType ex_ty_args vis_args = reverse $ take arty $ reverse val_args uniq_supply <- lift $ lift $ getUniqueSupplyM - let (_, ex_tvs) = cloneTyVarBndrs (mkEmptyTCvSubst in_scope) dc_ex_tvs uniq_supply + let (_, ex_tvs) = cloneTyVarBndrs (mkEmptySubst in_scope) dc_ex_tvs uniq_supply ty_cts = equateTys (map mkTyVarTy ex_tvs) ex_tys -- 1. @x ≁ ⊥@ if 'K' is not a Newtype constructor (#18341) when (not (isNewDataCon dc)) $ @@ -1477,7 +1476,7 @@ instCon fuel nabla@MkNabla{nabla_ty_st = ty_st} x con = {-# SCC "instCon" #-} Ma -- Make sure that @ty@ is normalised before. -- -- See Note [Matching against a ConLike result type]. -matchConLikeResTy :: FamInstEnvs -> TyState -> Type -> ConLike -> DsM (Maybe TCvSubst) +matchConLikeResTy :: FamInstEnvs -> TyState -> Type -> ConLike -> DsM (Maybe Subst) matchConLikeResTy env _ ty (RealDataCon dc) = pure $ do (rep_tc, tc_args, _co) <- splitReprTyConApp_maybe env ty if rep_tc == dataConTyCon dc @@ -1486,7 +1485,7 @@ matchConLikeResTy env _ ty (RealDataCon dc) = pure $ do matchConLikeResTy _ (TySt _ inert) ty (PatSynCon ps) = {-# SCC "matchConLikeResTy" #-} runMaybeT $ do let (univ_tvs,req_theta,_,_,_,con_res_ty) = patSynSig ps subst <- MaybeT $ pure $ tcMatchTy con_res_ty ty - guard $ all (`elemTCvSubst` subst) univ_tvs -- See the Note about T11336b + guard $ all (`elemSubst` subst) univ_tvs -- See the Note about T11336b if null req_theta then pure subst else do diff --git a/compiler/GHC/Iface/Ext/Utils.hs b/compiler/GHC/Iface/Ext/Utils.hs index aece9ed044..954ab3af57 100644 --- a/compiler/GHC/Iface/Ext/Utils.hs +++ b/compiler/GHC/Iface/Ext/Utils.hs @@ -61,7 +61,7 @@ renderHieType dflags ht = showSDoc dflags (ppr $ hieTypeToIface ht) resolveVisibility :: Type -> [Type] -> [(Bool,Type)] resolveVisibility kind ty_args - = go (mkEmptyTCvSubst in_scope) kind ty_args + = go (mkEmptySubst in_scope) kind ty_args where in_scope = mkInScopeSet (tyCoVarsOfTypes ty_args) diff --git a/compiler/GHC/Runtime/Context.hs b/compiler/GHC/Runtime/Context.hs index 3ea5f2725c..88abad2b10 100644 --- a/compiler/GHC/Runtime/Context.hs +++ b/compiler/GHC/Runtime/Context.hs @@ -441,7 +441,7 @@ icExtendGblRdrEnv env tythings _ -> False is_sub_bndr _ = False -substInteractiveContext :: InteractiveContext -> TCvSubst -> InteractiveContext +substInteractiveContext :: InteractiveContext -> Subst -> InteractiveContext substInteractiveContext ictxt@InteractiveContext{ ic_tythings = tts } subst | isEmptyTCvSubst subst = ictxt | otherwise = ictxt { ic_tythings = map subst_ty tts } diff --git a/compiler/GHC/Runtime/Debugger.hs b/compiler/GHC/Runtime/Debugger.hs index 04709b38cf..6e26c5c41d 100644 --- a/compiler/GHC/Runtime/Debugger.hs +++ b/compiler/GHC/Runtime/Debugger.hs @@ -67,7 +67,7 @@ pprintClosureCommand bindThings force str = do -- Obtain the terms and the recovered type information let ids = [id | AnId id <- pprintables] - (subst, terms) <- mapAccumLM go emptyTCvSubst ids + (subst, terms) <- mapAccumLM go emptySubst ids -- Apply the substitutions obtained after recovering the types modifySession $ \hsc_env -> @@ -101,7 +101,7 @@ pprintClosureCommand bindThings force str = do liftIO $ printOutputForUser logger unqual $ vcat sdocs -- Do the obtainTerm--bindSuspensions-computeSubstitution dance - go :: GhcMonad m => TCvSubst -> Id -> m (TCvSubst, Term) + go :: GhcMonad m => Subst -> Id -> m (Subst, Term) go subst id = do let id' = updateIdTypeAndMult (substTy subst) id id_ty' = idType id' @@ -124,7 +124,7 @@ pprintClosureCommand bindThings force str = do (fsep $ [text "RTTI Improvement for", ppr id, text "old substitution:" , ppr subst, text "new substitution:" , ppr subst']) - ; return (subst `unionTCvSubst` subst', term')} + ; return (subst `unionSubst` subst', term')} tidyTermTyVars :: GhcMonad m => Term -> m Term tidyTermTyVars t = diff --git a/compiler/GHC/Runtime/Eval.hs b/compiler/GHC/Runtime/Eval.hs index e4f4de3fc5..2a3099e08b 100644 --- a/compiler/GHC/Runtime/Eval.hs +++ b/compiler/GHC/Runtime/Eval.hs @@ -621,10 +621,10 @@ bindLocalsAtBreakpoint hsc_env apStack_fhv (Just BreakInfo{..}) = do = do { name <- newInteractiveBinder hsc_env occ (getSrcSpan old_id) ; return (Id.mkVanillaGlobalWithInfo name ty (idInfo old_id)) } - newTyVars :: UniqSupply -> [TcTyVar] -> TCvSubst + newTyVars :: UniqSupply -> [TcTyVar] -> Subst -- Similarly, clone the type variables mentioned in the types -- we have here, *and* make them all RuntimeUnk tyvars - newTyVars us tvs = foldl' new_tv emptyTCvSubst (tvs `zip` uniqsFromSupply us) + newTyVars us tvs = foldl' new_tv emptySubst (tvs `zip` uniqsFromSupply us) new_tv subst (tv,uniq) = extendTCvSubstWithClone subst tv new_tv where new_tv = mkRuntimeUnkTyVar (setNameUnique (tyVarName tv) uniq) @@ -1146,7 +1146,7 @@ checkForExistence clsInst mb_inst_tys = do Just (_, tys@(_:_)) -> all isTyVarTy tys _ -> isTyVarTy ty - empty_subst = mkEmptyTCvSubst (mkInScopeSet (tyCoVarsOfType (idType $ is_dfun clsInst))) + empty_subst = mkEmptySubst (mkInScopeSet (tyCoVarsOfType (idType $ is_dfun clsInst))) {- Create a ClsInst with instantiated arguments and constraints. diff --git a/compiler/GHC/Runtime/Heap/Inspect.hs b/compiler/GHC/Runtime/Heap/Inspect.hs index df3cd24278..cf3cc6265f 100644 --- a/compiler/GHC/Runtime/Heap/Inspect.hs +++ b/compiler/GHC/Runtime/Heap/Inspect.hs @@ -637,7 +637,7 @@ as expected. -} -instTyVars :: [TyVar] -> TR (TCvSubst, [TcTyVar]) +instTyVars :: [TyVar] -> TR (Subst, [TcTyVar]) -- Instantiate fresh mutable type variables from some TyVars -- This function preserves the print-name, which helps error messages instTyVars tvs @@ -1101,7 +1101,7 @@ findPtrTyss i tys = foldM step (i, []) tys -- improveType <base_type> <rtti_type> -- The types can contain skolem type variables, which need to be treated as normal vars. -- In particular, we want them to unify with things. -improveRTTIType :: HscEnv -> RttiType -> RttiType -> Maybe TCvSubst +improveRTTIType :: HscEnv -> RttiType -> RttiType -> Maybe Subst improveRTTIType _ base_ty new_ty = U.tcUnifyTyKi base_ty new_ty getDataConArgTys :: DataCon -> Type -> TR [Type] diff --git a/compiler/GHC/Tc/Deriv.hs b/compiler/GHC/Tc/Deriv.hs index f191f74d46..7df65bd367 100644 --- a/compiler/GHC/Tc/Deriv.hs +++ b/compiler/GHC/Tc/Deriv.hs @@ -645,9 +645,9 @@ deriveStandalone (L loc (DerivDecl _ deriv_ty mb_lderiv_strat overlap_mode)) DerivErrDerivingViaWrongKind inst_ty_kind via_ty via_kind) let Just kind_subst = mb_match - ki_subst_range = getTCvSubstRangeFVs kind_subst + ki_subst_range = getSubstRangeTyCoFVs kind_subst -- See Note [Unification of two kind variables in deriving] - unmapped_tkvs = filter (\v -> v `notElemTCvSubst` kind_subst + unmapped_tkvs = filter (\v -> v `notElemSubst` kind_subst && not (v `elemVarSet` ki_subst_range)) tvs (subst, _) = substTyVarBndrs kind_subst unmapped_tkvs @@ -769,9 +769,9 @@ deriveTyData tc tc_args mb_deriv_strat deriv_tvs cls cls_tys cls_arg_kind propagate_subst kind_subst tkvs' cls_tys' tc_args' mb_deriv_strat' = (final_tkvs, final_cls_tys, final_tc_args, final_mb_deriv_strat) where - ki_subst_range = getTCvSubstRangeFVs kind_subst + ki_subst_range = getSubstRangeTyCoFVs kind_subst -- See Note [Unification of two kind variables in deriving] - unmapped_tkvs = filter (\v -> v `notElemTCvSubst` kind_subst + unmapped_tkvs = filter (\v -> v `notElemSubst` kind_subst && not (v `elemVarSet` ki_subst_range)) tkvs' (subst, _) = substTyVarBndrs kind_subst unmapped_tkvs @@ -1008,7 +1008,7 @@ the type variable binder for c, since its kind is (k2 -> k2 -> *). We used to accomplish this by doing the following: - unmapped_tkvs = filter (`notElemTCvSubst` kind_subst) all_tkvs + unmapped_tkvs = filter (`notElemSubst` kind_subst) all_tkvs (subst, _) = substTyVarBndrs kind_subst unmapped_tkvs Where all_tkvs contains all kind variables in the class and instance types (in @@ -1024,9 +1024,9 @@ in an ill-kinded instance (this caused #11837). To prevent this, we need to filter out any variable from all_tkvs which either -1. Appears in the domain of kind_subst. notElemTCvSubst checks this. +1. Appears in the domain of kind_subst. notElemSubst checks this. 2. Appears in the range of kind_subst. To do this, we compute the free - variable set of the range of kind_subst with getTCvSubstRangeFVs, and check + variable set of the range of kind_subst with getSubstRangeTyCoFVs, and check if a kind variable appears in that set. Note [Eta-reducing type synonyms] diff --git a/compiler/GHC/Tc/Deriv/Generate.hs b/compiler/GHC/Tc/Deriv/Generate.hs index 810c4c7a32..ab0bbd0c11 100644 --- a/compiler/GHC/Tc/Deriv/Generate.hs +++ b/compiler/GHC/Tc/Deriv/Generate.hs @@ -2759,7 +2759,7 @@ buildDataConInstArgEnv rep_tc rep_tc_args = -- | Apply a substitution to all of the 'Type's contained in a 'DerivInstTys'. -- See @Note [Instantiating field types in stock deriving]@ for why we need to -- substitute into a 'DerivInstTys' in the first place. -substDerivInstTys :: TCvSubst -> DerivInstTys -> DerivInstTys +substDerivInstTys :: Subst -> DerivInstTys -> DerivInstTys substDerivInstTys subst dit@(DerivInstTys { dit_cls_tys = cls_tys, dit_tc_args = tc_args , dit_rep_tc = rep_tc, dit_rep_tc_args = rep_tc_args }) diff --git a/compiler/GHC/Tc/Deriv/Infer.hs b/compiler/GHC/Tc/Deriv/Infer.hs index 94a00ce52b..c17fee9753 100644 --- a/compiler/GHC/Tc/Deriv/Infer.hs +++ b/compiler/GHC/Tc/Deriv/Infer.hs @@ -178,7 +178,7 @@ inferConstraintsStock dit@(DerivInstTys { dit_cls_tys = cls_tys con_arg_constraints :: (CtOrigin -> TypeOrKind -> Type - -> [(ThetaSpec, Maybe TCvSubst)]) + -> [(ThetaSpec, Maybe Subst)]) -> (ThetaSpec, [TyVar], [TcType], DerivInstTys) con_arg_constraints get_arg_constraints = let -- Constraints from the fields of each data constructor. @@ -215,8 +215,8 @@ inferConstraintsStock dit@(DerivInstTys { dit_cls_tys = cls_tys -- kinds with (* -> *). -- See Note [Inferring the instance context] subst = foldl' composeTCvSubst - emptyTCvSubst (catMaybes mbSubsts) - unmapped_tvs = filter (\v -> v `notElemTCvSubst` subst + emptySubst (catMaybes mbSubsts) + unmapped_tvs = filter (\v -> v `notElemSubst` subst && not (v `isInScope` subst)) tvs (subst', _) = substTyVarBndrs subst unmapped_tvs stupid_theta_origin = mkDirectThetaSpec @@ -236,13 +236,13 @@ inferConstraintsStock dit@(DerivInstTys { dit_cls_tys = cls_tys || is_generic1 get_gen1_constraints :: Class -> CtOrigin -> TypeOrKind -> Type - -> [(ThetaSpec, Maybe TCvSubst)] + -> [(ThetaSpec, Maybe Subst)] get_gen1_constraints functor_cls orig t_or_k ty = mk_functor_like_constraints orig t_or_k functor_cls $ get_gen1_constrained_tys last_tv ty get_std_constrained_tys :: CtOrigin -> TypeOrKind -> Type - -> [(ThetaSpec, Maybe TCvSubst)] + -> [(ThetaSpec, Maybe Subst)] get_std_constrained_tys orig t_or_k ty | is_functor_like = mk_functor_like_constraints orig t_or_k main_cls $ @@ -253,7 +253,7 @@ inferConstraintsStock dit@(DerivInstTys { dit_cls_tys = cls_tys mk_functor_like_constraints :: CtOrigin -> TypeOrKind -> Class -> [Type] - -> [(ThetaSpec, Maybe TCvSubst)] + -> [(ThetaSpec, Maybe Subst)] -- 'cls' is usually main_cls (Functor or Traversable etc), but if -- main_cls = Generic1, then 'cls' can be Functor; see -- get_gen1_constraints diff --git a/compiler/GHC/Tc/Deriv/Utils.hs b/compiler/GHC/Tc/Deriv/Utils.hs index f28ad0e8f4..b6ad253ec1 100644 --- a/compiler/GHC/Tc/Deriv/Utils.hs +++ b/compiler/GHC/Tc/Deriv/Utils.hs @@ -637,7 +637,7 @@ mkDirectThetaSpec origin t_or_k = , sps_type_or_kind = t_or_k }) -substPredSpec :: HasCallStack => TCvSubst -> PredSpec -> PredSpec +substPredSpec :: HasCallStack => Subst -> PredSpec -> PredSpec substPredSpec subst ps = case ps of SimplePredSpec { sps_pred = pred diff --git a/compiler/GHC/Tc/Gen/HsType.hs b/compiler/GHC/Tc/Gen/HsType.hs index d045984024..3fed598f4d 100644 --- a/compiler/GHC/Tc/Gen/HsType.hs +++ b/compiler/GHC/Tc/Gen/HsType.hs @@ -1,4 +1,3 @@ - {-# LANGUAGE DataKinds #-} {-# LANGUAGE FlexibleContexts #-} {-# LANGUAGE RankNTypes #-} @@ -1572,12 +1571,12 @@ tcInferTyApps_nosat mode orig_hs_ty fun orig_hs_args -- Note that in a typical application (F t1 t2 t3), -- the 'fun' is just a TyCon, so tcTypeKind is fast - empty_subst = mkEmptyTCvSubst $ mkInScopeSet $ + empty_subst = mkEmptySubst $ mkInScopeSet $ tyCoVarsOfType fun_ki go :: Int -- The # of the next argument -> TcType -- Function applied to some args - -> TCvSubst -- Applies to function kind + -> Subst -- Applies to function kind -> TcKind -- Function kind -> [LHsTypeArg GhcRn] -- Un-type-checked args -> TcM (TcType, TcKind) -- Result type and its kind @@ -1687,7 +1686,7 @@ tcInferTyApps_nosat mode orig_hs_ty fun orig_hs_args | otherwise = fallthrough - zapped_subst = zapTCvSubst subst + zapped_subst = zapSubst subst substed_fun_ki = substTy subst fun_ki hs_ty = appTypeToArg orig_hs_ty (take (n-1) orig_hs_args) @@ -1700,10 +1699,10 @@ tcInferTyApps_nosat mode orig_hs_ty fun orig_hs_args ty_app_err arg ty = failWith $ TcRnInvalidVisibleKindArgument arg ty -mkAppTyM :: TCvSubst +mkAppTyM :: Subst -> TcType -> TyCoBinder -- fun, plus its top-level binder -> TcType -- arg - -> TcM (TCvSubst, TcType) -- Extended subst, plus (fun arg) + -> TcM (Subst, TcType) -- Extended subst, plus (fun arg) -- Precondition: the application (fun arg) is well-kinded after zonking -- That is, the application makes sense -- @@ -2581,7 +2580,7 @@ kcCheckDeclHeader_sig sig_kind name flav -- Why? So that the TyConBinders of the TyCon will lexically scope over the -- associated types and methods of a class. ; let swizzle_env = mkVarEnv (map swap implicit_prs) - (subst, swizzled_tcbs) = mapAccumL (swizzleTcb swizzle_env) emptyTCvSubst all_tcbs + (subst, swizzled_tcbs) = mapAccumL (swizzleTcb swizzle_env) emptySubst all_tcbs swizzled_kind = substTy subst tycon_res_kind all_tv_prs = mkTyVarNamePairs (binderVars swizzled_tcbs) @@ -2621,7 +2620,7 @@ matchUpSigWithDecl -- Invariant: Length of returned TyConBinders + length of excess TyConBinders -- = length of incoming TyConBinders matchUpSigWithDecl sig_tcbs sig_res_kind hs_bndrs thing_inside - = go emptyTCvSubst sig_tcbs hs_bndrs + = go emptySubst sig_tcbs hs_bndrs where go subst tcbs [] = do { let (subst', tcbs') = substTyConBindersX subst tcbs @@ -2663,16 +2662,16 @@ matchUpSigWithDecl sig_tcbs sig_res_kind hs_bndrs thing_inside ; discardResult $ -- See Note [discardResult in kcCheckDeclHeader_sig] unifyKind (Just (NameThing hs_nm)) sig_kind expected_kind } -substTyConBinderX :: TCvSubst -> TyConBinder -> (TCvSubst, TyConBinder) +substTyConBinderX :: Subst -> TyConBinder -> (Subst, TyConBinder) substTyConBinderX subst (Bndr tv vis) = (subst', Bndr tv' vis) where (subst', tv') = substTyVarBndr subst tv -substTyConBindersX :: TCvSubst -> [TyConBinder] -> (TCvSubst, [TyConBinder]) +substTyConBindersX :: Subst -> [TyConBinder] -> (Subst, [TyConBinder]) substTyConBindersX = mapAccumL substTyConBinderX -swizzleTcb :: VarEnv Name -> TCvSubst -> TyConBinder -> (TCvSubst, TyConBinder) +swizzleTcb :: VarEnv Name -> Subst -> TyConBinder -> (Subst, TyConBinder) swizzleTcb swizzle_env subst (Bndr tv vis) = (subst', Bndr tv2 vis) where @@ -3698,7 +3697,7 @@ splitTyConKind skol_info in_scope avoid_occs kind -- Note [Avoid name clashes for associated data types] , not (occ `elem` avoid_occs) ] new_uniqs = uniqsFromSupply uniqs - subst = mkEmptyTCvSubst in_scope + subst = mkEmptySubst in_scope details = SkolemTv skol_info (pushTcLevel lvl) False -- As always, allocate skolems one level in @@ -3713,7 +3712,7 @@ splitTyConKind skol_info in_scope avoid_occs kind arg' = substTy subst (scaledThing arg) name = mkInternalName uniq occ loc tv = mkTcTyVar name arg' details - subst' = extendTCvInScope subst tv + subst' = extendSubstInScope subst tv (uniq:uniqs') = uniqs (occ:occs') = occs @@ -3843,7 +3842,7 @@ tcbVisibilities :: TyCon -> [Type] -> [TyConBndrVis] tcbVisibilities tc orig_args = go (tyConKind tc) init_subst orig_args where - init_subst = mkEmptyTCvSubst (mkInScopeSet (tyCoVarsOfTypes orig_args)) + init_subst = mkEmptySubst (mkInScopeSet (tyCoVarsOfTypes orig_args)) go _ _ [] = [] diff --git a/compiler/GHC/Tc/Gen/Pat.hs b/compiler/GHC/Tc/Gen/Pat.hs index 83bb70e35f..b5c6b4c5c5 100644 --- a/compiler/GHC/Tc/Gen/Pat.hs +++ b/compiler/GHC/Tc/Gen/Pat.hs @@ -1,4 +1,3 @@ - {-# LANGUAGE FlexibleContexts #-} {-# LANGUAGE LambdaCase #-} {-# LANGUAGE RankNTypes #-} @@ -1239,7 +1238,7 @@ Wrinkles: tcConArgs :: ConLike -> [Scaled TcSigmaTypeFRR] - -> TCvSubst -- Instantiating substitution for constructor type + -> Subst -- Instantiating substitution for constructor type -> Checker (HsConPatDetails GhcRn) (HsConPatDetails GhcTc) tcConArgs con_like arg_tys tenv penv con_args thing_inside = case con_args of PrefixCon type_args arg_pats -> do diff --git a/compiler/GHC/Tc/Instance/FunDeps.hs b/compiler/GHC/Tc/Instance/FunDeps.hs index 067c87a50f..b11ed10efc 100644 --- a/compiler/GHC/Tc/Instance/FunDeps.hs +++ b/compiler/GHC/Tc/Instance/FunDeps.hs @@ -324,7 +324,7 @@ improveClsFD clas_tvs fd meta_tvs = [ setVarType tv (substTy subst (varType tv)) | tv <- qtvs - , tv `notElemTCvSubst` subst + , tv `notElemSubst` subst , tv `elemVarSet` rtys1_tvs ] -- meta_tvs are the quantified type variables -- that have not been substituted out @@ -343,7 +343,7 @@ improveClsFD clas_tvs fd -- whose kind mentions that kind variable! #6015, #6068 -- (c) no need to include tyvars not in rtys1 where - init_subst = mkEmptyTCvSubst $ mkInScopeSet $ + init_subst = mkEmptySubst $ mkInScopeSet $ mkVarSet qtvs `unionVarSet` tyCoVarsOfTypes ltys2 (ltys1, rtys1) = instFD fd clas_tvs tys_inst (ltys2, rtys2) = instFD fd clas_tvs tys_actual diff --git a/compiler/GHC/Tc/Solver/Canonical.hs b/compiler/GHC/Tc/Solver/Canonical.hs index 81aa291785..ec8e11b168 100644 --- a/compiler/GHC/Tc/Solver/Canonical.hs +++ b/compiler/GHC/Tc/Solver/Canonical.hs @@ -867,7 +867,7 @@ solveForAll ev@(CtWanted { ctev_dest = dest, ctev_rewriters = rewriters, ctev_lo -- TcLclEnv for the implication, and that in turn sets the location -- for the Givens when solving the constraint (#21006) do { skol_info <- mkSkolemInfo QuantCtxtSkol - ; let empty_subst = mkEmptyTCvSubst $ mkInScopeSet $ + ; let empty_subst = mkEmptySubst $ mkInScopeSet $ tyCoVarsOfTypes (pred:theta) `delVarSetList` tvs ; (subst, skol_tvs) <- tcInstSkolTyVarsX skol_info empty_subst tvs ; given_ev_vars <- mapM newEvVar (substTheta subst theta) @@ -1210,7 +1210,7 @@ can_eq_nc_forall ev eq_rel s1 s2 ; canEqHardFailure ev s1 s2 } else do { traceTcS "Creating implication for polytype equality" $ ppr ev - ; let empty_subst1 = mkEmptyTCvSubst $ mkInScopeSet free_tvs + ; let empty_subst1 = mkEmptySubst $ mkInScopeSet free_tvs ; skol_info <- mkSkolemInfo (UnifyForAllSkol phi1) ; (subst1, skol_tvs) <- tcInstSkolTyVarsX skol_info empty_subst1 $ binderVars bndrs1 @@ -1218,7 +1218,7 @@ can_eq_nc_forall ev eq_rel s1 s2 ; let phi1' = substTy subst1 phi1 -- Unify the kinds, extend the substitution - go :: [TcTyVar] -> TCvSubst -> [TyVarBinder] + go :: [TcTyVar] -> Subst -> [TyVarBinder] -> TcS (TcCoercion, Cts) go (skol_tv:skol_tvs) subst (bndr2:bndrs2) = do { let tv2 = binderVar bndr2 @@ -1239,7 +1239,7 @@ can_eq_nc_forall ev eq_rel s1 s2 go _ _ _ = panic "cna_eq_nc_forall" -- case (s:ss) [] - empty_subst2 = mkEmptyTCvSubst (getTCvInScope subst1) + empty_subst2 = mkEmptySubst (getSubstInScope subst1) ; (lvl, (all_co, wanteds)) <- pushLevelNoWorkList (ppr skol_info) $ go skol_tvs empty_subst2 bndrs2 diff --git a/compiler/GHC/Tc/Solver/Interact.hs b/compiler/GHC/Tc/Solver/Interact.hs index e60e6993cc..ac29f55505 100644 --- a/compiler/GHC/Tc/Solver/Interact.hs +++ b/compiler/GHC/Tc/Solver/Interact.hs @@ -1,4 +1,3 @@ - {-# OPTIONS_GHC -Wno-incomplete-record-updates #-} {-# OPTIONS_GHC -Wno-incomplete-uni-patterns #-} @@ -1859,19 +1858,19 @@ emitFunDepWanteds work_rewriters fd_eqns | otherwise = do { traceTcS "emitFunDepWanteds 2" (ppr (ctl_depth loc) $$ ppr tvs $$ ppr eqs) - ; subst <- instFlexiX emptyTCvSubst tvs -- Takes account of kind substitution + ; subst <- instFlexiX emptySubst tvs -- Takes account of kind substitution ; mapM_ (do_one_eq loc all_rewriters subst) (reverse eqs) } -- See Note [Reverse order of fundep equations] where all_rewriters = work_rewriters S.<> rewriters do_one_eq loc rewriters subst (Pair ty1 ty2) - = unifyWanted rewriters loc Nominal (Type.substTy subst' ty1) ty2 + = unifyWanted rewriters loc Nominal (substTyUnchecked subst' ty1) ty2 -- ty2 does not mention fd_qtvs, so no need to subst it. -- See GHC.Tc.Instance.Fundeps Note [Improving against instances] -- Wrinkle (1) where - subst' = extendTCvInScopeSet subst (tyCoVarsOfType ty1) + subst' = extendSubstInScopeSet subst (tyCoVarsOfType ty1) -- The free vars of ty1 aren't just fd_qtvs: ty1 is the result -- of matching with the [W] constraint. So we add its free -- vars to InScopeSet, to satisfy substTy's invariants, even @@ -2082,7 +2081,7 @@ improve_top_fun_eqs fam_envs fam_tc args rhs_ty -> (a -> [Type]) -- get LHS of an axiom -> (a -> Type) -- get RHS of an axiom -> (a -> Maybe CoAxBranch) -- Just => apartness check required - -> [( [Type], TCvSubst, [TyVar], Maybe CoAxBranch )] + -> [( [Type], Subst, [TyVar], Maybe CoAxBranch )] -- Result: -- ( [arguments of a matching axiom] -- , RHS-unifying substitution @@ -2102,7 +2101,7 @@ improve_top_fun_eqs fam_envs fam_tc args rhs_ty -- in telescope order e.g. (k:*) (a:k) injImproveEqns :: [Bool] - -> ([Type], TCvSubst, [TyCoVar], Maybe CoAxBranch) + -> ([Type], Subst, [TyCoVar], Maybe CoAxBranch) -> TcS [TypeEqn] injImproveEqns inj_args (ax_args, subst, unsubstTvs, cabr) = do { subst <- instFlexiX subst unsubstTvs @@ -2577,4 +2576,3 @@ information as described in Note [Replacement vs keeping], 2a. Test case: typecheck/should_compile/T20582. -} - diff --git a/compiler/GHC/Tc/Solver/Monad.hs b/compiler/GHC/Tc/Solver/Monad.hs index 6621f54317..f41e1991ce 100644 --- a/compiler/GHC/Tc/Solver/Monad.hs +++ b/compiler/GHC/Tc/Solver/Monad.hs @@ -1614,11 +1614,11 @@ newFlexiTcSTy knd = wrapTcS (TcM.newFlexiTyVarTy knd) cloneMetaTyVar :: TcTyVar -> TcS TcTyVar cloneMetaTyVar tv = wrapTcS (TcM.cloneMetaTyVar tv) -instFlexiX :: TCvSubst -> [TKVar] -> TcS TCvSubst +instFlexiX :: Subst -> [TKVar] -> TcS Subst instFlexiX subst tvs = wrapTcS (foldlM instFlexiHelper subst tvs) -instFlexiHelper :: TCvSubst -> TKVar -> TcM TCvSubst +instFlexiHelper :: Subst -> TKVar -> TcM Subst -- Makes fresh tyvar, extends the substitution, and the in-scope set instFlexiHelper subst tv = do { uniq <- TcM.newUnique @@ -1637,7 +1637,7 @@ matchGlobalInst :: DynFlags matchGlobalInst dflags short_cut cls tys = wrapTcS (TcM.matchGlobalInst dflags short_cut cls tys) -tcInstSkolTyVarsX :: SkolemInfo -> TCvSubst -> [TyVar] -> TcS (TCvSubst, [TcTyVar]) +tcInstSkolTyVarsX :: SkolemInfo -> Subst -> [TyVar] -> TcS (Subst, [TcTyVar]) tcInstSkolTyVarsX skol_info subst tvs = wrapTcS $ TcM.tcInstSkolTyVarsX skol_info subst tvs -- Creating and setting evidence variables and CtFlavors diff --git a/compiler/GHC/Tc/TyCl.hs b/compiler/GHC/Tc/TyCl.hs index 87580c1865..03e7d45148 100644 --- a/compiler/GHC/Tc/TyCl.hs +++ b/compiler/GHC/Tc/TyCl.hs @@ -2585,7 +2585,7 @@ tcDefaultAssocDecl fam_tc ]) ; let subst = case traverse getTyVar_maybe pats of Just cpt_tvs -> zipTvSubst cpt_tvs (mkTyVarTys fam_tvs) - Nothing -> emptyTCvSubst + Nothing -> emptySubst -- The Nothing case can only be reached in invalid -- associated type family defaults. In such cases, we -- simply create an empty substitution and let GHC fall @@ -3798,7 +3798,7 @@ rejigConRes :: [KnotTied TyConBinder] -- Template for result type; e.g. [InvisTVBinder], -- The constructor's rejigged, user-written -- type variables [EqSpec], -- Equality predicates - TCvSubst) -- Substitution to apply to argument types + Subst) -- Substitution to apply to argument types -- We don't check that the TyCon given in the ResTy is -- the same as the parent tycon, because checkValidDataCon will do it -- NB: All arguments may potentially be knot-tied @@ -3847,7 +3847,7 @@ rejigConRes tc_tvbndrs res_tmpl dc_tvbndrs res_ty -- albeit bogus, relying on checkValidDataCon to check the -- bad-result-type error before seeing that the other fields look odd -- See Note [rejigConRes] - = (tc_tvs, dc_tvs `minusList` tc_tvs, dc_tvbndrs, [], emptyTCvSubst) + = (tc_tvs, dc_tvs `minusList` tc_tvs, dc_tvbndrs, [], emptySubst) where dc_tvs = binderVars dc_tvbndrs tc_tvs = binderVars tc_tvbndrs @@ -3995,28 +3995,28 @@ certainly degrade error messages a bit, though. -- See Note [mkGADTVars]. mkGADTVars :: [TyVar] -- ^ The tycon vars -> [TyVar] -- ^ The datacon vars - -> TCvSubst -- ^ The matching between the template result type + -> Subst -- ^ The matching between the template result type -- and the actual result type -> ( [TyVar] , [EqSpec] - , TCvSubst ) -- ^ The univ. variables, the GADT equalities, + , Subst ) -- ^ The univ. variables, the GADT equalities, -- and a subst to apply to the GADT equalities -- and existentials. mkGADTVars tmpl_tvs dc_tvs subst = choose [] [] empty_subst empty_subst tmpl_tvs where in_scope = mkInScopeSet (mkVarSet tmpl_tvs `unionVarSet` mkVarSet dc_tvs) - `unionInScope` getTCvInScope subst - empty_subst = mkEmptyTCvSubst in_scope + `unionInScope` getSubstInScope subst + empty_subst = mkEmptySubst in_scope choose :: [TyVar] -- accumulator of univ tvs, reversed -> [EqSpec] -- accumulator of GADT equalities, reversed - -> TCvSubst -- template substitution - -> TCvSubst -- res. substitution + -> Subst -- template substitution + -> Subst -- res. substitution -> [TyVar] -- template tvs (the univ tvs passed in) -> ( [TyVar] -- the univ_tvs , [EqSpec] -- GADT equalities - , TCvSubst ) -- a substitution to fix kinds in ex_tvs + , Subst ) -- a substitution to fix kinds in ex_tvs choose univs eqs _t_sub r_sub [] = (reverse univs, reverse eqs, r_sub) diff --git a/compiler/GHC/Tc/TyCl/Class.hs b/compiler/GHC/Tc/TyCl/Class.hs index dee46e9189..a57f6df973 100644 --- a/compiler/GHC/Tc/TyCl/Class.hs +++ b/compiler/GHC/Tc/TyCl/Class.hs @@ -505,7 +505,7 @@ inst_decl_ctxt doc = hang (text "In the instance declaration for") 2 (quotes doc) tcATDefault :: SrcSpan - -> TCvSubst + -> Subst -> NameSet -> ClassATItem -> TcM [FamInst] diff --git a/compiler/GHC/Tc/TyCl/PatSyn.hs b/compiler/GHC/Tc/TyCl/PatSyn.hs index dad820674e..814e5640a2 100644 --- a/compiler/GHC/Tc/TyCl/PatSyn.hs +++ b/compiler/GHC/Tc/TyCl/PatSyn.hs @@ -436,7 +436,7 @@ tcCheckPatSynDecl psb@PSB{ psb_id = lname@(L _ name), psb_args = details -- expected type. Even though the tyvars in the type are -- already skolems, this step changes their TcLevels, -- avoiding level-check errors when unifying. - ; (skol_subst0, skol_univ_bndrs) <- skolemiseTvBndrsX skol_info emptyTCvSubst univ_bndrs + ; (skol_subst0, skol_univ_bndrs) <- skolemiseTvBndrsX skol_info emptySubst univ_bndrs ; (skol_subst, skol_ex_bndrs) <- skolemiseTvBndrsX skol_info skol_subst0 ex_bndrs ; let skol_univ_tvs = binderVars skol_univ_bndrs skol_ex_tvs = binderVars skol_ex_bndrs @@ -457,7 +457,7 @@ tcCheckPatSynDecl psb@PSB{ psb_id = lname@(L _ name), psb_args = details tcExtendNameTyVarEnv univ_tv_prs $ tcCheckPat PatSyn lpat (unrestricted skol_pat_ty) $ do { let in_scope = mkInScopeSetList skol_univ_tvs - empty_subst = mkEmptyTCvSubst in_scope + empty_subst = mkEmptySubst in_scope ; (inst_subst, ex_tvs') <- mapAccumLM newMetaTyVarX empty_subst skol_ex_tvs -- newMetaTyVarX: see the "Existential type variables" -- part of Note [Checking against a pattern signature] @@ -494,7 +494,7 @@ tcCheckPatSynDecl psb@PSB{ psb_id = lname@(L _ name), psb_args = details (args', skol_arg_tys) skol_pat_ty rec_fields } where - tc_arg :: TCvSubst -> Name -> Type -> TcM (LHsExpr GhcTc) + tc_arg :: Subst -> Name -> Type -> TcM (LHsExpr GhcTc) -- Look up the variable actually bound by lpat -- and check that it has the expected type tc_arg subst arg_name arg_ty @@ -515,8 +515,8 @@ tcCheckPatSynDecl psb@PSB{ psb_id = lname@(L _ name), psb_args = details -- See Note [Pattern synonyms and higher rank types] ; return (mkLHsWrap wrap $ nlHsVar arg_id) } -skolemiseTvBndrsX :: SkolemInfo -> TCvSubst -> [VarBndr TyVar flag] - -> TcM (TCvSubst, [VarBndr TcTyVar flag]) +skolemiseTvBndrsX :: SkolemInfo -> Subst -> [VarBndr TyVar flag] + -> TcM (Subst, [VarBndr TcTyVar flag]) -- Make new TcTyVars, all skolems with levels, but do not clone -- The level is one level deeper than the current level -- See Note [Skolemising when checking a pattern synonym] @@ -525,8 +525,8 @@ skolemiseTvBndrsX skol_info orig_subst tvs ; let pushed_lvl = pushTcLevel tc_lvl details = SkolemTv skol_info pushed_lvl False - mk_skol_tv_x :: TCvSubst -> VarBndr TyVar flag - -> (TCvSubst, VarBndr TcTyVar flag) + mk_skol_tv_x :: Subst -> VarBndr TyVar flag + -> (Subst, VarBndr TcTyVar flag) mk_skol_tv_x subst (Bndr tv flag) = (subst', Bndr new_tv flag) where diff --git a/compiler/GHC/Tc/Utils/Instantiate.hs b/compiler/GHC/Tc/Utils/Instantiate.hs index cbe8f03be9..4497fe4d4b 100644 --- a/compiler/GHC/Tc/Utils/Instantiate.hs +++ b/compiler/GHC/Tc/Utils/Instantiate.hs @@ -1,4 +1,3 @@ - {-# LANGUAGE FlexibleContexts #-} {-# LANGUAGE DisambiguateRecordFields #-} @@ -179,7 +178,7 @@ topSkolemise :: SkolemInfo topSkolemise skolem_info ty = go init_subst idHsWrapper [] [] ty where - init_subst = mkEmptyTCvSubst (mkInScopeSet (tyCoVarsOfType ty)) + init_subst = mkEmptySubst (mkInScopeSet (tyCoVarsOfType ty)) -- Why recursive? See Note [Skolemisation] go subst wrap tv_prs ev_vars ty @@ -241,16 +240,16 @@ instantiateSigma orig tvs theta body_ty where free_tvs = tyCoVarsOfType body_ty `unionVarSet` tyCoVarsOfTypes theta in_scope = mkInScopeSet (free_tvs `delVarSetList` tvs) - empty_subst = mkEmptyTCvSubst in_scope + empty_subst = mkEmptySubst in_scope -instTyVarsWith :: CtOrigin -> [TyVar] -> [TcType] -> TcM TCvSubst +instTyVarsWith :: CtOrigin -> [TyVar] -> [TcType] -> TcM Subst -- Use this when you want to instantiate (forall a b c. ty) with -- types [ta, tb, tc], but when the kinds of 'a' and 'ta' might -- not yet match (perhaps because there are unsolved constraints; #14154) -- If they don't match, emit a kind-equality to promise that they will -- eventually do so, and thus make a kind-homongeneous substitution. instTyVarsWith orig tvs tys - = go emptyTCvSubst tvs tys + = go emptySubst tvs tys where go subst [] [] = return subst @@ -335,11 +334,11 @@ instDFunType dfun_id dfun_inst_tys where dfun_ty = idType dfun_id (dfun_tvs, dfun_theta, _) = tcSplitSigmaTy dfun_ty - empty_subst = mkEmptyTCvSubst (mkInScopeSet (tyCoVarsOfType dfun_ty)) + empty_subst = mkEmptySubst (mkInScopeSet (tyCoVarsOfType dfun_ty)) -- With quantified constraints, the -- type of a dfun may not be closed - go :: TCvSubst -> [TyVar] -> [DFunInstType] -> TcM (TCvSubst, [TcType]) + go :: Subst -> [TyVar] -> [DFunInstType] -> TcM (Subst, [TcType]) go subst [] [] = return (subst, []) go subst (tv:tvs) (Just ty : mb_tys) = do { (subst', tys) <- go (extendTvSubstAndInScope subst tv ty) @@ -382,7 +381,7 @@ tcInstInvisibleTyBindersN 0 kind tcInstInvisibleTyBindersN n ty = go n empty_subst ty where - empty_subst = mkEmptyTCvSubst (mkInScopeSet (tyCoVarsOfType ty)) + empty_subst = mkEmptySubst (mkInScopeSet (tyCoVarsOfType ty)) go n subst kind | n > 0 @@ -395,7 +394,7 @@ tcInstInvisibleTyBindersN n ty = return ([], substTy subst kind) -- | Used only in *types* -tcInstInvisibleTyBinder :: TCvSubst -> TyBinder -> TcM (TCvSubst, TcType) +tcInstInvisibleTyBinder :: Subst -> TyBinder -> TcM (Subst, TcType) tcInstInvisibleTyBinder subst (Named (Bndr tv _)) = do { (subst', tv') <- newMetaTyVarX subst tv ; return (subst', mkTyVarTy tv') } @@ -458,7 +457,7 @@ mkEqBoxTy co ty1 ty2 * * ********************************************************************* -} -tcInstType :: ([TyVar] -> TcM (TCvSubst, [TcTyVar])) +tcInstType :: ([TyVar] -> TcM (Subst, [TcTyVar])) -- ^ How to instantiate the type variables -> Id -- ^ Type to instantiate -> TcM ([(Name, TcTyVar)], TcThetaType, TcType) -- ^ Result @@ -470,7 +469,7 @@ tcInstType inst_tyvars id | otherwise = do { (subst, tyvars') <- inst_tyvars tyvars ; let tv_prs = map tyVarName tyvars `zip` tyvars' - subst' = extendTCvInScopeSet subst (tyCoVarsOfType rho) + subst' = extendSubstInScopeSet subst (tyCoVarsOfType rho) ; return (tv_prs, substTheta subst' theta, substTy subst' tau) } where (tyvars, rho) = tcSplitForAllInvisTyVars (idType id) @@ -484,16 +483,16 @@ tcInstTypeBndrs poly_ty -- (?x :: Int) => Int -> Int = return ([], theta, tau) | otherwise - = do { (subst, tyvars') <- mapAccumLM inst_invis_bndr emptyTCvSubst tyvars + = do { (subst, tyvars') <- mapAccumLM inst_invis_bndr emptySubst tyvars ; let tv_prs = map (tyVarName . binderVar) tyvars `zip` tyvars' - subst' = extendTCvInScopeSet subst (tyCoVarsOfType rho) + subst' = extendSubstInScopeSet subst (tyCoVarsOfType rho) ; return (tv_prs, substTheta subst' theta, substTy subst' tau) } where (tyvars, rho) = splitForAllInvisTVBinders poly_ty (theta, tau) = tcSplitPhiTy rho - inst_invis_bndr :: TCvSubst -> InvisTVBinder - -> TcM (TCvSubst, InvisTVBinder) + inst_invis_bndr :: Subst -> InvisTVBinder + -> TcM (Subst, InvisTVBinder) inst_invis_bndr subst (Bndr tv spec) = do { (subst', tv') <- newMetaTyVarTyVarX subst tv ; return (subst', Bndr tv' spec) } @@ -506,14 +505,14 @@ tcSkolDFunType skol_info dfun = do { (tv_prs, theta, tau) <- tcInstType (tcInstSuperSkolTyVars skol_info) dfun ; return (map snd tv_prs, theta, tau) } -tcSuperSkolTyVars :: TcLevel -> SkolemInfo -> [TyVar] -> (TCvSubst, [TcTyVar]) +tcSuperSkolTyVars :: TcLevel -> SkolemInfo -> [TyVar] -> (Subst, [TcTyVar]) -- Make skolem constants, but do *not* give them new names, as above -- As always, allocate them one level in -- Moreover, make them "super skolems"; see GHC.Core.InstEnv -- Note [Binding when looking up instances] -- See Note [Kind substitution when instantiating] -- Precondition: tyvars should be ordered by scoping -tcSuperSkolTyVars tc_lvl skol_info = mapAccumL do_one emptyTCvSubst +tcSuperSkolTyVars tc_lvl skol_info = mapAccumL do_one emptySubst where details = SkolemTv skol_info (pushTcLevel tc_lvl) True -- The "super" bit @@ -525,29 +524,29 @@ tcSuperSkolTyVars tc_lvl skol_info = mapAccumL do_one emptyTCvSubst -- | Given a list of @['TyVar']@, skolemize the type variables, -- returning a substitution mapping the original tyvars to the -- skolems, and the list of newly bound skolems. -tcInstSkolTyVars :: SkolemInfo -> [TyVar] -> TcM (TCvSubst, [TcTyVar]) +tcInstSkolTyVars :: SkolemInfo -> [TyVar] -> TcM (Subst, [TcTyVar]) -- See Note [Skolemising type variables] -tcInstSkolTyVars skol_info = tcInstSkolTyVarsX skol_info emptyTCvSubst +tcInstSkolTyVars skol_info = tcInstSkolTyVarsX skol_info emptySubst -tcInstSkolTyVarsX :: SkolemInfo -> TCvSubst -> [TyVar] -> TcM (TCvSubst, [TcTyVar]) +tcInstSkolTyVarsX :: SkolemInfo -> Subst -> [TyVar] -> TcM (Subst, [TcTyVar]) -- See Note [Skolemising type variables] tcInstSkolTyVarsX skol_info = tcInstSkolTyVarsPushLevel skol_info False -tcInstSuperSkolTyVars :: SkolemInfo -> [TyVar] -> TcM (TCvSubst, [TcTyVar]) +tcInstSuperSkolTyVars :: SkolemInfo -> [TyVar] -> TcM (Subst, [TcTyVar]) -- See Note [Skolemising type variables] -- This version freshens the names and creates "super skolems"; -- see comments around superSkolemTv. -tcInstSuperSkolTyVars skol_info = tcInstSuperSkolTyVarsX skol_info emptyTCvSubst +tcInstSuperSkolTyVars skol_info = tcInstSuperSkolTyVarsX skol_info emptySubst -tcInstSuperSkolTyVarsX :: SkolemInfo -> TCvSubst -> [TyVar] -> TcM (TCvSubst, [TcTyVar]) +tcInstSuperSkolTyVarsX :: SkolemInfo -> Subst -> [TyVar] -> TcM (Subst, [TcTyVar]) -- See Note [Skolemising type variables] -- This version freshens the names and creates "super skolems"; -- see comments around superSkolemTv. tcInstSuperSkolTyVarsX skol_info subst = tcInstSkolTyVarsPushLevel skol_info True subst tcInstSkolTyVarsPushLevel :: SkolemInfo -> Bool -- True <=> make "super skolem" - -> TCvSubst -> [TyVar] - -> TcM (TCvSubst, [TcTyVar]) + -> Subst -> [TyVar] + -> TcM (Subst, [TcTyVar]) -- Skolemise one level deeper, hence pushTcLevel -- See Note [Skolemising type variables] tcInstSkolTyVarsPushLevel skol_info overlappable subst tvs @@ -557,8 +556,8 @@ tcInstSkolTyVarsPushLevel skol_info overlappable subst tvs ; tcInstSkolTyVarsAt skol_info pushed_lvl overlappable subst tvs } tcInstSkolTyVarsAt :: SkolemInfo -> TcLevel -> Bool - -> TCvSubst -> [TyVar] - -> TcM (TCvSubst, [TcTyVar]) + -> Subst -> [TyVar] + -> TcM (Subst, [TcTyVar]) tcInstSkolTyVarsAt skol_info lvl overlappable subst tvs = freshenTyCoVarsX new_skol_tv subst tvs where @@ -575,12 +574,12 @@ tcSkolemiseInvisibleBndrs skol_info ty ; skol_info <- mkSkolemInfo skol_info ; let details = SkolemTv skol_info lvl False mk_skol_tv name kind = return (mkTcTyVar name kind details) -- No freshening - ; (subst, tvs') <- instantiateTyVarsX mk_skol_tv emptyTCvSubst tvs + ; (subst, tvs') <- instantiateTyVarsX mk_skol_tv emptySubst tvs ; return (tvs', substTy subst body_ty) } instantiateTyVarsX :: (Name -> Kind -> TcM TcTyVar) - -> TCvSubst -> [TyVar] - -> TcM (TCvSubst, [TcTyVar]) + -> Subst -> [TyVar] + -> TcM (Subst, [TcTyVar]) -- Instantiate each type variable in turn with the specified function instantiateTyVarsX mk_tv subst tvs = case tvs of @@ -592,25 +591,25 @@ instantiateTyVarsX mk_tv subst tvs ; return (subst', tv':tvs') } ------------------ -freshenTyVarBndrs :: [TyVar] -> TcM (TCvSubst, [TyVar]) +freshenTyVarBndrs :: [TyVar] -> TcM (Subst, [TyVar]) -- ^ Give fresh uniques to a bunch of TyVars, but they stay -- as TyVars, rather than becoming TcTyVars -- Used in 'GHC.Tc.Instance.Family.newFamInst', and 'GHC.Tc.Utils.Instantiate.newClsInst' freshenTyVarBndrs = freshenTyCoVars mkTyVar -freshenCoVarBndrsX :: TCvSubst -> [CoVar] -> TcM (TCvSubst, [CoVar]) +freshenCoVarBndrsX :: Subst -> [CoVar] -> TcM (Subst, [CoVar]) -- ^ Give fresh uniques to a bunch of CoVars -- Used in "GHC.Tc.Instance.Family.newFamInst" freshenCoVarBndrsX subst = freshenTyCoVarsX mkCoVar subst ------------------ freshenTyCoVars :: (Name -> Kind -> TyCoVar) - -> [TyVar] -> TcM (TCvSubst, [TyCoVar]) -freshenTyCoVars mk_tcv = freshenTyCoVarsX mk_tcv emptyTCvSubst + -> [TyVar] -> TcM (Subst, [TyCoVar]) +freshenTyCoVars mk_tcv = freshenTyCoVarsX mk_tcv emptySubst freshenTyCoVarsX :: (Name -> Kind -> TyCoVar) - -> TCvSubst -> [TyCoVar] - -> TcM (TCvSubst, [TyCoVar]) + -> Subst -> [TyCoVar] + -> TcM (Subst, [TyCoVar]) -- This a complete freshening operation: -- the skolems have a fresh unique, and a location from the monad -- See Note [Skolemising type variables] diff --git a/compiler/GHC/Tc/Utils/TcMType.hs b/compiler/GHC/Tc/Utils/TcMType.hs index c44ceba426..eed03d9323 100644 --- a/compiler/GHC/Tc/Utils/TcMType.hs +++ b/compiler/GHC/Tc/Utils/TcMType.hs @@ -1,4 +1,3 @@ - {-# LANGUAGE MultiWayIf #-} {-# LANGUAGE TupleSections #-} @@ -1072,35 +1071,35 @@ newOpenBoxedTypeKind ; let rr = mkTyConApp boxedRepDataConTyCon [lev] ; return (mkTYPEapp rr) } -newMetaTyVars :: [TyVar] -> TcM (TCvSubst, [TcTyVar]) +newMetaTyVars :: [TyVar] -> TcM (Subst, [TcTyVar]) -- Instantiate with META type variables -- Note that this works for a sequence of kind, type, and coercion variables -- variables. Eg [ (k:*), (a:k->k) ] -- Gives [ (k7:*), (a8:k7->k7) ] -newMetaTyVars = newMetaTyVarsX emptyTCvSubst - -- emptyTCvSubst has an empty in-scope set, but that's fine here +newMetaTyVars = newMetaTyVarsX emptySubst + -- emptySubst has an empty in-scope set, but that's fine here -- Since the tyvars are freshly made, they cannot possibly be -- captured by any existing for-alls. -newMetaTyVarsX :: TCvSubst -> [TyVar] -> TcM (TCvSubst, [TcTyVar]) +newMetaTyVarsX :: Subst -> [TyVar] -> TcM (Subst, [TcTyVar]) -- Just like newMetaTyVars, but start with an existing substitution. newMetaTyVarsX subst = mapAccumLM newMetaTyVarX subst -newMetaTyVarX :: TCvSubst -> TyVar -> TcM (TCvSubst, TcTyVar) +newMetaTyVarX :: Subst -> TyVar -> TcM (Subst, TcTyVar) -- Make a new unification variable tyvar whose Name and Kind come from -- an existing TyVar. We substitute kind variables in the kind. newMetaTyVarX = new_meta_tv_x TauTv -newMetaTyVarTyVarX :: TCvSubst -> TyVar -> TcM (TCvSubst, TcTyVar) +newMetaTyVarTyVarX :: Subst -> TyVar -> TcM (Subst, TcTyVar) -- Just like newMetaTyVarX, but make a TyVarTv newMetaTyVarTyVarX = new_meta_tv_x TyVarTv -newWildCardX :: TCvSubst -> TyVar -> TcM (TCvSubst, TcTyVar) +newWildCardX :: Subst -> TyVar -> TcM (Subst, TcTyVar) newWildCardX subst tv = do { new_tv <- newAnonMetaTyVar TauTv (substTy subst (tyVarKind tv)) ; return (extendTvSubstWithClone subst tv new_tv, new_tv) } -new_meta_tv_x :: MetaInfo -> TCvSubst -> TyVar -> TcM (TCvSubst, TcTyVar) +new_meta_tv_x :: MetaInfo -> Subst -> TyVar -> TcM (Subst, TcTyVar) new_meta_tv_x info subst tv = do { new_tv <- cloneAnonMetaTyVar info tv substd_kind ; let subst1 = extendTvSubstWithClone subst tv new_tv diff --git a/compiler/GHC/Tc/Utils/TcType.hs b/compiler/GHC/Tc/Utils/TcType.hs index 82924e9115..805e58fc39 100644 --- a/compiler/GHC/Tc/Utils/TcType.hs +++ b/compiler/GHC/Tc/Utils/TcType.hs @@ -1,4 +1,3 @@ - {-# LANGUAGE FlexibleContexts #-} {-# LANGUAGE ScopedTypeVariables #-} {-# LANGUAGE TupleSections #-} @@ -158,15 +157,15 @@ module GHC.Tc.Utils.TcType ( isVisibleBinder, isInvisibleBinder, -- Type substitutions - TCvSubst(..), -- Representation visible to a few friends - TvSubstEnv, emptyTCvSubst, mkEmptyTCvSubst, + Subst(..), -- Representation visible to a few friends + TvSubstEnv, emptySubst, mkEmptySubst, zipTvSubst, - mkTvSubstPrs, notElemTCvSubst, unionTCvSubst, - getTvSubstEnv, setTvSubstEnv, getTCvInScope, extendTCvInScope, - extendTCvInScopeList, extendTCvInScopeSet, extendTvSubstAndInScope, + mkTvSubstPrs, notElemSubst, unionSubst, + getTvSubstEnv, getSubstInScope, extendSubstInScope, + extendSubstInScopeList, extendSubstInScopeSet, extendTvSubstAndInScope, Type.lookupTyVar, Type.extendTCvSubst, Type.substTyVarBndr, Type.extendTvSubst, - isInScope, mkTCvSubst, mkTvSubst, zipTyEnv, zipCoEnv, + isInScope, mkSubst, mkTvSubst, zipTyEnv, zipCoEnv, Type.substTy, substTys, substScaledTys, substTyWith, substTyWithCoVars, substTyAddInScope, substTyUnchecked, substTysUnchecked, substScaledTyUnchecked, diff --git a/compiler/GHC/Tc/Utils/Unify.hs b/compiler/GHC/Tc/Utils/Unify.hs index 91b0d5015e..1eb81d8191 100644 --- a/compiler/GHC/Tc/Utils/Unify.hs +++ b/compiler/GHC/Tc/Utils/Unify.hs @@ -1370,7 +1370,7 @@ deeplySkolemise :: SkolemInfo -> TcSigmaType deeplySkolemise skol_info ty = go init_subst ty where - init_subst = mkEmptyTCvSubst (mkInScopeSet (tyCoVarsOfType ty)) + init_subst = mkEmptySubst (mkInScopeSet (tyCoVarsOfType ty)) go subst ty | Just (arg_tys, tvs, theta, ty') <- tcDeepSplitSigmaTy_maybe ty @@ -1397,7 +1397,7 @@ deeplyInstantiate :: CtOrigin -> TcType -> TcM (HsWrapper, Type) deeplyInstantiate orig ty = go init_subst ty where - init_subst = mkEmptyTCvSubst (mkInScopeSet (tyCoVarsOfType ty)) + init_subst = mkEmptySubst (mkInScopeSet (tyCoVarsOfType ty)) go subst ty | Just (arg_tys, tvs, theta, rho) <- tcDeepSplitSigmaTy_maybe ty diff --git a/compiler/GHC/Tc/Validity.hs b/compiler/GHC/Tc/Validity.hs index cd628b5622..d6a5b15dbb 100644 --- a/compiler/GHC/Tc/Validity.hs +++ b/compiler/GHC/Tc/Validity.hs @@ -1,4 +1,3 @@ - {-# LANGUAGE DerivingStrategies #-} {-# OPTIONS_GHC -Wno-incomplete-record-updates #-} @@ -2272,7 +2271,7 @@ checkConsistentFamInst (InClsInst { ai_class = clas -- For check_match, bind_me, see -- Note [Matching in the consistent-instantiation check] check_match :: [(Type,Type,ArgFlag)] -> TcM () - check_match triples = go emptyTCvSubst emptyTCvSubst triples + check_match triples = go emptySubst emptySubst triples go _ _ [] = return () go lr_subst rl_subst ((ty1,ty2,vis):triples) diff --git a/compiler/GHC/Types/Id/Make.hs b/compiler/GHC/Types/Id/Make.hs index e31460de7c..2806ad1bd0 100644 --- a/compiler/GHC/Types/Id/Make.hs +++ b/compiler/GHC/Types/Id/Make.hs @@ -616,7 +616,7 @@ mkDataConWorkId wkr_name data_con type Unboxer = Var -> UniqSM ([Var], CoreExpr -> CoreExpr) -- Unbox: bind rep vars by decomposing src var -data Boxer = UnitBox | Boxer (TCvSubst -> UniqSM ([Var], CoreExpr)) +data Boxer = UnitBox | Boxer (Subst -> UniqSM ([Var], CoreExpr)) -- Box: build src arg using these rep vars -- | Data Constructor Boxer |