diff options
| author | Yiyun Liu <yiyun.liu@tweag.io> | 2022-05-27 18:04:16 -0400 |
|---|---|---|
| committer | Marge Bot <ben+marge-bot@smart-cactus.org> | 2022-08-04 02:55:07 -0400 |
| commit | 35aef18de6d04473da95cb5a19d5cc111ee7ec45 (patch) | |
| tree | 6b7a91a7c48d913d48ad9cf5cc9c89efc263e03c | |
| parent | 97655ad88c42003bc5eeb5c026754b005229800c (diff) | |
| download | haskell-35aef18de6d04473da95cb5a19d5cc111ee7ec45.tar.gz | |
Remove TCvSubst and use Subst for both term and type-level subst
This patch removes the TCvSubst data type and instead uses Subst as
the environment for both term and type level substitution. This
change is partially motivated by the existential type proposal,
which will introduce types that contain expressions and therefore
forces us to carry around an "IdSubstEnv" even when substituting for
types. It also reduces the amount of code because "Subst" and
"TCvSubst" share a lot of common operations. There isn't any
noticeable impact on performance (geo. mean for ghc/alloc is around
0.0% but we have -94 loc and one less data type to worry abount).
Currently, the "TCvSubst" data type for substitution on types is
identical to the "Subst" data type except the former doesn't store
"IdSubstEnv". Using "Subst" for type-level substitution means there
will be a redundant field stored in the data type. However, in cases
where the substitution starts from the expression, using "Subst" for
type-level substitution saves us from having to project "Subst" into a
"TCvSubst". This probably explains why the allocation is mostly even
despite the redundant field.
The patch deletes "TCvSubst" and moves "Subst" and its relevant
functions from "GHC.Core.Subst" into "GHC.Core.TyCo.Subst".
Substitution on expressions is still defined in "GHC.Core.Subst" so we
don't have to expose the definition of "Expr" in the hs-boot file that
"GHC.Core.TyCo.Subst" must import to refer to "IdSubstEnv" (whose
codomain is "CoreExpr"). Most functions named fooTCvSubst are renamed
into fooSubst with a few exceptions (e.g. "isEmptyTCvSubst" is a
distinct function from "isEmptySubst"; the former ignores the
emptiness of "IdSubstEnv"). These exceptions mainly exist for
performance reasons and will go away when "Expr" and "Type" are
mutually recursively defined (we won't be able to take those
shortcuts if we can't make the assumption that expressions don't
appear in types).
49 files changed, 654 insertions, 730 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 diff --git a/testsuite/tests/corelint/LintEtaExpand.stderr b/testsuite/tests/corelint/LintEtaExpand.stderr index 366fae4bb3..47274d0cc6 100644 --- a/testsuite/tests/corelint/LintEtaExpand.stderr +++ b/testsuite/tests/corelint/LintEtaExpand.stderr @@ -2,17 +2,17 @@ Cannot eta expand ‘coerce’ The following type does not have a fixed runtime representation: • a :: TYPE k - Substitution: [TCvSubst - In scope: InScope {a q} - Type env: [] - Co env: []] + Substitution: <InScope = {a q} + IdSubst = [] + TvSubst = [] + CvSubst = []> in coerce BAD 1 <no location info>: warning: Cannot eta expand ‘coerce’ The following type does not have a fixed runtime representation: • a :: TYPE q - Substitution: [TCvSubst - In scope: InScope {a q} - Type env: [] - Co env: []] + Substitution: <InScope = {a q} + IdSubst = [] + TvSubst = [] + CvSubst = []> in coerce BAD 2 diff --git a/testsuite/tests/corelint/T21115b.stderr b/testsuite/tests/corelint/T21115b.stderr index eaa70cc22f..1b245cf3c7 100644 --- a/testsuite/tests/corelint/T21115b.stderr +++ b/testsuite/tests/corelint/T21115b.stderr @@ -6,10 +6,10 @@ T21115b.hs:9:1: warning: In the body of lambda with binder ds :: Double# In the body of letrec with binders fail :: (# #) -> Int# In the body of letrec with binders fail :: (# #) -> Int# - Substitution: [TCvSubst - In scope: InScope {} - Type env: [] - Co env: []] + Substitution: <InScope = {} + IdSubst = [] + TvSubst = [] + CvSubst = []> *** Offending Program *** Rec { $trModule = Module (TrNameS "main"#) (TrNameS "T21115b"#) |