summaryrefslogtreecommitdiff
path: root/compiler/GHC/Core
diff options
context:
space:
mode:
authorYiyun Liu <yiyun.liu@tweag.io>2022-05-27 18:04:16 -0400
committerMarge Bot <ben+marge-bot@smart-cactus.org>2022-08-04 02:55:07 -0400
commit35aef18de6d04473da95cb5a19d5cc111ee7ec45 (patch)
tree6b7a91a7c48d913d48ad9cf5cc9c89efc263e03c /compiler/GHC/Core
parent97655ad88c42003bc5eeb5c026754b005229800c (diff)
downloadhaskell-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).
Diffstat (limited to 'compiler/GHC/Core')
-rw-r--r--compiler/GHC/Core/Coercion.hs66
-rw-r--r--compiler/GHC/Core/Coercion/Opt.hs6
-rw-r--r--compiler/GHC/Core/DataCon.hs2
-rw-r--r--compiler/GHC/Core/Lint.hs38
-rw-r--r--compiler/GHC/Core/Opt/Arity.hs20
-rw-r--r--compiler/GHC/Core/Opt/CSE.hs4
-rw-r--r--compiler/GHC/Core/Opt/SetLevels.hs9
-rw-r--r--compiler/GHC/Core/Opt/Simplify/Env.hs29
-rw-r--r--compiler/GHC/Core/Opt/Simplify/Iteration.hs2
-rw-r--r--compiler/GHC/Core/Opt/SpecConstr.hs6
-rw-r--r--compiler/GHC/Core/Opt/Specialise.hs12
-rw-r--r--compiler/GHC/Core/Opt/WorkWrap/Utils.hs4
-rw-r--r--compiler/GHC/Core/Ppr.hs-boot11
-rw-r--r--compiler/GHC/Core/Rules.hs8
-rw-r--r--compiler/GHC/Core/SimpleOpt.hs24
-rw-r--r--compiler/GHC/Core/Subst.hs198
-rw-r--r--compiler/GHC/Core/TyCo/Subst.hs534
-rw-r--r--compiler/GHC/Core/Type.hs33
-rw-r--r--compiler/GHC/Core/Unify.hs74
-rw-r--r--compiler/GHC/Core/Utils.hs2
20 files changed, 504 insertions, 578 deletions
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)
View Lorry Controller Status