X-Git-Url: http://git.megacz.com/?a=blobdiff_plain;ds=sidebyside;f=compiler%2FsimplCore%2FSimplEnv.lhs;h=2fedf8755f3576ae4ce1ad5bcf8a1cd5eee6fd08;hb=940524aec90652b5ef81789c9a453c57c0e42cc9;hp=f9e048430b81c598661ea8c093fbfecc423f3e2c;hpb=7a327c1297615a9498e7117a0017b09ff2458d53;p=ghc-hetmet.git diff --git a/compiler/simplCore/SimplEnv.lhs b/compiler/simplCore/SimplEnv.lhs index f9e0484..2fedf87 100644 --- a/compiler/simplCore/SimplEnv.lhs +++ b/compiler/simplCore/SimplEnv.lhs @@ -9,8 +9,6 @@ module SimplEnv ( OutId, OutTyVar, OutBind, OutExpr, OutAlt, OutArg, OutType, OutBndr, InCoercion, OutCoercion, - isStrictBndr, - -- The simplifier mode setMode, getMode, @@ -21,7 +19,7 @@ module SimplEnv ( setEnclosingCC, getEnclosingCC, -- Environments - SimplEnv(..), -- Temp not abstract + SimplEnv(..), pprSimplEnv, -- Temp not abstract mkSimplEnv, extendIdSubst, SimplEnv.extendTvSubst, zapSubstEnv, setSubstEnv, getInScope, setInScope, setInScopeSet, modifyInScope, addNewInScopeIds, @@ -34,9 +32,9 @@ module SimplEnv ( substExpr, substTy, -- Floats - Floats, emptyFloats, isEmptyFloats, addNonRec, addFloats, - wrapFloats, floatBinds, setFloats, canFloat, zapFloats, addRecFloats, - getFloats + Floats, emptyFloats, isEmptyFloats, addNonRec, addFloats, extendFloats, + wrapFloats, floatBinds, setFloats, zapFloats, addRecFloats, + doFloatFromRhs, getFloats ) where #include "HsVersions.h" @@ -46,14 +44,12 @@ import IdInfo import CoreSyn import Rules import CoreUtils -import CoreFVs import CostCentre import Var import VarEnv import VarSet import OrdList import Id -import NewDemand import qualified CoreSubst ( Subst, mkSubst, substExpr, substSpec, substWorker ) import qualified Type ( substTy, substTyVarBndr ) import Type hiding ( substTy, substTyVarBndr ) @@ -61,7 +57,6 @@ import Coercion import BasicTypes import DynFlags import Util -import UniqFM import Outputable \end{code} @@ -92,13 +87,6 @@ type OutAlt = CoreAlt type OutArg = CoreArg \end{code} -\begin{code} -isStrictBndr :: Id -> Bool -isStrictBndr bndr - = ASSERT2( isId bndr, ppr bndr ) - isStrictDmd (idNewDemandInfo bndr) || isStrictType (idType bndr) -\end{code} - %************************************************************************ %* * \subsubsection{The @SimplEnv@ type} @@ -129,7 +117,14 @@ data SimplEnv } +pprSimplEnv :: SimplEnv -> SDoc +-- Used for debugging; selective +pprSimplEnv 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 data SimplSR = DoneEx OutExpr -- Completed term @@ -137,15 +132,16 @@ data SimplSR | ContEx TvSubstEnv -- A suspended substitution 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 (filter_env tv), ppr (filter_env id) -}] - where - fvs = exprFreeVars e - filter_env env = filterVarEnv_Directly keep env - keep uniq _ = uniq `elemUFM_Directly` fvs + -- where + -- fvs = exprFreeVars e + -- filter_env env = filterVarEnv_Directly keep env + -- keep uniq _ = uniq `elemUFM_Directly` fvs \end{code} @@ -313,11 +309,13 @@ The Floats is a bunch of bindings, classified by a FloatFlag. NonRec x (y:ys) FltLifted Rec [(x,rhs)] FltLifted - NonRec x# (y +# 3) FltOkSpec + + NonRec x# (y +# 3) FltOkSpec -- Unboxed, but ok-for-spec'n + NonRec x# (a /# b) FltCareful - NonRec x* (f y) FltCareful -- Might fail or diverge - NonRec x# (f y) FltCareful -- Might fail or diverge - (where f :: Int -> Int#) + NonRec x* (f y) FltCareful -- Strict binding; might fail or diverge + NonRec x# (f y) FltCareful -- Unboxed binding: might fail or diverge + -- (where f :: Int -> Int#) \begin{code} data Floats = Floats (OrdList OutBind) FloatFlag @@ -356,18 +354,19 @@ andFF FltLifted flt = flt classifyFF :: CoreBind -> FloatFlag classifyFF (Rec _) = FltLifted classifyFF (NonRec bndr rhs) - | not (isStrictBndr bndr) = FltLifted + | not (isStrictId bndr) = FltLifted | exprOkForSpeculation rhs = FltOkSpec | otherwise = FltCareful -canFloat :: TopLevelFlag -> RecFlag -> Bool -> SimplEnv -> Bool -canFloat lvl rec str (SimplEnv {seFloats = Floats _ ff}) - = canFloatFlt lvl rec str ff - -canFloatFlt :: TopLevelFlag -> RecFlag -> Bool -> FloatFlag -> Bool -canFloatFlt lvl rec str FltLifted = True -canFloatFlt lvl rec str FltOkSpec = isNotTopLevel lvl && isNonRec rec -canFloatFlt lvl rec str FltCareful = str && isNotTopLevel lvl && isNonRec rec +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 + can_float = case ff of + FltLifted -> True + FltOkSpec -> isNotTopLevel lvl && isNonRec rec + FltCareful -> isNotTopLevel lvl && isNonRec rec && str \end{code} @@ -388,6 +387,16 @@ addNonRec env id rhs = env { seFloats = seFloats env `addFlts` unitFloat (NonRec id rhs), seInScope = extendInScopeSet (seInScope env) id } +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, + seInScope = extendInScopeSetList (seInScope env) bndrs } + where + bndrs = bindersOfBinds binds + new_floats = Floats (toOL binds) + (foldr (andFF . classifyFF) FltLifted binds) + addFloats :: SimplEnv -> SimplEnv -> SimplEnv -- Add the floats for env2 to env1; -- *plus* the in-scope set for env2, which is bigger @@ -531,6 +540,8 @@ substIdBndr :: SimplEnv -> Id -- Substitition and Id to transform -- * The substitution extended with a DoneId if unique changed -- In this case, the var in the DoneId is the same as the -- var returned +-- +-- Exactly like CoreSubst.substIdBndr, except that the type of id_subst differs substIdBndr env@(SimplEnv { seInScope = in_scope, seIdSubst = id_subst}) old_id @@ -549,6 +560,7 @@ substIdBndr env@(SimplEnv { seInScope = in_scope, seIdSubst = id_subst}) -- Extend the substitution if the unique has changed -- See the notes with substTyVarBndr for the delSubstEnv + -- Also see Note [Extending the Subst] in CoreSubst new_subst | new_id /= old_id = extendVarEnv id_subst old_id (DoneId new_id) | otherwise @@ -597,8 +609,12 @@ substLetIdBndr :: SimplEnv -> InBndr -- Env and binder to transform -> (SimplEnv, OutBndr) -- C.f. substIdBndr above -- Clone Id if necessary, substitute its type --- Return an Id with completely zapped IdInfo +-- Return an Id with its fragile info zapped +-- namely, any info that depends on free variables -- [addLetIdInfo, below, will restore its IdInfo] +-- We want to retain robust info, especially arity and demand info, +-- so that they are available to occurrences that occur in an +-- earlier binding of a letrec -- Augment the subtitution -- if the unique changed, *or* -- if there's interesting occurrence info @@ -609,7 +625,10 @@ substLetIdBndr env@(SimplEnv { seInScope = in_scope, seIdSubst = id_subst }) old where id1 = uniqAway in_scope old_id id2 = substIdType env id1 - new_id = setIdInfo id2 vanillaIdInfo + + -- We want to get rid of any info that's dependent on free variables, + -- but keep other info (like the arity). + new_id = zapFragileIdInfo id2 -- Extend the substitution if the unique has changed, -- or there's some useful occurrence information