X-Git-Url: http://git.megacz.com/?a=blobdiff_plain;f=compiler%2FsimplCore%2FSimplEnv.lhs;h=d1fd65f2a2e94f153a2e00e2bc4a191d104c6f71;hb=ebd091d5cd703b249838baaa125e6c0fa0fe0e45;hp=245f313e8f874b4f59f60e26f2dd5ca2a26ba5cc;hpb=dbcff8ab57f64bcc6abff68448fc33691410266e;p=ghc-hetmet.git diff --git a/compiler/simplCore/SimplEnv.lhs b/compiler/simplCore/SimplEnv.lhs index 245f313..d1fd65f 100644 --- a/compiler/simplCore/SimplEnv.lhs +++ b/compiler/simplCore/SimplEnv.lhs @@ -4,13 +4,18 @@ \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, InCoercion, OutCoercion, - isStrictBndr, - -- The simplifier mode setMode, getMode, @@ -34,9 +39,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 +51,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,8 +64,9 @@ import Coercion import BasicTypes import DynFlags import Util -import UniqFM import Outputable + +import Data.List \end{code} %************************************************************************ @@ -92,13 +96,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} @@ -113,9 +110,6 @@ data SimplEnv seChkr :: SwitchChecker, seCC :: CostCentreStack, -- The enclosing CCS (when profiling) - -- Rules from other modules - seExtRules :: RuleBase, - -- The current set of in-scope variables -- They are all OutVars, and all bound in this module seInScope :: InScopeSet, -- OutVars only @@ -219,11 +213,11 @@ seIdSubst: \begin{code} -mkSimplEnv :: SimplifierMode -> SwitchChecker -> RuleBase -> SimplEnv -mkSimplEnv mode switches rules +mkSimplEnv :: SimplifierMode -> SwitchChecker -> SimplEnv +mkSimplEnv mode switches = SimplEnv { seChkr = switches, seCC = subsumedCCS, seMode = mode, seInScope = emptyInScopeSet, - seExtRules = rules, seFloats = emptyFloats, + seFloats = emptyFloats, seTvSubst = emptyVarEnv, seIdSubst = emptyVarEnv } -- The top level "enclosing CC" is "SUBSUMED". @@ -301,10 +295,6 @@ mkContEx (SimplEnv { seTvSubst = tvs, seIdSubst = ids }) e = ContEx tvs ids e isEmptySimplSubst :: SimplEnv -> Bool isEmptySimplSubst (SimplEnv { seTvSubst = tvs, seIdSubst = ids }) = isEmptyVarEnv tvs && isEmptyVarEnv ids - ---------------------- -getRules :: SimplEnv -> RuleBase -getRules = seExtRules \end{code} @@ -321,11 +311,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 @@ -364,18 +356,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} @@ -396,6 +389,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 @@ -604,29 +607,26 @@ simplRecBndrs env@(SimplEnv { seInScope = in_scope, seIdSubst = id_subst }) ids ; seqIds ids1 `seq` return env1 } --------------- -substLetIdBndr :: SimplEnv -> InBndr -- Env and binder to transform +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 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 - -substLetIdBndr env@(SimplEnv { seInScope = in_scope, seIdSubst = id_subst }) old_id +-- Return an Id with its +-- UnfoldingInfo zapped +-- Rules, etc, substitutd with rec_subst +-- Robust info, retained 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 + +substLetIdBndr env@(SimplEnv { seInScope = in_scope, seIdSubst = id_subst }) + old_id = (env { seInScope = in_scope `extendInScopeSet` new_id, seIdSubst = new_subst }, new_id) where id1 = uniqAway in_scope old_id id2 = substIdType env id1 - - -- 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, @@ -638,8 +638,8 @@ substLetIdBndr env@(SimplEnv { seInScope = in_scope, seIdSubst = id_subst }) old = delVarEnv id_subst old_id \end{code} -Add IdInfo back onto a let-bound Id -~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~ +Note [Add IdInfo back onto a let-bound Id] +~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~ We must transfer the IdInfo of the original binder to the new binder. This is crucial, to preserve strictness @@ -696,14 +696,13 @@ when substituting in h's RULE. \begin{code} addLetIdInfo :: SimplEnv -> InBndr -> OutBndr -> (SimplEnv, OutBndr) addLetIdInfo env in_id out_id - = (modifyInScope env out_id final_id, final_id) + = case substIdInfo subst (idInfo in_id) of + Nothing -> (env, out_id) + Just new_info -> (modifyInScope env out_id final_id, final_id) + where + final_id = out_id `setIdInfo` new_info where - final_id = out_id `setIdInfo` new_info subst = mkCoreSubst env - old_info = idInfo in_id - new_info = case substIdInfo subst old_info of - Nothing -> old_info - Just new_info -> new_info substIdInfo :: CoreSubst.Subst -> IdInfo -> Maybe IdInfo -- Substitute the