%
-% (c) The AQUA Project, Glasgow University, 1993-1998
+o% (c) The AQUA Project, Glasgow University, 1993-1998
%
\section[SimplMonad]{The simplifier Monad}
\begin{code}
module SimplEnv (
- InId, InBind, InExpr, InAlt, InArg, InType, InBndr,
- OutId, OutTyVar, OutBind, OutExpr, OutAlt, OutArg, OutType, OutBndr,
+ InId, InBind, InExpr, InAlt, InArg, InType, InBndr, InVar,
+ OutId, OutTyVar, OutBind, OutExpr, OutAlt, OutArg, OutType, OutBndr, OutVar,
InCoercion, OutCoercion,
-- The simplifier mode
- setMode, getMode,
+ setMode, getMode, updMode,
- -- Switch checker
- SwitchChecker, SwitchResult(..), getSwitchChecker, getSimplIntSwitch,
- isAmongSimpl, intSwitchSet, switchIsOn,
-
- setEnclosingCC, getEnclosingCC,
+ setEnclosingCC, getEnclosingCC,
-- Environments
- SimplEnv(..), pprSimplEnv, -- Temp not abstract
- mkSimplEnv, extendIdSubst, SimplEnv.extendTvSubst,
+ SimplEnv(..), StaticEnv, pprSimplEnv, -- Temp not abstract
+ mkSimplEnv, extendIdSubst, SimplEnv.extendTvSubst, SimplEnv.extendCvSubst,
zapSubstEnv, setSubstEnv,
getInScope, setInScope, setInScopeSet, modifyInScope, addNewInScopeIds,
- getRules,
+ getSimplRules,
SimplSR(..), mkContEx, substId, lookupRecBndr,
simplNonRecBndr, simplRecBndrs, simplLamBndr, simplLamBndrs,
- simplBinder, simplBinders, addBndrRules,
- substExpr, substWorker, substTy,
+ simplBinder, simplBinders, addBndrRules,
+ substExpr, substTy, substTyVar, getTvSubst,
+ getCvSubst, substCo, substCoVar,
+ mkCoreSubst,
-- Floats
Floats, emptyFloats, isEmptyFloats, addNonRec, addFloats, extendFloats,
#include "HsVersions.h"
import SimplMonad
+import CoreMonad ( SimplifierMode(..) )
import IdInfo
import CoreSyn
import CoreUtils
import VarSet
import OrdList
import Id
-import qualified CoreSubst ( Subst, mkSubst, substExpr, substSpec, substWorker )
-import qualified Type ( substTy, substTyVarBndr )
-import Type hiding ( substTy, substTyVarBndr )
-import Coercion
+import MkCore
+import TysWiredIn
+import qualified CoreSubst
+import qualified Type
+import Type hiding ( substTy, substTyVarBndr, substTyVar )
+import qualified Coercion
+import Coercion hiding ( substCo, substTy, substCoVar, substCoVarBndr, substTyVarBndr )
import BasicTypes
-import DynFlags
import MonadUtils
import Outputable
import FastString
\begin{code}
type InBndr = CoreBndr
+type InVar = Var -- Not yet cloned
type InId = Id -- Not yet cloned
type InType = Type -- Ditto
type InBind = CoreBind
type InCoercion = Coercion
type OutBndr = CoreBndr
+type OutVar = Var -- Cloned
type OutId = Id -- Cloned
type OutTyVar = TyVar -- Cloned
type OutType = Type -- Cloned
\begin{code}
data SimplEnv
= SimplEnv {
+ ----------- Static part of the environment -----------
+ -- Static in the sense of lexically scoped,
+ -- wrt the original expression
+
seMode :: SimplifierMode,
- seChkr :: SwitchChecker,
- seCC :: CostCentreStack, -- The enclosing CCS (when profiling)
+ seCC :: CostCentreStack, -- The enclosing CCS (when profiling)
+
+ -- The current substitution
+ 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
+ -- the expression finally ends up
-- The current set of in-scope variables
-- They are all OutVars, and all bound in this module
seInScope :: InScopeSet, -- OutVars only
-- Includes all variables bound by seFloats
- seFloats :: Floats,
+ seFloats :: Floats
-- See Note [Simplifier floats]
-
- -- The current substitution
- seTvSubst :: TvSubstEnv, -- InTyVar |--> OutType
- seIdSubst :: SimplIdSubst -- InId |--> OutExpr
-
}
+type StaticEnv = SimplEnv -- Just the static part is relevant
+
pprSimplEnv :: SimplEnv -> SDoc
-- Used for debugging; selective
pprSimplEnv env
= vcat [ptext (sLit "TvSubst:") <+> ppr (seTvSubst env),
- ptext (sLit "IdSubst:") <+> ppr (seIdSubst env) ]
+ ptext (sLit "IdSubst:") <+> ppr (seIdSubst env),
+ ptext (sLit "InScope:") <+> vcat (map ppr_one in_scope_vars)
+ ]
+ where
+ in_scope_vars = varEnvElts (getInScopeVars (seInScope env))
+ ppr_one v | isId v = ppr v <+> ppr (idUnfolding v)
+ | otherwise = ppr v
type SimplIdSubst = IdEnv SimplSR -- IdId |--> OutExpr
-- See Note [Extending the Subst] in CoreSubst
= 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
-- keep uniq _ = uniq `elemUFM_Directly` fvs
\end{code}
-
+Note [SimplEnv invariants]
+~~~~~~~~~~~~~~~~~~~~~~~~~~
seInScope:
The in-scope part of Subst includes *all* in-scope TyVars and Ids
The elements of the set may have better IdInfo than the
* substId adds a binding (DoneId new_id) to the substitution if
the Id's unique has changed
-
Note, though that the substitution isn't necessarily extended
- if the type changes. Why not? Because of the next point:
+ if the type of the Id changes. Why not? Because of the next point:
* We *always, always* finish by looking up in the in-scope set
any variable that doesn't get a DoneEx or DoneVar hit in the substitution.
\begin{code}
-mkSimplEnv :: SimplifierMode -> SwitchChecker -> SimplEnv
-mkSimplEnv mode switches
- = SimplEnv { seChkr = switches, seCC = subsumedCCS,
- seMode = mode, seInScope = emptyInScopeSet,
- seFloats = emptyFloats,
- seTvSubst = emptyVarEnv, seIdSubst = emptyVarEnv }
+mkSimplEnv :: SimplifierMode -> SimplEnv
+mkSimplEnv mode
+ = SimplEnv { seCC = subsumedCCS
+ , seMode = mode
+ , seInScope = init_in_scope
+ , seFloats = emptyFloats
+ , seTvSubst = emptyVarEnv
+ , seCvSubst = emptyVarEnv
+ , seIdSubst = emptyVarEnv }
-- The top level "enclosing CC" is "SUBSUMED".
----------------------
-getSwitchChecker :: SimplEnv -> SwitchChecker
-getSwitchChecker env = seChkr env
+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
setMode :: SimplifierMode -> SimplEnv -> SimplEnv
setMode mode env = env { seMode = mode }
+updMode :: (SimplifierMode -> SimplifierMode) -> SimplEnv -> SimplEnv
+updMode upd env = env { seMode = upd (seMode env) }
+
---------------------
getEnclosingCC :: SimplEnv -> CostCentreStack
getEnclosingCC env = seCC 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
-- _delete_ it from the substitution when going inside
-- the (\x -> ...)!
-modifyInScope :: SimplEnv -> CoreBndr -> CoreBndr -> SimplEnv
-modifyInScope env@(SimplEnv {seInScope = in_scope}) v v'
- = env {seInScope = modifyInScopeSet in_scope v v'}
+modifyInScope :: SimplEnv -> CoreBndr -> SimplEnv
+-- The variable should already be in scope, but
+-- replace the existing version with this new one
+-- which has more information
+modifyInScope env@(SimplEnv {seInScope = in_scope}) v
+ = env {seInScope = extendInScopeSet in_scope v}
---------------------
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
-
-isEmptySimplSubst :: SimplEnv -> Bool
-isEmptySimplSubst (SimplEnv { seTvSubst = tvs, seIdSubst = ids })
- = isEmptyVarEnv tvs && isEmptyVarEnv ids
+mkContEx (SimplEnv { seTvSubst = tvs, seCvSubst = cvs, seIdSubst = ids }) e = ContEx tvs cvs ids e
\end{code}
doFloatFromRhs lvl rec str rhs (SimplEnv {seFloats = Floats fs ff})
= not (isNilOL fs) && want_to_float && can_float
where
- want_to_float = isTopLevel lvl || exprIsCheap rhs
+ want_to_float = isTopLevel lvl || exprIsExpandable rhs
can_float = case ff of
FltLifted -> True
FltOkSpec -> isNotTopLevel lvl && isNonRec rec
-- in-scope set (although it might also have been created with newId)
-- but it may now have more IdInfo
addNonRec env id rhs
- = env { seFloats = seFloats env `addFlts` unitFloat (NonRec id rhs),
+ = id `seq` -- This seq forces the Id, and hence its IdInfo,
+ -- and hence any inner substitutions
+ env { seFloats = seFloats env `addFlts` unitFloat (NonRec id rhs),
seInScope = extendInScopeSet (seInScope env) id }
extendFloats :: SimplEnv -> OutBind -> SimplEnv
%* *
%************************************************************************
+Note [Global Ids in the substitution]
+~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~
+We look up even a global (eg imported) Id in the substitution. Consider
+ case X.g_34 of b { (a,b) -> ... case X.g_34 of { (p,q) -> ...} ... }
+The binder-swap in the occurence analyser will add a binding
+for a LocalId version of g (with the same unique though):
+ case X.g_34 of b { (a,b) -> let g_34 = b in
+ ... case X.g_34 of { (p,q) -> ...} ... }
+So we want to look up the inner X.g_34 in the substitution, where we'll
+find that it has been substituted by b. (Or conceivably cloned.)
\begin{code}
substId :: SimplEnv -> InId -> SimplSR
-- Returns DoneEx only on a non-Var expression
substId (SimplEnv { seInScope = in_scope, seIdSubst = ids }) v
- | not (isLocalId v)
- = DoneId v
- | otherwise -- A local Id
- = case lookupVarEnv ids v of
+ = case lookupVarEnv ids v of -- Note [Global Ids in the substitution]
Nothing -> DoneId (refine in_scope v)
Just (DoneId v) -> DoneId (refine in_scope v)
- Just (DoneEx (Var v))
- | isLocalId v -> DoneId (refine in_scope v)
- | otherwise -> DoneId 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 in-scope set with better IdInfo
refine :: InScopeSet -> Var -> Var
-refine in_scope v = case lookupInScope in_scope v of
+refine in_scope v
+ | isLocalId v = case lookupInScope in_scope v of
Just v' -> v'
Nothing -> WARN( True, ppr v ) v -- This is an error!
+ | otherwise = v
lookupRecBndr :: SimplEnv -> InId -> OutId
-- Look up an Id which has been put into the envt by simplRecBndrs,
old_unf = idUnfolding bndr
(env1, id1) = substIdBndr env bndr
id2 = id1 `setIdUnfolding` substUnfolding env old_unf
- env2 = modifyInScope env1 id1 id2
+ env2 = modifyInScope env1 id2
---------------
simplNonRecBndr :: SimplEnv -> InBndr -> SimplM (SimplEnv, OutBndr)
; 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
-- Rules are added back in to to the bin
addBndrRules env in_id out_id
| isEmptySpecInfo old_rules = (env, out_id)
- | otherwise = (modifyInScope env out_id final_id, final_id)
+ | otherwise = (modifyInScope env final_id, final_id)
where
- subst = mkCoreSubst env
+ subst = mkCoreSubst (text "local rules") env
old_rules = idSpecialisation in_id
new_rules = CoreSubst.substSpec subst out_id old_rules
final_id = out_id `setIdSpecialisation` new_rules
-
-------------------
-substIdType :: SimplEnv -> Id -> 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
- -- because we cache the free tyvars of the type
- -- in a Note in the id's type itself
- where
- old_ty = idType id
-
-------------------
-substUnfolding :: SimplEnv -> Unfolding -> Unfolding
-substUnfolding _ NoUnfolding = NoUnfolding
-substUnfolding _ (OtherCon cons) = OtherCon cons
-substUnfolding env (CompulsoryUnfolding rhs) = CompulsoryUnfolding (substExpr env rhs)
-substUnfolding env (CoreUnfolding rhs t v w g) = CoreUnfolding (substExpr env rhs) t v w g
-
-------------------
-substWorker :: SimplEnv -> WorkerInfo -> WorkerInfo
-substWorker _ NoWorker = NoWorker
-substWorker env wkr_info = CoreSubst.substWorker (mkCoreSubst env) wkr_info
\end{code}
%************************************************************************
\begin{code}
+getTvSubst :: SimplEnv -> TvSubst
+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 (SimplEnv { seInScope = in_scope, seTvSubst = tv_env }) ty
- = Type.substTy (TvSubst in_scope tv_env) ty
+substTy env ty = Type.substTy (getTvSubst env) ty
+
+substTyVar :: SimplEnv -> TyVar -> Type
+substTyVar env tv = Type.substTyVar (getTvSubst env) tv
substTyVarBndr :: SimplEnv -> TyVar -> (SimplEnv, TyVar)
-substTyVarBndr env@(SimplEnv { seInScope = in_scope, seTvSubst = tv_env }) tv
- = case Type.substTyVarBndr (TvSubst in_scope tv_env) tv of
+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
-- here. I think the this will not usually result in a lot of work;
-- the substitutions are typically small, and laziness will avoid work in many cases.
-mkCoreSubst :: SimplEnv -> CoreSubst.Subst
-mkCoreSubst (SimplEnv { seInScope = in_scope, seTvSubst = tv_env, seIdSubst = id_env })
- = mk_subst tv_env id_env
+mkCoreSubst :: SDoc -> SimplEnv -> CoreSubst.Subst
+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 (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
-substExpr :: SimplEnv -> CoreExpr -> CoreExpr
-substExpr env expr
- | isEmptySimplSubst env = expr
- | otherwise = CoreSubst.substExpr (mkCoreSubst env) expr
+------------------
+substIdType :: SimplEnv -> Id -> 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
+ -- because we cache the free tyvars of the type
+ -- in a Note in the id's type itself
+ where
+ old_ty = idType id
+
+------------------
+substExpr :: SDoc -> SimplEnv -> CoreExpr -> CoreExpr
+substExpr doc env
+ = CoreSubst.substExpr (text "SimplEnv.substExpr1" <+> doc)
+ (mkCoreSubst (text "SimplEnv.substExpr2" <+> doc) env)
+ -- Do *not* short-cut in the case of an empty substitution
+ -- See Note [SimplEnv invariants]
+
+substUnfolding :: SimplEnv -> Unfolding -> Unfolding
+substUnfolding env unf = CoreSubst.substUnfolding (mkCoreSubst (text "subst-unfolding") env) unf
+ -- Do *not* short-cut in the case of an empty substitution
+ -- See Note [SimplEnv invariants]
\end{code}
projects / ghc-hetmet.git / blobdiff