OutId, OutTyVar, OutBind, OutExpr, OutAlt, OutArg, OutType, OutBndr,
InCoercion, OutCoercion,
- isStrictBndr,
-
-- The simplifier mode
setMode, getMode,
setEnclosingCC, getEnclosingCC,
-- Environments
- SimplEnv(..), -- Temp not abstract
+ SimplEnv(..), pprSimplEnv, -- Temp not abstract
mkSimplEnv, extendIdSubst, SimplEnv.extendTvSubst,
zapSubstEnv, setSubstEnv,
getInScope, setInScope, setInScopeSet, modifyInScope, addNewInScopeIds,
SimplSR(..), mkContEx, substId, lookupRecBndr,
simplNonRecBndr, simplRecBndrs, simplLamBndr, simplLamBndrs,
- simplBinder, simplBinders, addLetIdInfo,
- substExpr, substTy,
+ simplBinder, simplBinders, addBndrRules,
+ substExpr, substWorker, 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 SimplMonad
+import SimplMonad
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 )
import Coercion
import BasicTypes
import DynFlags
-import Util
-import UniqFM
+import MonadUtils
import Outputable
+import FastString
+
+import Data.List
\end{code}
%************************************************************************
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}
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
}
+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
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 (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}
\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".
-- 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
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
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")
+ 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 FltOkSpec _ = FltOkSpec
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}
= 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 bind
+ = env { seFloats = seFloats env `addFlts` unitFloat bind,
+ seInScope = extendInScopeSetList (seInScope env) bndrs }
+ where
+ bndrs = bindersOf bind
+
addFloats :: SimplEnv -> SimplEnv -> SimplEnv
-- Add the floats for env2 to env1;
-- *plus* the in-scope set for env2, which is bigger
-- 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) )
+ = ASSERT2( case ff of { FltLifted -> True; _ -> False }, ppr (fromOL bs) )
env2 {seFloats = seFloats env1 `addFlts` unitFloat (Rec (flattenBinds (fromOL bs)))}
wrapFloats :: SimplEnv -> OutExpr -> OutExpr
\begin{code}
-substId :: SimplEnv -> Id -> SimplSR
+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
- Just (DoneId v) -> DoneId (refine in_scope v)
- Just res -> res
- Nothing -> DoneId (refine in_scope v)
+ 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 res -> res -- DoneEx non-var, or ContEx
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 better IdInfo
+refine :: InScopeSet -> Var -> Var
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
+lookupRecBndr :: SimplEnv -> InId -> OutId
-- 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
+ Just _ -> pprPanic "lookupRecBndr" (ppr v)
+ Nothing -> refine in_scope v
\end{code}
\begin{code}
simplBinders, simplLamBndrs
:: SimplEnv -> [InBndr] -> SimplM (SimplEnv, [OutBndr])
-simplBinders env bndrs = mapAccumLSmpl simplBinder env bndrs
-simplLamBndrs env bndrs = mapAccumLSmpl simplLamBndr env bndrs
+simplBinders env bndrs = mapAccumLM simplBinder env bndrs
+simplLamBndrs env bndrs = mapAccumLM simplLamBndr env bndrs
-------------
simplBinder :: SimplEnv -> InBndr -> SimplM (SimplEnv, OutBndr)
-------------
simplLamBndr :: SimplEnv -> Var -> SimplM (SimplEnv, Var)
-- Used for lambda binders. These sometimes have unfoldings added by
--- the worker/wrapper pass that must be preserved, becuase they can't
+-- the worker/wrapper pass that must be preserved, because they can't
-- be reconstructed from context. For example:
-- f x = case x of (a,b) -> fw a b x
-- fw a b x{=(a,b)} = ...
-- The "{=(a,b)}" is an unfolding we can't reconstruct otherwise.
simplLamBndr env bndr
- | not (isId bndr && hasSomeUnfolding old_unf) = simplBinder env bndr -- Normal case
- | otherwise = seqId id2 `seq` return (env', id2)
+ | isId bndr && hasSomeUnfolding old_unf = seqId id2 `seq` return (env2, id2) -- Special case
+ | otherwise = simplBinder env bndr -- Normal case
where
old_unf = idUnfolding bndr
- (env', id1) = substIdBndr env bndr
- id2 = id1 `setIdUnfolding` substUnfolding env old_unf
+ (env1, id1) = substIdBndr env bndr
+ id2 = id1 `setIdUnfolding` substUnfolding env old_unf
+ env2 = modifyInScope env1 id1 id2
+
+---------------
+simplNonRecBndr :: SimplEnv -> InBndr -> SimplM (SimplEnv, OutBndr)
+-- A non-recursive let binder
+simplNonRecBndr env id
+ = do { let (env1, id1) = substIdBndr env id
+ ; seqId id1 `seq` return (env1, id1) }
---------------
-substIdBndr :: SimplEnv -> Id -- Substitition and Id to transform
- -> (SimplEnv, Id) -- Transformed pair
+---------------
+simplRecBndrs :: SimplEnv -> [InBndr] -> SimplM SimplEnv
+-- Recursive let binders
+simplRecBndrs env@(SimplEnv {}) ids
+ = do { let (env1, ids1) = mapAccumL substIdBndr env ids
+ ; seqIds ids1 `seq` return env1 }
--- Returns with:
--- * Unique changed if necessary
+---------------
+substIdBndr :: SimplEnv
+ -> InBndr -- Env and binder to transform
+ -> (SimplEnv, OutBndr)
+-- Clone Id if necessary, substitute its type
+-- Return an Id with its
-- * Type substituted
--- * Unfolding zapped
--- * Rules, worker, lbvar info all substituted
--- * Fragile occurrence info zapped
--- * The in-scope set extended with the returned Id
--- * The substitution extended with a DoneId if unique changed
--- In this case, the var in the DoneId is the same as the
--- var returned
+-- * UnfoldingInfo, Rules, WorkerInfo zapped
+-- * Fragile OccInfo (only) zapped: Note [Robust OccInfo]
+-- * Robust info, retained especially arity and demand info,
+-- so that they are available to occurrences that occur in an
+-- earlier binding of a letrec
+--
+-- For the robust info, see Note [Arity robustness]
+--
+-- Augment the substitution if the unique changed
+-- Extend the in-scope set with the new Id
--
--- Exactly like CoreSubst.substIdBndr, except that the type of id_subst differs
+-- Similar to CoreSubst.substIdBndr, except that
+-- the type of id_subst differs
+-- all fragile info is zapped
-substIdBndr env@(SimplEnv { seInScope = in_scope, seIdSubst = id_subst})
- old_id
- = (env { seInScope = in_scope `extendInScopeSet` new_id,
+substIdBndr env@(SimplEnv { seInScope = in_scope, seIdSubst = id_subst })
+ old_id
+ = (env { seInScope = in_scope `extendInScopeSet` new_id,
seIdSubst = new_subst }, new_id)
where
- -- id1 is cloned if necessary
- id1 = uniqAway in_scope old_id
-
- -- id2 has its type zapped
- id2 = substIdType env id1
-
- -- new_id has the final IdInfo
- subst = mkCoreSubst env
- new_id = maybeModifyIdInfo (substIdInfo subst (idInfo old_id)) id2
+ id1 = uniqAway in_scope old_id
+ id2 = substIdType env id1
+ new_id = zapFragileIdInfo id2 -- Zaps rules, worker-info, unfolding
+ -- and fragile OccInfo
- -- Extend the substitution if the unique has changed
+ -- Extend the substitution if the unique has changed,
+ -- or there's some useful occurrence information
-- 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
seqIds (id:ids) = seqId id `seq` seqIds ids
\end{code}
-%************************************************************************
-%* *
- Let bindings
-%* *
-%************************************************************************
-Simplifying let binders
+Note [Arity robustness]
~~~~~~~~~~~~~~~~~~~~~~~
-Rename the binders if necessary,
-
-\begin{code}
-simplNonRecBndr :: SimplEnv -> InBndr -> SimplM (SimplEnv, OutBndr)
-simplNonRecBndr env id
- = do { let (env1, id1) = substLetIdBndr env id
- ; seqId id1 `seq` return (env1, id1) }
-
----------------
-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 }
-
----------------
-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
--- [addLetIdInfo, below, will restore its IdInfo]
--- 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
- = (env { seInScope = in_scope `extendInScopeSet` new_id,
- seIdSubst = new_subst }, new_id)
- where
- id1 = uniqAway in_scope old_id
- id2 = substIdType env id1
- new_id = setIdInfo id2 vanillaIdInfo
-
- -- Extend the substitution if the unique has changed,
- -- or there's some useful occurrence information
- -- See the notes with substTyVarBndr for the delSubstEnv
- new_subst | new_id /= old_id
- = extendVarEnv id_subst old_id (DoneId new_id)
- | otherwise
- = delVarEnv id_subst old_id
-\end{code}
-
-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
- rules
- worker info
-etc. To do this we must apply the current substitution,
-which incorporates earlier substitutions in this very letrec group.
-
-NB 1. We do this *before* processing the RHS of the binder, so that
-its substituted rules are visible in its own RHS.
-This is important. Manuel found cases where he really, really
-wanted a RULE for a recursive function to apply in that function's
-own right-hand side.
-
-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:
+We *do* transfer the arity from from the in_id of a let binding to the
+out_id. 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.
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
+There is a disadvantage though. Making the arity visible in the RHS
allows us to eta-reduce
f = \x -> f x
to
never decreases; its arity started as 1, and we should never eta-reduce
below that.
-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
+Note [Robust OccInfo]
+~~~~~~~~~~~~~~~~~~~~~
+It's important that we *do* retain the loop-breaker OccInfo, because
+that's what stops the Id getting inlined infinitely, in the body of
+the letrec.
+
+
+Note [Rules in a letrec]
+~~~~~~~~~~~~~~~~~~~~~~~~
+After creating fresh binders for the binders of a letrec, we
+substitute the RULES and add them back onto the binders; this is done
+*before* processing any of the RHSs. This is important. Manuel found
+cases where he really, really wanted a RULE for a recursive function
+to apply in that function's own right-hand side.
+
+See Note [Loop breaking and RULES] in OccAnal.
-NB 5: we can't do the addLetIdInfo part before *all* the RHSs because
- rec { f = g
- h = ...
- RULE h Int = f
- }
-Here, we'll do postInlineUnconditionally on f, and we must "see" that
-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)
- 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
--- rules
--- worker info
--- Zap the unfolding
--- Keep only 'robust' OccInfo
--- 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)
- `setSpecInfo` CoreSubst.substSpec subst old_rules
- `setWorkerInfo` CoreSubst.substWorker subst old_wrkr
- `setUnfoldingInfo` noUnfolding)
- -- setSpecInfo does a seq
- -- setWorkerInfo does a seq
+addBndrRules :: SimplEnv -> InBndr -> OutBndr -> (SimplEnv, OutBndr)
+-- 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)
where
- nothing_to_do = keep_occ &&
- isEmptySpecInfo old_rules &&
- not (workerExists old_wrkr) &&
- not (hasUnfolding (unfoldingInfo info))
-
- keep_occ = not (isFragileOcc old_occ)
- old_occ = occInfo info
- old_rules = specInfo info
- old_wrkr = workerInfo info
+ 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 env@(SimplEnv { seInScope = in_scope, seTvSubst = tv_env}) 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
old_ty = idType id
------------------
-substUnfolding env NoUnfolding = NoUnfolding
-substUnfolding env (OtherCon cons) = OtherCon cons
+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}