-- Environments
SimplEnv(..), StaticEnv, pprSimplEnv, -- Temp not abstract
- mkSimplEnv, extendIdSubst, SimplEnv.extendTvSubst,
+ mkSimplEnv, extendIdSubst, SimplEnv.extendTvSubst, SimplEnv.extendCvSubst,
zapSubstEnv, setSubstEnv,
getInScope, setInScope, setInScopeSet, modifyInScope, addNewInScopeIds,
getSimplRules,
SimplSR(..), mkContEx, substId, lookupRecBndr,
simplNonRecBndr, simplRecBndrs, simplLamBndr, simplLamBndrs,
- simplBinder, simplBinders, addBndrRules,
- substExpr, substTy, substTyVar, getTvSubst, mkCoreSubst,
+ simplBinder, simplBinders, addBndrRules,
+ substExpr, substTy, substTyVar, getTvSubst,
+ getCvSubst, substCo, substCoVar,
+ mkCoreSubst,
-- Floats
Floats, emptyFloats, isEmptyFloats, addNonRec, addFloats, extendFloats,
import VarSet
import OrdList
import Id
+import MkCore
+import TysWiredIn
import qualified CoreSubst
-import qualified Type ( substTy, substTyVarBndr, substTyVar )
+import qualified Type
import Type hiding ( substTy, substTyVarBndr, substTyVar )
-import Coercion
+import qualified Coercion
+import Coercion hiding ( substCo, substTy, substCoVar, substCoVarBndr, substTyVarBndr )
import BasicTypes
import MonadUtils
import Outputable
seCC :: CostCentreStack, -- The enclosing CCS (when profiling)
-- The current substitution
- seTvSubst :: TvSubstEnv, -- InTyVar |--> OutType
- seIdSubst :: SimplIdSubst, -- InId |--> OutExpr
+ seTvSubst :: TvSubstEnv, -- InTyVar |--> OutType
+ seCvSubst :: CvSubstEnv, -- InTyCoVar |--> OutCoercion
+ seIdSubst :: SimplIdSubst, -- InId |--> OutExpr
----------- Dynamic part of the environment -----------
-- Dynamic in the sense of describing the setup where
= DoneEx OutExpr -- Completed term
| DoneId OutId -- Completed term variable
| ContEx TvSubstEnv -- A suspended substitution
+ CvSubstEnv
SimplIdSubst
InExpr
instance Outputable SimplSR where
ppr (DoneEx e) = ptext (sLit "DoneEx") <+> ppr e
ppr (DoneId v) = ptext (sLit "DoneId") <+> ppr v
- ppr (ContEx _tv _id e) = vcat [ptext (sLit "ContEx") <+> ppr e {-,
+ ppr (ContEx _tv _cv _id e) = vcat [ptext (sLit "ContEx") <+> ppr e {-,
ppr (filter_env tv), ppr (filter_env id) -}]
-- where
-- fvs = exprFreeVars e
\begin{code}
mkSimplEnv :: SimplifierMode -> SimplEnv
mkSimplEnv mode
- = SimplEnv { seCC = subsumedCCS,
- seMode = mode, seInScope = emptyInScopeSet,
- seFloats = emptyFloats,
- seTvSubst = emptyVarEnv, seIdSubst = emptyVarEnv }
+ = SimplEnv { seCC = subsumedCCS
+ , seMode = mode
+ , seInScope = init_in_scope
+ , seFloats = emptyFloats
+ , seTvSubst = emptyVarEnv
+ , seCvSubst = emptyVarEnv
+ , seIdSubst = emptyVarEnv }
-- The top level "enclosing CC" is "SUBSUMED".
----------------------
+init_in_scope :: InScopeSet
+init_in_scope = mkInScopeSet (unitVarSet (mkWildValBinder unitTy))
+ -- See Note [WildCard binders]
+\end{code}
+
+Note [WildCard binders]
+~~~~~~~~~~~~~~~~~~~~~~~
+The program to be simplified may have wild binders
+ case e of wild { p -> ... }
+We want to *rename* them away, so that there are no
+occurrences of 'wild-id' (with wildCardKey). The easy
+way to do that is to start of with a representative
+Id in the in-scope set
+
+There can be be *occurrences* of wild-id. For example,
+MkCore.mkCoreApp transforms
+ e (a /# b) --> case (a /# b) of wild { DEFAULT -> e wild }
+This is ok provided 'wild' isn't free in 'e', and that's the delicate
+thing. Generally, you want to run the simplifier to get rid of the
+wild-ids before doing much else.
+
+It's a very dark corner of GHC. Maybe it should be cleaned up.
+
+\begin{code}
getMode :: SimplEnv -> SimplifierMode
getMode env = seMode env
---------------------
extendIdSubst :: SimplEnv -> Id -> SimplSR -> SimplEnv
extendIdSubst env@(SimplEnv {seIdSubst = subst}) var res
- = env {seIdSubst = extendVarEnv subst var res}
+ = ASSERT2( isId var && not (isCoVar var), ppr var )
+ env {seIdSubst = extendVarEnv subst var res}
extendTvSubst :: SimplEnv -> TyVar -> Type -> SimplEnv
extendTvSubst env@(SimplEnv {seTvSubst = subst}) var res
= env {seTvSubst = extendVarEnv subst var res}
+extendCvSubst :: SimplEnv -> CoVar -> Coercion -> SimplEnv
+extendCvSubst env@(SimplEnv {seCvSubst = subst}) var res
+ = env {seCvSubst = extendVarEnv subst var res}
+
---------------------
getInScope :: SimplEnv -> InScopeSet
getInScope env = seInScope env
---------------------
zapSubstEnv :: SimplEnv -> SimplEnv
-zapSubstEnv env = env {seTvSubst = emptyVarEnv, seIdSubst = emptyVarEnv}
+zapSubstEnv env = env {seTvSubst = emptyVarEnv, seCvSubst = emptyVarEnv, seIdSubst = emptyVarEnv}
-setSubstEnv :: SimplEnv -> TvSubstEnv -> SimplIdSubst -> SimplEnv
-setSubstEnv env tvs ids = env { seTvSubst = tvs, seIdSubst = ids }
+setSubstEnv :: SimplEnv -> TvSubstEnv -> CvSubstEnv -> SimplIdSubst -> SimplEnv
+setSubstEnv env tvs cvs ids = env { seTvSubst = tvs, seCvSubst = cvs, seIdSubst = ids }
mkContEx :: SimplEnv -> InExpr -> SimplSR
-mkContEx (SimplEnv { seTvSubst = tvs, seIdSubst = ids }) e = ContEx tvs ids e
+mkContEx (SimplEnv { seTvSubst = tvs, seCvSubst = cvs, seIdSubst = ids }) e = ContEx tvs cvs ids e
\end{code}
Just (DoneId v) -> DoneId (refine in_scope v)
Just (DoneEx (Var v)) -> DoneId (refine in_scope v)
Just res -> res -- DoneEx non-var, or ContEx
- where
-- Get the most up-to-date thing from the in-scope set
-- Even though it isn't in the substitution, it may be in
-- The substitution is extended only if the variable is cloned, because
-- we *don't* need to use it to track occurrence info.
simplBinder env bndr
- | isTyCoVar bndr = do { let (env', tv) = substTyVarBndr env bndr
+ | isTyVar bndr = do { let (env', tv) = substTyVarBndr env bndr
; seqTyVar tv `seq` return (env', tv) }
| otherwise = do { let (env', id) = substIdBndr env bndr
; seqId id `seq` return (env', id) }
; seqIds ids1 `seq` return env1 }
---------------
-substIdBndr :: SimplEnv
- -> InBndr -- Env and binder to transform
- -> (SimplEnv, OutBndr)
+substIdBndr :: SimplEnv -> InBndr -> (SimplEnv, OutBndr)
+-- Might be a coercion variable
+substIdBndr env bndr
+ | isCoVar bndr = substCoVarBndr env bndr
+ | otherwise = substNonCoVarIdBndr env bndr
+
+---------------
+substNonCoVarIdBndr
+ :: SimplEnv
+ -> InBndr -- Env and binder to transform
+ -> (SimplEnv, OutBndr)
-- Clone Id if necessary, substitute its type
-- Return an Id with its
-- * Type substituted
-- Similar to CoreSubst.substIdBndr, except that
-- the type of id_subst differs
-- all fragile info is zapped
-
-substIdBndr env@(SimplEnv { seInScope = in_scope, seIdSubst = id_subst })
- old_id
- = (env { seInScope = in_scope `extendInScopeSet` new_id,
+substNonCoVarIdBndr env@(SimplEnv { seInScope = in_scope, seIdSubst = id_subst })
+ old_id
+ = ASSERT2( not (isCoVar old_id), ppr old_id )
+ (env { seInScope = in_scope `extendInScopeSet` new_id,
seIdSubst = new_subst }, new_id)
where
id1 = uniqAway in_scope old_id
getTvSubst (SimplEnv { seInScope = in_scope, seTvSubst = tv_env })
= mkTvSubst in_scope tv_env
+getCvSubst :: SimplEnv -> CvSubst
+getCvSubst (SimplEnv { seInScope = in_scope, seTvSubst = tv_env, seCvSubst = cv_env })
+ = CvSubst in_scope tv_env cv_env
+
substTy :: SimplEnv -> Type -> Type
substTy env ty = Type.substTy (getTvSubst env) ty
substTyVarBndr env tv
= case Type.substTyVarBndr (getTvSubst env) tv of
(TvSubst in_scope' tv_env', tv')
- -> (env { seInScope = in_scope', seTvSubst = tv_env'}, tv')
+ -> (env { seInScope = in_scope', seTvSubst = tv_env' }, tv')
+
+substCoVar :: SimplEnv -> CoVar -> Coercion
+substCoVar env tv = Coercion.substCoVar (getCvSubst env) tv
+
+substCoVarBndr :: SimplEnv -> CoVar -> (SimplEnv, CoVar)
+substCoVarBndr env cv
+ = case Coercion.substCoVarBndr (getCvSubst env) cv of
+ (CvSubst 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 (getCvSubst env) co
-- When substituting in rules etc we can get CoreSubst to do the work
-- But CoreSubst uses a simpler form of IdSubstEnv, so we must impedence-match
-- the substitutions are typically small, and laziness will avoid work in many cases.
mkCoreSubst :: SDoc -> SimplEnv -> CoreSubst.Subst
-mkCoreSubst doc (SimplEnv { seInScope = in_scope, seTvSubst = tv_env, seIdSubst = id_env })
- = mk_subst tv_env id_env
+mkCoreSubst doc (SimplEnv { seInScope = in_scope, seTvSubst = tv_env, seCvSubst = cv_env, seIdSubst = id_env })
+ = mk_subst tv_env cv_env id_env
where
- mk_subst tv_env id_env = CoreSubst.mkSubst in_scope tv_env (mapVarEnv fiddle id_env)
+ mk_subst tv_env cv_env id_env = CoreSubst.mkSubst in_scope tv_env cv_env (mapVarEnv fiddle id_env)
- fiddle (DoneEx e) = e
- fiddle (DoneId v) = Var v
- fiddle (ContEx tv id e) = CoreSubst.substExpr (text "mkCoreSubst" <+> doc) (mk_subst tv id) e
+ fiddle (DoneEx e) = e
+ fiddle (DoneId v) = Var v
+ fiddle (ContEx tv cv id e) = CoreSubst.substExpr (text "mkCoreSubst" <+> doc) (mk_subst tv cv id) e
-- Don't shortcut here
------------------
substIdType :: SimplEnv -> Id -> Id
-substIdType (SimplEnv { seInScope = in_scope, seTvSubst = tv_env}) id
+substIdType (SimplEnv { seInScope = in_scope, seTvSubst = tv_env }) id
| isEmptyVarEnv tv_env || isEmptyVarSet (tyVarsOfType old_ty) = id
| otherwise = Id.setIdType id (Type.substTy (TvSubst in_scope tv_env) old_ty)
-- The tyVarsOfType is cheaper than it looks
projects / ghc-hetmet.git / blobdiff