X-Git-Url: http://git.megacz.com/?p=ghc-hetmet.git;a=blobdiff_plain;f=compiler%2FsimplCore%2FSimplEnv.lhs;h=10b000357479c0ea67638e50a3fb917fb447d5ed;hp=462a697da36dc4cfea89151a7ea32e0fe0f17c9c;hb=d2ce0f52d42edf32bb9f13796e6ba6edba8bd516;hpb=eb80228b1f96ae3a739ef06728713eeec02f4c3e diff --git a/compiler/simplCore/SimplEnv.lhs b/compiler/simplCore/SimplEnv.lhs index 462a697..10b0003 100644 --- a/compiler/simplCore/SimplEnv.lhs +++ b/compiler/simplCore/SimplEnv.lhs @@ -4,20 +4,13 @@ \section[SimplMonad]{The simplifier Monad} \begin{code} -{-# OPTIONS -w #-} --- The above warning supression flag is a temporary kludge. --- While working on this module you are encouraged to remove it and fix --- any warnings in the module. See --- http://hackage.haskell.org/trac/ghc/wiki/Commentary/CodingStyle#Warnings --- for details - 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, @@ -26,17 +19,17 @@ module SimplEnv ( 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, - getRules, + getSimplRules, inGentleMode, SimplSR(..), mkContEx, substId, lookupRecBndr, simplNonRecBndr, simplRecBndrs, simplLamBndr, simplLamBndrs, simplBinder, simplBinders, addBndrRules, - substExpr, substWorker, substTy, + substExpr, substTy, substTyVar, getTvSubst, mkCoreSubst, -- Floats Floats, emptyFloats, isEmptyFloats, addNonRec, addFloats, extendFloats, @@ -47,9 +40,9 @@ module SimplEnv ( #include "HsVersions.h" import SimplMonad +import CoreMonad ( SimplifierMode(..) ) import IdInfo import CoreSyn -import Rules import CoreUtils import CostCentre import Var @@ -57,15 +50,14 @@ import VarEnv 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 qualified CoreSubst +import qualified Type ( substTy, substTyVarBndr, substTyVar ) +import Type hiding ( substTy, substTyVarBndr, substTyVar ) import Coercion import BasicTypes -import DynFlags -import Util import MonadUtils import Outputable +import FastString import Data.List \end{code} @@ -78,6 +70,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 @@ -87,6 +80,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 @@ -107,28 +101,37 @@ 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) + -- 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) ] + = vcat [ptext (sLit "TvSubst:") <+> ppr (seTvSubst env), + ptext (sLit "IdSubst:") <+> ppr (seIdSubst env) ] type SimplIdSubst = IdEnv SimplSR -- IdId |--> OutExpr -- See Note [Extending the Subst] in CoreSubst @@ -141,9 +144,9 @@ data SimplSR 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 (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 (filter_env tv), ppr (filter_env id) -}] -- where -- fvs = exprFreeVars e @@ -214,8 +217,8 @@ seIdSubst: \begin{code} -mkSimplEnv :: SimplifierMode -> SwitchChecker -> SimplEnv -mkSimplEnv mode switches +mkSimplEnv :: SwitchChecker -> SimplifierMode -> SimplEnv +mkSimplEnv switches mode = SimplEnv { seChkr = switches, seCC = subsumedCCS, seMode = mode, seInScope = emptyInScopeSet, seFloats = emptyFloats, @@ -233,6 +236,14 @@ 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) } + +inGentleMode :: SimplEnv -> Bool +inGentleMode env = case seMode env of + SimplGently {} -> True + _other -> False + --------------------- getEnclosingCC :: SimplEnv -> CostCentreStack getEnclosingCC env = seCC env @@ -276,12 +287,15 @@ addNewInScopeIds env@(SimplEnv { seInScope = in_scope, seIdSubst = id_subst }) v -- Why delete? Consider -- let x = a*b in (x, \x -> x+3) -- We add [x |-> a*b] to the substitution, but we must - -- *delete* it from the substitution when going inside + -- _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 @@ -292,10 +306,6 @@ setSubstEnv env tvs ids = env { seTvSubst = tvs, 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 \end{code} @@ -344,14 +354,14 @@ instance Outputable Floats where ppr (Floats binds ff) = ppr ff $$ ppr (fromOL binds) instance Outputable FloatFlag where - ppr FltLifted = ptext SLIT("FltLifted") - ppr FltOkSpec = ptext SLIT("FltOkSpec") - ppr FltCareful = ptext SLIT("FltCareful") + ppr FltLifted = ptext (sLit "FltLifted") + ppr FltOkSpec = ptext (sLit "FltOkSpec") + ppr FltCareful = ptext (sLit "FltCareful") andFF :: FloatFlag -> FloatFlag -> FloatFlag andFF FltCareful _ = FltCareful andFF FltOkSpec FltCareful = FltCareful -andFF FltOkSpec flt = FltOkSpec +andFF FltOkSpec _ = FltOkSpec andFF FltLifted flt = flt classifyFF :: CoreBind -> FloatFlag @@ -365,7 +375,7 @@ doFloatFromRhs :: TopLevelFlag -> RecFlag -> Bool -> OutExpr -> SimplEnv -> Bool 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 @@ -390,15 +400,13 @@ addNonRec env id rhs = env { seFloats = seFloats env `addFlts` unitFloat (NonRec id rhs), seInScope = extendInScopeSet (seInScope env) id } -extendFloats :: SimplEnv -> [OutBind] -> SimplEnv +extendFloats :: SimplEnv -> OutBind -> SimplEnv -- Add these bindings to the floats, and extend the in-scope env too -extendFloats env binds - = env { seFloats = seFloats env `addFlts` new_floats, +extendFloats env bind + = env { seFloats = seFloats env `addFlts` unitFloat bind, seInScope = extendInScopeSetList (seInScope env) bndrs } where - bndrs = bindersOfBinds binds - new_floats = Floats (toOL binds) - (foldr (andFF . classifyFF) FltLifted binds) + bndrs = bindersOf bind addFloats :: SimplEnv -> SimplEnv -> SimplEnv -- Add the floats for env2 to env1; @@ -421,7 +429,7 @@ addRecFloats :: SimplEnv -> SimplEnv -> SimplEnv -- This is all very specific to the way recursive bindings are -- handled; see Simplify.simplRecBind addRecFloats env1 env2@(SimplEnv {seFloats = Floats bs ff}) - = ASSERT2( case ff of { FltLifted -> True; other -> False }, ppr (fromOL bs) ) + = ASSERT2( case ff of { FltLifted -> True; _ -> False }, ppr (fromOL bs) ) env2 {seFloats = seFloats env1 `addFlts` unitFloat (Rec (flattenBinds (fromOL bs)))} wrapFloats :: SimplEnv -> OutExpr -> OutExpr @@ -454,29 +462,37 @@ floatBinds (Floats bs _) = fromOL bs %* * %************************************************************************ +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 in_scope v = case lookupInScope in_scope v of +refine :: InScopeSet -> Var -> Var +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, @@ -484,8 +500,8 @@ lookupRecBndr :: SimplEnv -> InId -> OutId lookupRecBndr (SimplEnv { seInScope = in_scope, seIdSubst = ids }) v = case lookupVarEnv ids v of Just (DoneId v) -> v - Just res -> pprPanic "lookupRecBndr" (ppr v) - Nothing -> refine in_scope v + Just _ -> pprPanic "lookupRecBndr" (ppr v) + Nothing -> refine in_scope v \end{code} @@ -512,7 +528,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) } @@ -532,7 +548,7 @@ simplLamBndr env bndr 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) @@ -544,7 +560,7 @@ simplNonRecBndr env id --------------- simplRecBndrs :: SimplEnv -> [InBndr] -> SimplM SimplEnv -- Recursive let binders -simplRecBndrs env@(SimplEnv { seInScope = in_scope, seIdSubst = id_subst }) ids +simplRecBndrs env@(SimplEnv {}) ids = do { let (env1, ids1) = mapAccumL substIdBndr env ids ; seqIds ids1 `seq` return env1 } @@ -654,38 +670,15 @@ See Note [Loop breaking and RULES] in OccAnal. \begin{code} addBndrRules :: SimplEnv -> InBndr -> OutBndr -> (SimplEnv, OutBndr) --- Rules are added back in to to hte bin +-- 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 env@(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 env NoUnfolding = NoUnfolding -substUnfolding env (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 env NoWorker = NoWorker -substWorker env wkr_info = CoreSubst.substWorker (mkCoreSubst env) wkr_info \end{code} @@ -696,13 +689,19 @@ substWorker env wkr_info = CoreSubst.substWorker (mkCoreSubst env) wkr_info %************************************************************************ \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') @@ -711,19 +710,37 @@ 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 +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 :: SimplEnv -> CoreExpr -> CoreExpr -substExpr env expr - | isEmptySimplSubst env = expr - | otherwise = CoreSubst.substExpr (mkCoreSubst env) expr +------------------ +substExpr :: SDoc -> SimplEnv -> CoreExpr -> CoreExpr +substExpr doc env + = CoreSubst.substExprSC (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] + +substUnfolding :: SimplEnv -> Unfolding -> Unfolding +substUnfolding env unf = CoreSubst.substUnfoldingSC (mkCoreSubst (text "subst-unfolding") env) unf \end{code}