\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,
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"
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 )
import BasicTypes
import DynFlags
import Util
-import UniqFM
import Outputable
+
+import Data.List
\end{code}
%************************************************************************
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
\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".
isEmptySimplSubst :: SimplEnv -> Bool
isEmptySimplSubst (SimplEnv { seTvSubst = tvs, seIdSubst = ids })
= isEmptyVarEnv tvs && isEmptyVarEnv ids
-
----------------------
-getRules :: SimplEnv -> RuleBase
-getRules = seExtRules
\end{code}
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
| 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}
= 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
= 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