X-Git-Url: http://git.megacz.com/?a=blobdiff_plain;f=compiler%2FsimplCore%2FSimplEnv.lhs;h=12b3ce56ce377453d57d739699f62a81266f93ad;hb=d95ce839533391e7118257537044f01cbb1d6694;hp=1c3b8d8f60bbddee61475f97ac8a9bd19152bfae;hpb=5699ec476d64d48b7fcf6812238406e1eea91bef;p=ghc-hetmet.git diff --git a/compiler/simplCore/SimplEnv.lhs b/compiler/simplCore/SimplEnv.lhs index 1c3b8d8..12b3ce5 100644 --- a/compiler/simplCore/SimplEnv.lhs +++ b/compiler/simplCore/SimplEnv.lhs @@ -23,13 +23,13 @@ module SimplEnv ( mkSimplEnv, extendIdSubst, SimplEnv.extendTvSubst, zapSubstEnv, setSubstEnv, getInScope, setInScope, setInScopeSet, modifyInScope, addNewInScopeIds, - getRules, + getSimplRules, SimplSR(..), mkContEx, substId, lookupRecBndr, simplNonRecBndr, simplRecBndrs, simplLamBndr, simplLamBndrs, simplBinder, simplBinders, addBndrRules, - substExpr, substWorker, substTy, + substExpr, substTy, substUnfolding, -- Floats Floats, emptyFloats, isEmptyFloats, addNonRec, addFloats, extendFloats, @@ -49,7 +49,7 @@ import VarEnv import VarSet import OrdList import Id -import qualified CoreSubst ( Subst, mkSubst, substExpr, substSpec, substWorker ) +import qualified CoreSubst ( Subst, mkSubst, substExpr, substSpec, substUnfolding ) import qualified Type ( substTy, substTyVarBndr ) import Type hiding ( substTy, substTyVarBndr ) import Coercion @@ -268,12 +268,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 @@ -284,10 +287,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} @@ -444,20 +443,25 @@ 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 @@ -465,9 +469,11 @@ substId (SimplEnv { seInScope = in_scope, seIdSubst = ids }) v -- 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, @@ -522,8 +528,8 @@ simplLamBndr env bndr where old_unf = idUnfolding bndr (env1, id1) = substIdBndr env bndr - id2 = id1 `setIdUnfolding` substUnfolding env old_unf - env2 = modifyInScope env1 id1 id2 + id2 = id1 `setIdUnfolding` substUnfolding env False old_unf + env2 = modifyInScope env1 id2 --------------- simplNonRecBndr :: SimplEnv -> InBndr -> SimplM (SimplEnv, OutBndr) @@ -645,38 +651,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 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} @@ -712,9 +695,28 @@ mkCoreSubst (SimplEnv { seInScope = in_scope, seTvSubst = tv_env, seIdSubst = id fiddle (DoneId v) = Var v fiddle (ContEx tv id e) = CoreSubst.substExpr (mk_subst tv id) e +------------------ +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 env expr = CoreSubst.substExpr (mkCoreSubst env) expr + -- Do *not* short-cut in the case of an empty substitution + -- See CoreSubst: Note [Extending the Subst] + +substUnfolding :: SimplEnv -> Bool -> Unfolding -> Unfolding +substUnfolding env is_top_lvl unf + | InlineRule {} <- unf' = unf' { uf_is_top = is_top_lvl } + | otherwise = unf' + where + unf' = CoreSubst.substUnfolding (mkCoreSubst env) unf \end{code}