X-Git-Url: http://git.megacz.com/?p=ghc-hetmet.git;a=blobdiff_plain;f=compiler%2FsimplCore%2FSimplEnv.lhs;h=d9eea39ed69e7bb1d76820ee0af5e4e532dc9086;hp=c10ad907b6006f970c52e13070adb62e4dc591bf;hb=16b9e80dc14db24509f051f294b5b51943285090;hpb=72462499b891d5779c19f3bda03f96e24f9554ae diff --git a/compiler/simplCore/SimplEnv.lhs b/compiler/simplCore/SimplEnv.lhs index c10ad90..d9eea39 100644 --- a/compiler/simplCore/SimplEnv.lhs +++ b/compiler/simplCore/SimplEnv.lhs @@ -1,35 +1,31 @@ % -% (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 + SimplEnv(..), StaticEnv, pprSimplEnv, -- Temp not abstract mkSimplEnv, extendIdSubst, SimplEnv.extendTvSubst, zapSubstEnv, setSubstEnv, getInScope, setInScope, setInScopeSet, modifyInScope, addNewInScopeIds, - getSimplRules, inGentleMode, + getSimplRules, SimplSR(..), mkContEx, substId, lookupRecBndr, simplNonRecBndr, simplRecBndrs, simplLamBndr, simplLamBndrs, simplBinder, simplBinders, addBndrRules, - substExpr, substTy, mkCoreSubst, + substExpr, substTy, substTyVar, getTvSubst, mkCoreSubst, -- Floats Floats, emptyFloats, isEmptyFloats, addNonRec, addFloats, extendFloats, @@ -40,6 +36,7 @@ module SimplEnv ( #include "HsVersions.h" import SimplMonad +import CoreMonad ( SimplifierMode(..) ) import IdInfo import CoreSyn import CoreUtils @@ -49,12 +46,13 @@ import VarEnv import VarSet import OrdList import Id -import qualified CoreSubst ( Subst, mkSubst, substExpr, substSpec, substUnfolding ) -import qualified Type ( substTy, substTyVarBndr ) -import Type hiding ( substTy, substTyVarBndr ) +import MkCore +import TysWiredIn +import qualified CoreSubst +import qualified Type ( substTy, substTyVarBndr, substTyVar ) +import Type hiding ( substTy, substTyVarBndr, substTyVar ) import Coercion import BasicTypes -import DynFlags import MonadUtils import Outputable import FastString @@ -70,6 +68,7 @@ import Data.List \begin{code} type InBndr = CoreBndr +type InVar = Var -- Not yet cloned type InId = Id -- Not yet cloned type InType = Type -- Ditto type InBind = CoreBind @@ -79,6 +78,7 @@ type InArg = CoreArg type InCoercion = Coercion type OutBndr = CoreBndr +type OutVar = Var -- Cloned type OutId = Id -- Cloned type OutTyVar = TyVar -- Cloned type OutType = Type -- Cloned @@ -99,28 +99,42 @@ type OutArg = CoreArg \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 + 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 @@ -143,7 +157,8 @@ instance Outputable SimplSR where -- 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 @@ -179,9 +194,8 @@ seIdSubst: * 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. @@ -206,29 +220,48 @@ seIdSubst: \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 + , 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 } -inGentleMode :: SimplEnv -> Bool -inGentleMode env = case seMode env of - SimplGently -> True - _other -> False +updMode :: (SimplifierMode -> SimplifierMode) -> SimplEnv -> SimplEnv +updMode upd env = env { seMode = upd (seMode env) } --------------------- getEnclosingCC :: SimplEnv -> CostCentreStack @@ -383,7 +416,9 @@ addNonRec :: SimplEnv -> OutId -> OutExpr -> SimplEnv -- 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 @@ -514,7 +549,7 @@ simplBinder :: SimplEnv -> InBndr -> SimplM (SimplEnv, OutBndr) -- 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 - | isTyVar bndr = do { let (env', tv) = substTyVarBndr env bndr + | isTyCoVar 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) } @@ -661,7 +696,7 @@ addBndrRules env in_id out_id | isEmptySpecInfo old_rules = (env, out_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 @@ -675,13 +710,19 @@ addBndrRules env in_id out_id %************************************************************************ \begin{code} +getTvSubst :: SimplEnv -> TvSubst +getTvSubst (SimplEnv { seInScope = in_scope, seTvSubst = tv_env }) + = mkTvSubst in_scope tv_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') @@ -690,15 +731,16 @@ substTyVarBndr env@(SimplEnv { seInScope = in_scope, seTvSubst = tv_env }) tv -- 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 }) +mkCoreSubst :: SDoc -> SimplEnv -> CoreSubst.Subst +mkCoreSubst doc (SimplEnv { seInScope = in_scope, seTvSubst = tv_env, seIdSubst = id_env }) = mk_subst tv_env id_env where mk_subst tv_env id_env = CoreSubst.mkSubst in_scope tv_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 (ContEx tv id e) = CoreSubst.substExpr (text "mkCoreSubst" <+> doc) (mk_subst tv id) e + -- Don't shortcut here ------------------ substIdType :: SimplEnv -> Id -> Id @@ -712,12 +754,16 @@ substIdType (SimplEnv { seInScope = in_scope, seTvSubst = tv_env}) id old_ty = idType id ------------------ -substExpr :: SimplEnv -> CoreExpr -> CoreExpr -substExpr env expr = CoreSubst.substExpr (mkCoreSubst env) expr +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 CoreSubst: Note [Extending the Subst] + -- See Note [SimplEnv invariants] substUnfolding :: SimplEnv -> Unfolding -> Unfolding -substUnfolding env unf = CoreSubst.substUnfolding (mkCoreSubst env) unf +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}