\begin{code}
module SimplEnv (
- InId, InBind, InExpr, InAlt, InArg, InType, InBinder,
- OutId, OutTyVar, OutBind, OutExpr, OutAlt, OutArg, OutType, OutBinder,
+ InId, InBind, InExpr, InAlt, InArg, InType, InBndr,
+ OutId, OutTyVar, OutBind, OutExpr, OutAlt, OutArg, OutType, OutBndr,
+ InCoercion, OutCoercion,
-- The simplifier mode
setMode, getMode,
setEnclosingCC, getEnclosingCC,
-- Environments
- SimplEnv, mkSimplEnv, extendIdSubst, extendTvSubst,
+ SimplEnv(..), pprSimplEnv, -- Temp not abstract
+ mkSimplEnv, extendIdSubst, SimplEnv.extendTvSubst,
zapSubstEnv, setSubstEnv,
getInScope, setInScope, setInScopeSet, modifyInScope, addNewInScopeIds,
- getRules, refineSimplEnv,
+ getRules,
- SimplSR(..), mkContEx, substId,
+ SimplSR(..), mkContEx, substId, lookupRecBndr,
simplNonRecBndr, simplRecBndrs, simplLamBndr, simplLamBndrs,
simplBinder, simplBinders, addLetIdInfo,
- substExpr, substTy,
+ substExpr, substTy,
-- Floats
- FloatsWith, FloatsWithExpr,
- Floats, emptyFloats, isEmptyFloats, unitFloat, addFloats, flattenFloats,
- allLifted, wrapFloats, floatBinds,
- addAuxiliaryBind,
+ Floats, emptyFloats, isEmptyFloats, addNonRec, addFloats,
+ wrapFloats, floatBinds, setFloats, canFloat, zapFloats, addRecFloats,
+ getFloats
) where
#include "HsVersions.h"
import SimplMonad
-import Id ( Id, idType, idOccInfo, idUnfolding, setIdUnfolding )
-import IdInfo ( IdInfo, vanillaIdInfo, occInfo, setOccInfo, specInfo, setSpecInfo,
- arityInfo, setArityInfo, workerInfo, setWorkerInfo,
- unfoldingInfo, setUnfoldingInfo, isEmptySpecInfo,
- unknownArity, workerExists
- )
+import IdInfo
import CoreSyn
-import Unify ( TypeRefinement )
-import Rules ( RuleBase )
-import CoreUtils ( needsCaseBinding )
-import CostCentre ( CostCentreStack, subsumedCCS )
-import Var
+import Rules
+import CoreUtils
+import CoreFVs
+import CostCentre
+import Var
import VarEnv
-import VarSet ( isEmptyVarSet )
+import VarSet
import OrdList
-
+import Id
+import NewDemand
import qualified CoreSubst ( Subst, mkSubst, substExpr, substSpec, substWorker )
import qualified Type ( substTy, substTyVarBndr )
-
-import Type ( Type, TvSubst(..), TvSubstEnv, composeTvSubst,
- isUnLiftedType, seqType, tyVarsOfType )
-import BasicTypes ( OccInfo(..), isFragileOcc )
-import DynFlags ( SimplifierMode(..) )
-import Util ( mapAccumL )
+import Type hiding ( substTy, substTyVarBndr )
+import Coercion
+import BasicTypes
+import DynFlags
+import Util
+import UniqFM
import Outputable
\end{code}
%************************************************************************
\begin{code}
-type InBinder = CoreBndr
-type InId = Id -- Not yet cloned
-type InType = Type -- Ditto
-type InBind = CoreBind
-type InExpr = CoreExpr
-type InAlt = CoreAlt
-type InArg = CoreArg
-
-type OutBinder = CoreBndr
-type OutId = Id -- Cloned
-type OutTyVar = TyVar -- Cloned
-type OutType = Type -- Cloned
-type OutBind = CoreBind
-type OutExpr = CoreExpr
-type OutAlt = CoreAlt
-type OutArg = CoreArg
+type InBndr = CoreBndr
+type InId = Id -- Not yet cloned
+type InType = Type -- Ditto
+type InBind = CoreBind
+type InExpr = CoreExpr
+type InAlt = CoreAlt
+type InArg = CoreArg
+type InCoercion = Coercion
+
+type OutBndr = CoreBndr
+type OutId = Id -- Cloned
+type OutTyVar = TyVar -- Cloned
+type OutType = Type -- Cloned
+type OutCoercion = Coercion
+type OutBind = CoreBind
+type OutExpr = CoreExpr
+type OutAlt = CoreAlt
+type OutArg = CoreArg
\end{code}
%************************************************************************
-- 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,
+ -- See Note [Simplifier floats]
-- The current substitution
seTvSubst :: TvSubstEnv, -- InTyVar |--> OutType
seIdSubst :: SimplIdSubst -- InId |--> OutExpr
+
}
+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
- | DoneId OutId OccInfo -- Completed term variable, with occurrence info
+ | DoneId OutId -- Completed term variable
| 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
\end{code}
a77 -> a77
from the substitution, when we decide not to clone a77, but it's quite
legitimate to put the mapping in the substitution anyway.
-
- Indeed, we do so when we want to pass fragile OccInfo to the
- occurrences of the variable; we add a substitution
- x77 -> DoneId x77 occ
- to record x's occurrence information.]
Furthermore, consider
let x = case k of I# x77 -> ... in
Of course, the substitution *must* applied! Things in its domain
simply aren't necessarily bound in the result.
-* substId adds a binding (DoneId new_id occ) to the substitution if
- EITHER the Id's unique has changed
- OR the Id has interesting occurrence information
- So in effect you can only get to interesting occurrence information
- by looking up the *old* Id; it's not really attached to the new id
- at all.
+* substId adds a binding (DoneId new_id) to the substitution if
+ the Id's unique has changed
+
Note, though that the substitution isn't necessarily extended
if the type changes. Why not? Because of the next point:
That's why the "set" is actually a VarEnv Var
-Note [GADT type refinement]
-~~~~~~~~~~~~~~~~~~~~~~~~~~~
-When we come to a GADT pattern match that refines the in-scope types, we
- a) Refine the types of the Ids in the in-scope set, seInScope.
- For exmaple, consider
- data T a where
- Foo :: T (Bool -> Bool)
-
- (\ (x::T a) (y::a) -> case x of { Foo -> y True }
-
- Technically this is well-typed, but exprType will barf on the
- (y True) unless we refine the type on y's occurrence.
-
- b) Refine the range of the type substitution, seTvSubst.
- Very similar reason to (a).
-
- NB: we don't refine the range of the SimplIdSubst, because it's always
- interpreted relative to the seInScope (see substId)
-
-For (b) we need to be a little careful. Specifically, we compose the refinement
-with the type substitution. Suppose
- The substitution was [a->b, b->a]
- and the refinement was [b->Int]
- Then we want [a->Int, b->a]
-
-But also if
- The substitution was [a->b]
- and the refinement was [b->Int]
- Then we want [a->Int, b->Int]
- becuase b might be both an InTyVar and OutTyVar
-
-
\begin{code}
mkSimplEnv :: SimplifierMode -> SwitchChecker -> RuleBase -> SimplEnv
mkSimplEnv mode switches rules
= SimplEnv { seChkr = switches, seCC = subsumedCCS,
seMode = mode, seInScope = emptyInScopeSet,
- seExtRules = rules,
+ seExtRules = rules, seFloats = emptyFloats,
seTvSubst = emptyVarEnv, seIdSubst = emptyVarEnv }
-- The top level "enclosing CC" is "SUBSUMED".
setInScopeSet env in_scope = env {seInScope = in_scope}
setInScope :: SimplEnv -> SimplEnv -> SimplEnv
-setInScope env env_with_in_scope = setInScopeSet env (getInScope env_with_in_scope)
+-- Set the in-scope set, and *zap* the floats
+setInScope env env_with_scope
+ = env { seInScope = seInScope env_with_scope,
+ seFloats = emptyFloats }
+
+setFloats :: SimplEnv -> SimplEnv -> SimplEnv
+-- Set the in-scope set *and* the floats
+setFloats env env_with_floats
+ = env { seInScope = seInScope env_with_floats,
+ seFloats = seFloats env_with_floats }
addNewInScopeIds :: SimplEnv -> [CoreBndr] -> SimplEnv
-- The new Ids are guaranteed to be freshly allocated
getRules = seExtRules
\end{code}
- GADT stuff
-Given an idempotent substitution, generated by the unifier, use it to
-refine the environment
+
+%************************************************************************
+%* *
+\subsection{Floats}
+%* *
+%************************************************************************
+
+Note [Simplifier floats]
+~~~~~~~~~~~~~~~~~~~~~~~~~
+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# (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#)
\begin{code}
-refineSimplEnv :: SimplEnv -> TypeRefinement -> SimplEnv
--- The TvSubstEnv is the refinement, and it refines OutTyVars into OutTypes
-refineSimplEnv env@(SimplEnv { seTvSubst = tv_subst, seInScope = in_scope })
- (refine_tv_subst, all_bound_here)
- = env { seTvSubst = composeTvSubst in_scope refine_tv_subst tv_subst,
- seInScope = in_scope' }
+data Floats = Floats (OrdList OutBind) FloatFlag
+ -- See Note [Simplifier floats]
+
+data FloatFlag
+ = FltLifted -- All bindings are lifted and lazy
+ -- Hence ok to float to top level, or recursive
+
+ | FltOkSpec -- All bindings are FltLifted *or*
+ -- strict (perhaps because unlifted,
+ -- perhaps because of a strict binder),
+ -- *and* ok-for-speculation
+ -- Hence ok to float out of the RHS
+ -- of a lazy non-recursive let binding
+ -- (but not to top level, or into a rec group)
+
+ | FltCareful -- At least one binding is strict (or unlifted)
+ -- and not guaranteed cheap
+ -- Do not float these bindings out of a lazy let
+
+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")
+
+andFF :: FloatFlag -> FloatFlag -> FloatFlag
+andFF FltCareful _ = FltCareful
+andFF FltOkSpec FltCareful = FltCareful
+andFF FltOkSpec flt = FltOkSpec
+andFF FltLifted flt = flt
+
+classifyFF :: CoreBind -> FloatFlag
+classifyFF (Rec _) = FltLifted
+classifyFF (NonRec bndr rhs)
+ | 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
+\end{code}
+
+
+\begin{code}
+emptyFloats :: Floats
+emptyFloats = Floats nilOL FltLifted
+
+unitFloat :: OutBind -> Floats
+-- A single-binding float
+unitFloat bind = Floats (unitOL bind) (classifyFF bind)
+
+addNonRec :: SimplEnv -> OutId -> OutExpr -> SimplEnv
+-- Add a non-recursive binding and extend the in-scope set
+-- The latter is important; the binder may already be in the
+-- in-scope set (although it might also have been created with newId)
+-- but it may now have more IdInfo
+addNonRec env id rhs
+ = env { seFloats = seFloats env `addFlts` unitFloat (NonRec id rhs),
+ seInScope = extendInScopeSet (seInScope env) id }
+
+addFloats :: SimplEnv -> SimplEnv -> SimplEnv
+-- Add the floats for env2 to env1;
+-- *plus* the in-scope set for env2, which is bigger
+-- than that for env1
+addFloats env1 env2
+ = env1 {seFloats = seFloats env1 `addFlts` seFloats env2,
+ seInScope = seInScope env2 }
+
+addFlts :: Floats -> Floats -> Floats
+addFlts (Floats bs1 l1) (Floats bs2 l2)
+ = Floats (bs1 `appOL` bs2) (l1 `andFF` l2)
+
+zapFloats :: SimplEnv -> SimplEnv
+zapFloats env = env { seFloats = emptyFloats }
+
+addRecFloats :: SimplEnv -> SimplEnv -> SimplEnv
+-- Flattens the floats from env2 into a single Rec group,
+-- prepends the floats from env1, and puts the result back in env2
+-- 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) )
+ env2 {seFloats = seFloats env1 `addFlts` unitFloat (Rec (flattenBinds (fromOL bs)))}
+
+wrapFloats :: SimplEnv -> OutExpr -> OutExpr
+wrapFloats env expr = wrapFlts (seFloats env) expr
+
+wrapFlts :: Floats -> OutExpr -> OutExpr
+-- Wrap the floats around the expression, using case-binding where necessary
+wrapFlts (Floats bs _) body = foldrOL wrap body bs
where
- in_scope'
- | all_bound_here = in_scope
- -- The tvs are the tyvars bound here. If only they
- -- are refined, there's no need to do anything
- | otherwise = mapInScopeSet refine_id in_scope
-
- refine_id v -- Only refine its type; any rules will get
- -- refined if they are used (I hope)
- | isId v = setIdType v (Type.substTy refine_subst (idType v))
- | otherwise = v
- refine_subst = TvSubst in_scope refine_tv_subst
+ wrap (Rec prs) body = Let (Rec prs) body
+ wrap (NonRec b r) body = bindNonRec b r body
+
+getFloats :: SimplEnv -> [CoreBind]
+getFloats (SimplEnv {seFloats = Floats bs _}) = fromOL bs
+
+isEmptyFloats :: SimplEnv -> Bool
+isEmptyFloats env = isEmptyFlts (seFloats env)
+
+isEmptyFlts :: Floats -> Bool
+isEmptyFlts (Floats bs _) = isNilOL bs
+
+floatBinds :: Floats -> [OutBind]
+floatBinds (Floats bs _) = fromOL bs
\end{code}
+
%************************************************************************
%* *
Substitution of Vars
substId :: SimplEnv -> Id -> SimplSR
substId (SimplEnv { seInScope = in_scope, seIdSubst = ids }) v
| not (isLocalId v)
- = DoneId v NoOccInfo
+ = DoneId v
| otherwise -- A local Id
= case lookupVarEnv ids v of
- Just (DoneId v occ) -> DoneId (refine v) occ
- Just res -> res
- Nothing -> let v' = refine v
- in DoneId v' (idOccInfo v')
- -- We don't put LoopBreakers in the substitution (unless then need
- -- to be cloned for name-clash rasons), so the idOccInfo is
- -- very important! If isFragileOcc returned True for
- -- loop breakers we could avoid this call, but at the expense
- -- of adding more to the substitution, and building new Ids
- -- a bit more often than really necessary
+ Just (DoneId v) -> DoneId (refine in_scope v)
+ Just res -> res
+ Nothing -> DoneId (refine in_scope v)
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 a different type (we only use the
- -- substitution if the unique changes).
- refine v = case lookupInScope in_scope v of
- Just v' -> v'
- Nothing -> WARN( True, ppr v ) v -- This is an error!
+ -- the in-scope set with better IdInfo
+refine in_scope v = case lookupInScope in_scope v of
+ Just v' -> v'
+ Nothing -> WARN( True, ppr v ) v -- This is an error!
+
+lookupRecBndr :: SimplEnv -> Id -> Id
+-- Look up an Id which has been put into the envt by simplRecBndrs,
+-- but where we have not yet done its RHS
+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
\end{code}
\begin{code}
simplBinders, simplLamBndrs
- :: SimplEnv -> [InBinder] -> SimplM (SimplEnv, [OutBinder])
+ :: SimplEnv -> [InBndr] -> SimplM (SimplEnv, [OutBndr])
simplBinders env bndrs = mapAccumLSmpl simplBinder env bndrs
simplLamBndrs env bndrs = mapAccumLSmpl simplLamBndr env bndrs
-------------
-simplBinder :: SimplEnv -> InBinder -> SimplM (SimplEnv, OutBinder)
+simplBinder :: SimplEnv -> InBndr -> SimplM (SimplEnv, OutBndr)
-- Used for lambda and case-bound variables
-- Clone Id if necessary, substitute type
-- Return with IdInfo already substituted, but (fragile) occurrence info zapped
-- * 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
-- new_id has the final IdInfo
subst = mkCoreSubst env
- new_id = maybeModifyIdInfo (substIdInfo subst) id2
+ new_id = maybeModifyIdInfo (substIdInfo subst (idInfo old_id)) id2
-- 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 (idOccInfo old_id))
+ = extendVarEnv id_subst old_id (DoneId new_id)
| otherwise
= delVarEnv id_subst old_id
\end{code}
-
\begin{code}
+------------------------------------
seqTyVar :: TyVar -> ()
seqTyVar b = b `seq` ()
seqIds (id:ids) = seqId id `seq` seqIds ids
\end{code}
-
%************************************************************************
%* *
Let bindings
Rename the binders if necessary,
\begin{code}
-simplNonRecBndr :: SimplEnv -> InBinder -> SimplM (SimplEnv, OutBinder)
+simplNonRecBndr :: SimplEnv -> InBndr -> SimplM (SimplEnv, OutBndr)
simplNonRecBndr env id
= do { let (env1, id1) = substLetIdBndr env id
; seqId id1 `seq` return (env1, id1) }
---------------
-simplRecBndrs :: SimplEnv -> [InBinder] -> SimplM (SimplEnv, [OutBinder])
+simplRecBndrs :: SimplEnv -> [InBndr] -> SimplM SimplEnv
simplRecBndrs env@(SimplEnv { seInScope = in_scope, seIdSubst = id_subst }) ids
= do { let (env1, ids1) = mapAccumL substLetIdBndr env ids
- ; seqIds ids1 `seq` return (env1, ids1) }
+ ; seqIds ids1 `seq` return env1 }
---------------
-substLetIdBndr :: SimplEnv -> InBinder -- Env and binder to transform
- -> (SimplEnv, OutBinder)
--- C.f. CoreSubst.substIdBndr
+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
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
-- See the notes with substTyVarBndr for the delSubstEnv
- occ_info = occInfo (idInfo old_id)
- new_subst | new_id /= old_id || isFragileOcc occ_info
- = extendVarEnv id_subst old_id (DoneId new_id occ_info)
+ new_subst | new_id /= old_id
+ = extendVarEnv id_subst old_id (DoneId new_id)
| otherwise
= delVarEnv id_subst old_id
\end{code}
wanted a RULE for a recursive function to apply in that function's
own right-hand side.
-NB 2: We do not transfer the arity (see Subst.substIdInfo)
-The arity of an Id should not be visible
-in its own RHS, else we eta-reduce
+NB 2: ARITY. We *do* transfer the arity. This is important, so that
+the arity of an Id is visible in its own RHS. For example:
+ f = \x. ....g (\y. f y)....
+We can eta-reduce the arg to g, becuase f is a value. But that
+needs to be visible.
+
+This interacts with the 'state hack' too:
+ f :: Bool -> IO Int
+ f = \x. case x of
+ True -> f y
+ False -> \s -> ...
+Can we eta-expand f? Only if we see that f has arity 1, and then we
+take advantage of the 'state hack' on the result of
+(f y) :: State# -> (State#, Int) to expand the arity one more.
+
+There is a disadvantage though. Making the arity visible in the RHA
+allows us to eta-reduce
f = \x -> f x
to
f = f
-which isn't sound. And it makes the arity in f's IdInfo greater than
-the manifest arity, which isn't good.
-The arity will get added later.
+which technically is not sound. This is very much a corner case, so
+I'm not worried about it. Another idea is to ensure that f's arity
+never decreases; its arity started as 1, and we should never eta-reduce
+below that.
-NB 3: It's important that we *do* transer the loop-breaker OccInfo,
-because that's what stops the Id getting inlined infinitely, in the body
-of the letrec.
+NB 3: OccInfo. It's important that we *do* transer the loop-breaker
+OccInfo, because that's what stops the Id getting inlined infinitely,
+in the body of the letrec.
NB 4: does no harm for non-recursive bindings
when substituting in h's RULE.
\begin{code}
-addLetIdInfo :: SimplEnv -> InBinder -> OutBinder -> (SimplEnv, OutBinder)
+addLetIdInfo :: SimplEnv -> InBndr -> OutBndr -> (SimplEnv, OutBndr)
addLetIdInfo env in_id out_id
- = (modifyInScope env out_id out_id, final_id)
+ = (modifyInScope env out_id final_id, final_id)
where
final_id = out_id `setIdInfo` new_info
subst = mkCoreSubst env
-- worker info
-- Zap the unfolding
-- Keep only 'robust' OccInfo
--- Zap Arity
+-- arity
--
-- Seq'ing on the returned IdInfo is enough to cause all the
-- substitutions to happen completely
substIdInfo subst info
| nothing_to_do = Nothing
| otherwise = Just (info `setOccInfo` (if keep_occ then old_occ else NoOccInfo)
- `setArityInfo` (if keep_arity then old_arity else unknownArity)
`setSpecInfo` CoreSubst.substSpec subst old_rules
`setWorkerInfo` CoreSubst.substWorker subst old_wrkr
`setUnfoldingInfo` noUnfolding)
-- setSpecInfo does a seq
-- setWorkerInfo does a seq
where
- nothing_to_do = keep_occ && keep_arity &&
+ nothing_to_do = keep_occ &&
isEmptySpecInfo old_rules &&
not (workerExists old_wrkr) &&
not (hasUnfolding (unfoldingInfo info))
- keep_occ = not (isFragileOcc old_occ)
- keep_arity = old_arity == unknownArity
- old_arity = arityInfo info
+ keep_occ = not (isFragileOcc old_occ)
old_occ = occInfo info
old_rules = specInfo info
old_wrkr = workerInfo info
substIdType :: SimplEnv -> Id -> Id
substIdType env@(SimplEnv { seInScope = in_scope, seTvSubst = tv_env}) id
| isEmptyVarEnv tv_env || isEmptyVarSet (tyVarsOfType old_ty) = id
- | otherwise = setIdType id (Type.substTy (TvSubst in_scope tv_env) old_ty)
+ | 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
mk_subst tv_env id_env = CoreSubst.mkSubst in_scope tv_env (mapVarEnv fiddle id_env)
fiddle (DoneEx e) = e
- fiddle (DoneId v occ) = Var v
+ fiddle (DoneId v) = Var v
fiddle (ContEx tv id e) = CoreSubst.substExpr (mk_subst tv id) e
substExpr :: SimplEnv -> CoreExpr -> CoreExpr
| otherwise = CoreSubst.substExpr (mkCoreSubst env) expr
\end{code}
-
-%************************************************************************
-%* *
-\subsection{Floats}
-%* *
-%************************************************************************
-
-\begin{code}
-type FloatsWithExpr = FloatsWith OutExpr
-type FloatsWith a = (Floats, a)
- -- We return something equivalent to (let b in e), but
- -- in pieces to avoid the quadratic blowup when floating
- -- incrementally. Comments just before simplExprB in Simplify.lhs
-
-data Floats = Floats (OrdList OutBind)
- InScopeSet -- Environment "inside" all the floats
- Bool -- True <=> All bindings are lifted
-
-allLifted :: Floats -> Bool
-allLifted (Floats _ _ is_lifted) = is_lifted
-
-wrapFloats :: Floats -> OutExpr -> OutExpr
-wrapFloats (Floats bs _ _) body = foldrOL Let body bs
-
-isEmptyFloats :: Floats -> Bool
-isEmptyFloats (Floats bs _ _) = isNilOL bs
-
-floatBinds :: Floats -> [OutBind]
-floatBinds (Floats bs _ _) = fromOL bs
-
-flattenFloats :: Floats -> Floats
--- Flattens into a single Rec group
-flattenFloats (Floats bs is is_lifted)
- = ASSERT2( is_lifted, ppr (fromOL bs) )
- Floats (unitOL (Rec (flattenBinds (fromOL bs)))) is is_lifted
-\end{code}
-
-\begin{code}
-emptyFloats :: SimplEnv -> Floats
-emptyFloats env = Floats nilOL (getInScope env) True
-
-unitFloat :: SimplEnv -> OutId -> OutExpr -> Floats
--- A single non-rec float; extend the in-scope set
-unitFloat env var rhs = Floats (unitOL (NonRec var rhs))
- (extendInScopeSet (getInScope env) var)
- (not (isUnLiftedType (idType var)))
-
-addFloats :: SimplEnv -> Floats
- -> (SimplEnv -> SimplM (FloatsWith a))
- -> SimplM (FloatsWith a)
-addFloats env (Floats b1 is1 l1) thing_inside
- | isNilOL b1
- = thing_inside env
- | otherwise
- = thing_inside (setInScopeSet env is1) `thenSmpl` \ (Floats b2 is2 l2, res) ->
- returnSmpl (Floats (b1 `appOL` b2) is2 (l1 && l2), res)
-
-addLetBind :: OutBind -> Floats -> Floats
-addLetBind bind (Floats binds in_scope lifted)
- = Floats (bind `consOL` binds) in_scope (lifted && is_lifted_bind bind)
-
-is_lifted_bind (Rec _) = True
-is_lifted_bind (NonRec b r) = not (isUnLiftedType (idType b))
-
--- addAuxiliaryBind * takes already-simplified things (bndr and rhs)
--- * extends the in-scope env
--- * assumes it's a let-bindable thing
-addAuxiliaryBind :: SimplEnv -> OutBind
- -> (SimplEnv -> SimplM (FloatsWith a))
- -> SimplM (FloatsWith a)
- -- Extends the in-scope environment as well as wrapping the bindings
-addAuxiliaryBind env bind thing_inside
- = ASSERT( case bind of { NonRec b r -> not (needsCaseBinding (idType b) r) ; Rec _ -> True } )
- thing_inside (addNewInScopeIds env (bindersOf bind)) `thenSmpl` \ (floats, x) ->
- returnSmpl (addLetBind bind floats, x)
-\end{code}
-
-