Commit 33452dfc authored by Simon Peyton Jones's avatar Simon Peyton Jones
Browse files

Refactor the Mighty Simplifier

Triggered by #12150, and the knock-on effects of join points, I did a
major refactoring of the Simplifier.  This is a big patch that change
a lot of Simplify.hs: I did a lot of other re-organisation.

The main event
~~~~~~~~~~~~~~
Since the dawn of time we have had
  simplExpr :: SimplEnv -> InExpr -> SimplCont
            -> SimplM (SimplEnv, OutExpr)

What's that SimplEnv in the result?  When simplifying an expression the
simplifier add floated let-bindings to the SimplEnv, extending the
in-scope set appropriately, and hence needs to resturn the SimplEnv at
the end.  The mode, flags, substitution in the returned SimplEnv were
all irrelevant: it was just the floating bindings.

It's strange to accumulate part of the /result/ in the /environment/
argument!  And indeed its leads to all manner of mysterious calls to
zapFloats and transferring of floats from one SimplEnv to another.
It got worse with join points, so I finally bit the bullet and refactored.
Now we have
  simplExpr :: SimplEnv -> InExpr -> SimplCont
            -> SimplM (SimplFloats, OutExpr)
  -- See Note [The big picture]
and the SimplEnv no longer has floats in it.  The code is no shorter,
but it /is/ easier to understand.

Main changes

* Remove seLetFloats field from SimplEnv

* Define new data type SimplFloats, and functions over it

* Change the types of simplExpr, simplBind, and their many variants,
  to follow the above plan

Bottoming bindings
~~~~~~~~~~~~~~~~~~
I made one other significant change in SimplUtils (not just refactoring),
related to Trac #12150 comment:16.  Given
  x = <rhs>
where <rhs> turns out to be a bottoming expression, propagate that
information to x's IdInfo immediately.  That's always good, because
it makes x be inlined less (we don't inline bottoming things), and
it allows (case x of ...) to drop the dead alterantives immediately.
Moreover, we are doing the analysis anyway, in tryEtaExpandRhs, which
calls CoreArity.findRhsArity, which already does simple bottom analysis.
So we are generating the information; all we need do is to atach the
bottoming info to the IdInfo.

See Note [Bottoming bindings]

Smaller refactoring
~~~~~~~~~~~~~~~~~~~
* Rename SimplifierMode to SimplMode
* Put DynFlags as a new field in SimplMode, to make fewer
  monadic calls to getDynFlags.
* Move the code in addPolyBind into abstractFloats
* Move the "don't eta-expand join points" into tryEtaExpandRhs
parent 407c11b8
......@@ -521,61 +521,60 @@ mk_cheap_fn dflags cheap_app
----------------------
findRhsArity :: DynFlags -> Id -> CoreExpr -> Arity -> Arity
findRhsArity :: DynFlags -> Id -> CoreExpr -> Arity -> (Arity, Bool)
-- This implements the fixpoint loop for arity analysis
-- See Note [Arity analysis]
-- If findRhsArity e = (n, is_bot) then
-- (a) any application of e to <n arguments will not do much work,
-- so it is safe to expand e ==> (\x1..xn. e x1 .. xn)
-- (b) if is_bot=True, then e applied to n args is guaranteed bottom
findRhsArity dflags bndr rhs old_arity
= go (rhsEtaExpandArity dflags init_cheap_app rhs)
= go (get_arity init_cheap_app)
-- We always call exprEtaExpandArity once, but usually
-- that produces a result equal to old_arity, and then
-- we stop right away (since arities should not decrease)
-- Result: the common case is that there is just one iteration
where
is_lam = has_lam rhs
has_lam (Tick _ e) = has_lam e
has_lam (Lam b e) = isId b || has_lam e
has_lam _ = False
init_cheap_app :: CheapAppFun
init_cheap_app fn n_val_args
| fn == bndr = True -- On the first pass, this binder gets infinite arity
| otherwise = isCheapApp fn n_val_args
go :: Arity -> Arity
go cur_arity
| cur_arity <= old_arity = cur_arity
| new_arity == cur_arity = cur_arity
go :: (Arity, Bool) -> (Arity, Bool)
go cur_info@(cur_arity, _)
| cur_arity <= old_arity = cur_info
| new_arity == cur_arity = cur_info
| otherwise = ASSERT( new_arity < cur_arity )
#if defined(DEBUG)
pprTrace "Exciting arity"
(vcat [ ppr bndr <+> ppr cur_arity <+> ppr new_arity
, ppr rhs])
, ppr rhs])
#endif
go new_arity
go new_info
where
new_arity = rhsEtaExpandArity dflags cheap_app rhs
new_info@(new_arity, _) = get_arity cheap_app
cheap_app :: CheapAppFun
cheap_app fn n_val_args
| fn == bndr = n_val_args < cur_arity
| otherwise = isCheapApp fn n_val_args
-- ^ The Arity returned is the number of value args the
-- expression can be applied to without doing much work
rhsEtaExpandArity :: DynFlags -> CheapAppFun -> CoreExpr -> Arity
-- exprEtaExpandArity is used when eta expanding
-- e ==> \xy -> e x y
rhsEtaExpandArity dflags cheap_app e
= case (arityType env e) of
ATop (os:oss)
| isOneShotInfo os || has_lam e -> 1 + length oss
-- Don't expand PAPs/thunks
-- Note [Eta expanding thunks]
| otherwise -> 0
ATop [] -> 0
ABot n -> n
where
env = AE { ae_cheap_fn = mk_cheap_fn dflags cheap_app
, ae_ped_bot = gopt Opt_PedanticBottoms dflags }
has_lam (Tick _ e) = has_lam e
has_lam (Lam b e) = isId b || has_lam e
has_lam _ = False
get_arity :: CheapAppFun -> (Arity, Bool)
get_arity cheap_app
= case (arityType env rhs) of
ABot n -> (n, True)
ATop (os:oss) | isOneShotInfo os || is_lam
-> (1 + length oss, False) -- Don't expand PAPs/thunks
ATop _ -> (0, False) -- Note [Eta expanding thunks]
where
env = AE { ae_cheap_fn = mk_cheap_fn dflags cheap_app
, ae_ped_bot = gopt Opt_PedanticBottoms dflags }
{-
Note [Arity analysis]
......
......@@ -9,7 +9,7 @@
module CoreMonad (
-- * Configuration of the core-to-core passes
CoreToDo(..), runWhen, runMaybe,
SimplifierMode(..),
SimplMode(..),
FloatOutSwitches(..),
pprPassDetails,
......@@ -107,7 +107,7 @@ data CoreToDo -- These are diff core-to-core passes,
= CoreDoSimplify -- The core-to-core simplifier.
Int -- Max iterations
SimplifierMode
SimplMode
| CoreDoPluginPass String PluginPass
| CoreDoFloatInwards
| CoreDoFloatOutwards FloatOutSwitches
......@@ -163,17 +163,19 @@ pprPassDetails (CoreDoSimplify n md) = vcat [ text "Max iterations =" <+> int n
, ppr md ]
pprPassDetails _ = Outputable.empty
data SimplifierMode -- See comments in SimplMonad
data SimplMode -- See comments in SimplMonad
= SimplMode
{ sm_names :: [String] -- Name(s) of the phase
, sm_phase :: CompilerPhase
, sm_dflags :: DynFlags -- Just for convenient non-monadic
-- access; we don't override these
, sm_rules :: Bool -- Whether RULES are enabled
, sm_inline :: Bool -- Whether inlining is enabled
, sm_case_case :: Bool -- Whether case-of-case is enabled
, sm_eta_expand :: Bool -- Whether eta-expansion is enabled
}
instance Outputable SimplifierMode where
instance Outputable SimplMode where
ppr (SimplMode { sm_phase = p, sm_names = ss
, sm_rules = r, sm_inline = i
, sm_eta_expand = eta, sm_case_case = cc })
......
......@@ -142,6 +142,7 @@ getCoreToDo dflags
base_mode = SimplMode { sm_phase = panic "base_mode"
, sm_names = []
, sm_dflags = dflags
, sm_rules = rules_on
, sm_eta_expand = eta_expand_on
, sm_inline = True
......@@ -619,7 +620,7 @@ simplExprGently :: SimplEnv -> CoreExpr -> SimplM CoreExpr
-- (b) the LHS and RHS of a RULE
-- (c) Template Haskell splices
--
-- The name 'Gently' suggests that the SimplifierMode is SimplGently,
-- The name 'Gently' suggests that the SimplMode is SimplGently,
-- and in fact that is so.... but the 'Gently' in simplExprGently doesn't
-- enforce that; it just simplifies the expression twice
......@@ -754,8 +755,8 @@ simplifyPgmIO pass@(CoreDoSimplify max_iterations mode)
-- Simplify the program
((binds1, rules1), counts1) <-
initSmpl dflags (mkRuleEnv rule_base2 vis_orphs) fam_envs us1 sz $
do { env1 <- {-# SCC "SimplTopBinds" #-}
simplTopBinds simpl_env tagged_binds
do { (floats, env1) <- {-# SCC "SimplTopBinds" #-}
simplTopBinds simpl_env tagged_binds
-- Apply the substitution to rules defined in this module
-- for imported Ids. Eg RULE map my_f = blah
......@@ -763,7 +764,7 @@ simplifyPgmIO pass@(CoreDoSimplify max_iterations mode)
-- apply it to the rule to, or it'll never match
; rules1 <- simplRules env1 Nothing rules
; return (getFloatBinds env1, rules1) } ;
; return (getTopFloatBinds floats, rules1) } ;
-- Stop if nothing happened; don't dump output
if isZeroSimplCount counts1 then
......
......@@ -8,14 +8,14 @@
module SimplEnv (
-- * The simplifier mode
setMode, getMode, updMode,
setMode, getMode, updMode, seDynFlags,
-- * Environments
SimplEnv(..), StaticEnv, pprSimplEnv, -- Temp not abstract
mkSimplEnv, extendIdSubst,
SimplEnv.extendTvSubst, SimplEnv.extendCvSubst,
zapSubstEnv, setSubstEnv,
getInScope, setInScopeAndZapFloats,
getInScope, setInScopeFromE, setInScopeFromF,
setInScopeSet, modifyInScope, addNewInScopeIds,
getSimplRules,
......@@ -29,19 +29,24 @@ module SimplEnv (
substCo, substCoVar,
-- * Floats
Floats, emptyFloats, isEmptyFloats,
addNonRec, addLetFloats, addFloats, extendFloats, addFlts,
wrapFloats, setFloats, zapFloats, addRecFloats, mapFloats,
doFloatFromRhs, getFloatBinds,
JoinFloat, JoinFloats, emptyJoinFloats, isEmptyJoinFloats,
wrapJoinFloats, wrapJoinFloatsX, zapJoinFloats, addJoinFloats
SimplFloats(..), emptyFloats, mkRecFloats,
mkFloatBind, addLetFloats, addJoinFloats, addFloats,
extendFloats, wrapFloats,
doFloatFromRhs, getTopFloatBinds,
-- * LetFloats
LetFloats, letFloatBinds, emptyLetFloats, unitLetFloat,
addLetFlts, mapLetFloats,
-- * JoinFloats
JoinFloat, JoinFloats, emptyJoinFloats,
wrapJoinFloats, wrapJoinFloatsX, unitJoinFloat, addJoinFlts
) where
#include "HsVersions.h"
import SimplMonad
import CoreMonad ( SimplifierMode(..) )
import CoreMonad ( SimplMode(..) )
import CoreSyn
import CoreUtils
import Var
......@@ -50,6 +55,7 @@ import VarSet
import OrdList
import Id
import MkCore ( mkWildValBinder )
import DynFlags ( DynFlags )
import TysWiredIn
import qualified Type
import Type hiding ( substTy, substTyVar, substTyVarBndr )
......@@ -77,12 +83,12 @@ data SimplEnv
-- Static in the sense of lexically scoped,
-- wrt the original expression
seMode :: SimplifierMode,
seMode :: SimplMode
-- The current substitution
seTvSubst :: TvSubstEnv, -- InTyVar |--> OutType
seCvSubst :: CvSubstEnv, -- InCoVar |--> OutCoercion
seIdSubst :: SimplIdSubst, -- InId |--> OutExpr
, seTvSubst :: TvSubstEnv -- InTyVar |--> OutType
, seCvSubst :: CvSubstEnv -- InCoVar |--> OutCoercion
, seIdSubst :: SimplIdSubst -- InId |--> OutExpr
----------- Dynamic part of the environment -----------
-- Dynamic in the sense of describing the setup where
......@@ -90,23 +96,42 @@ data SimplEnv
-- 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 seLetFloats and seJoinFloats
, seInScope :: InScopeSet -- OutVars only
}
-- Ordinary bindings
seLetFloats :: Floats,
-- See Note [Simplifier floats]
type StaticEnv = SimplEnv -- Just the static part is relevant
data SimplFloats
= SimplFloats
{ -- Ordinary let bindings
sfLetFloats :: LetFloats
-- See Note [LetFloats]
-- Join points
seJoinFloats :: JoinFloats
, sfJoinFloats :: JoinFloats
-- Handled separately; they don't go very far
-- We consider these to be /inside/ seLetFloats
-- We consider these to be /inside/ sfLetFloats
-- because join points can refer to ordinary bindings,
-- but not vice versa
}
type StaticEnv = SimplEnv -- Just the static part is relevant
-- Includes all variables bound by sfLetFloats and
-- sfJoinFloats, plus at least whatever is in scope where
-- these bindings land up.
, sfInScope :: InScopeSet -- All OutVars
}
instance Outputable SimplFloats where
ppr (SimplFloats { sfLetFloats = lf, sfJoinFloats = jf, sfInScope = is })
= text "SimplFloats"
<+> braces (vcat [ text "lets: " <+> ppr lf
, text "joins:" <+> ppr jf
, text "in_scope:" <+> ppr is ])
emptyFloats :: SimplEnv -> SimplFloats
emptyFloats env
= SimplFloats { sfLetFloats = emptyLetFloats
, sfJoinFloats = emptyJoinFloats
, sfInScope = seInScope env }
pprSimplEnv :: SimplEnv -> SDoc
-- Used for debugging; selective
......@@ -241,12 +266,10 @@ need to know at the occurrence site that the variable is a join point
so that we know to drop the context. Thus we remember which join
points we're substituting. -}
mkSimplEnv :: SimplifierMode -> SimplEnv
mkSimplEnv :: SimplMode -> SimplEnv
mkSimplEnv mode
= SimplEnv { seMode = mode
, seInScope = init_in_scope
, seLetFloats = emptyFloats
, seJoinFloats = emptyJoinFloats
, seTvSubst = emptyVarEnv
, seCvSubst = emptyVarEnv
, seIdSubst = emptyVarEnv }
......@@ -276,13 +299,16 @@ wild-ids before doing much else.
It's a very dark corner of GHC. Maybe it should be cleaned up.
-}
getMode :: SimplEnv -> SimplifierMode
getMode :: SimplEnv -> SimplMode
getMode env = seMode env
setMode :: SimplifierMode -> SimplEnv -> SimplEnv
seDynFlags :: SimplEnv -> DynFlags
seDynFlags env = sm_dflags (seMode env)
setMode :: SimplMode -> SimplEnv -> SimplEnv
setMode mode env = env { seMode = mode }
updMode :: (SimplifierMode -> SimplifierMode) -> SimplEnv -> SimplEnv
updMode :: (SimplMode -> SimplMode) -> SimplEnv -> SimplEnv
updMode upd env = env { seMode = upd (seMode env) }
---------------------
......@@ -308,19 +334,11 @@ getInScope env = seInScope env
setInScopeSet :: SimplEnv -> InScopeSet -> SimplEnv
setInScopeSet env in_scope = env {seInScope = in_scope}
setInScopeAndZapFloats :: SimplEnv -> SimplEnv -> SimplEnv
-- Set the in-scope set, and *zap* the floats
setInScopeAndZapFloats env env_with_scope
= env { seInScope = seInScope env_with_scope,
seLetFloats = emptyFloats,
seJoinFloats = emptyJoinFloats }
setInScopeFromE :: SimplEnv -> SimplEnv -> SimplEnv
setInScopeFromE env env' = env { seInScope = seInScope env' }
setFloats :: SimplEnv -> SimplEnv -> SimplEnv
-- Set the in-scope set *and* the floats
setFloats env env_with_floats
= env { seInScope = seInScope env_with_floats,
seLetFloats = seLetFloats env_with_floats,
seJoinFloats = seJoinFloats env_with_floats }
setInScopeFromF :: SimplEnv -> SimplFloats -> SimplEnv
setInScopeFromF env floats = env { seInScope = sfInScope floats }
addNewInScopeIds :: SimplEnv -> [CoreBndr] -> SimplEnv
-- The new Ids are guaranteed to be freshly allocated
......@@ -353,13 +371,13 @@ mkContEx (SimplEnv { seTvSubst = tvs, seCvSubst = cvs, seIdSubst = ids }) e = Co
{-
************************************************************************
* *
\subsection{Floats}
\subsection{LetFloats}
* *
************************************************************************
Note [Simplifier floats]
~~~~~~~~~~~~~~~~~~~~~~~~~
The Floats is a bunch of bindings, classified by a FloatFlag.
Note [LetFloats]
~~~~~~~~~~~~~~~~
The LetFloats is a bunch of bindings, classified by a FloatFlag.
* All of them satisfy the let/app invariant
......@@ -378,8 +396,8 @@ Can't happen:
NonRec x# (f y) -- Might diverge; does not satisfy let/app
-}
data Floats = Floats (OrdList OutBind) FloatFlag
-- See Note [Simplifier floats]
data LetFloats = LetFloats (OrdList OutBind) FloatFlag
-- See Note [LetFloats]
type JoinFloat = OutBind
type JoinFloats = OrdList JoinFloat
......@@ -401,12 +419,12 @@ data FloatFlag
-- 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 LetFloats where
ppr (LetFloats binds ff) = ppr ff $$ ppr (fromOL binds)
instance Outputable FloatFlag where
ppr FltLifted = text "FltLifted"
ppr FltOkSpec = text "FltOkSpec"
ppr FltLifted = text "FltLifted"
ppr FltOkSpec = text "FltOkSpec"
ppr FltCareful = text "FltCareful"
andFF :: FloatFlag -> FloatFlag -> FloatFlag
......@@ -415,9 +433,9 @@ andFF FltOkSpec FltCareful = FltCareful
andFF FltOkSpec _ = FltOkSpec
andFF FltLifted flt = flt
doFloatFromRhs :: TopLevelFlag -> RecFlag -> Bool -> OutExpr -> SimplEnv -> Bool
doFloatFromRhs :: TopLevelFlag -> RecFlag -> Bool -> SimplFloats -> OutExpr -> Bool
-- If you change this function look also at FloatIn.noFloatFromRhs
doFloatFromRhs lvl rec str rhs (SimplEnv {seLetFloats = Floats fs ff})
doFloatFromRhs lvl rec str (SimplFloats { sfLetFloats = LetFloats fs ff }) rhs
= not (isNilOL fs) && want_to_float && can_float
where
want_to_float = isTopLevel lvl || exprIsCheap rhs || exprIsExpandable rhs
......@@ -439,16 +457,16 @@ But there are
so we must take the 'or' of the two.
-}
emptyFloats :: Floats
emptyFloats = Floats nilOL FltLifted
emptyLetFloats :: LetFloats
emptyLetFloats = LetFloats nilOL FltLifted
emptyJoinFloats :: JoinFloats
emptyJoinFloats = nilOL
unitFloat :: OutBind -> Floats
unitLetFloat :: OutBind -> LetFloats
-- This key function constructs a singleton float with the right form
unitFloat bind = ASSERT(all (not . isJoinId) (bindersOf bind))
Floats (unitOL bind) (flag bind)
unitLetFloat bind = ASSERT(all (not . isJoinId) (bindersOf bind))
LetFloats (unitOL bind) (flag bind)
where
flag (Rec {}) = FltLifted
flag (NonRec bndr rhs)
......@@ -465,138 +483,132 @@ unitJoinFloat :: OutBind -> JoinFloats
unitJoinFloat bind = ASSERT(all isJoinId (bindersOf bind))
unitOL 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@(SimplEnv { seLetFloats = floats
, seJoinFloats = jfloats
, seInScope = in_scope })
id rhs
| isJoinId id -- This test incidentally forces the Id, and hence
-- its IdInfo, and hence any inner substitutions
= env { seInScope = in_scope'
, seLetFloats = floats
, seJoinFloats = jfloats' }
| otherwise
= env { seInScope = in_scope'
, seLetFloats = floats'
, seJoinFloats = jfloats }
mkFloatBind :: SimplEnv -> OutBind -> (SimplFloats, SimplEnv)
-- Make a singleton SimplFloats, and
-- extend the incoming SimplEnv's in-scope set with its binders
-- These binders may already be in the in-scope set,
-- but may have by now been augmented with more IdInfo
mkFloatBind env bind
= (floats, env { seInScope = in_scope' })
where
bind = NonRec id rhs
in_scope' = extendInScopeSet in_scope id
floats' = floats `addFlts` unitFloat bind
jfloats' = jfloats `addJoinFlts` unitJoinFloat bind
extendFloats :: SimplEnv -> OutBind -> SimplEnv
floats
| isJoinBind bind
= SimplFloats { sfLetFloats = emptyLetFloats
, sfJoinFloats = unitJoinFloat bind
, sfInScope = in_scope' }
| otherwise
= SimplFloats { sfLetFloats = unitLetFloat bind
, sfJoinFloats = emptyJoinFloats
, sfInScope = in_scope' }
in_scope' = seInScope env `extendInScopeSetBind` bind
extendFloats :: SimplFloats -> OutBind -> SimplFloats
-- Add this binding to the floats, and extend the in-scope env too
extendFloats env@(SimplEnv { seLetFloats = floats
, seJoinFloats = jfloats
, seInScope = in_scope })
extendFloats (SimplFloats { sfLetFloats = floats
, sfJoinFloats = jfloats
, sfInScope = in_scope })
bind
| isJoinBind bind
= env { seInScope = in_scope'
, seLetFloats = floats
, seJoinFloats = jfloats' }
= SimplFloats { sfInScope = in_scope'
, sfLetFloats = floats
, sfJoinFloats = jfloats' }
| otherwise
= env { seInScope = in_scope'
, seLetFloats = floats'
, seJoinFloats = jfloats }
= SimplFloats { sfInScope = in_scope'
, sfLetFloats = floats'
, sfJoinFloats = jfloats }
where
bndrs = bindersOf bind
in_scope' = extendInScopeSetList in_scope bndrs
floats' = floats `addFlts` unitFloat bind
in_scope' = in_scope `extendInScopeSetBind` bind
floats' = floats `addLetFlts` unitLetFloat bind
jfloats' = jfloats `addJoinFlts` unitJoinFloat bind
addLetFloats :: SimplEnv -> SimplEnv -> SimplEnv
addLetFloats :: SimplFloats -> LetFloats -> SimplFloats
-- Add the let-floats for env2 to env1;
-- *plus* the in-scope set for env2, which is bigger
-- than that for env1
addLetFloats env1 env2
= env1 { seLetFloats = seLetFloats env1 `addFlts` seLetFloats env2
, seInScope = seInScope env2 }
addFloats :: SimplEnv -> SimplEnv -> SimplEnv
addLetFloats floats let_floats@(LetFloats binds _)
= floats { sfLetFloats = sfLetFloats floats `addLetFlts` let_floats
, sfInScope = foldlOL extendInScopeSetBind
(sfInScope floats) binds }
addJoinFloats :: SimplFloats -> JoinFloats -> SimplFloats
addJoinFloats floats join_floats
= floats { sfJoinFloats = sfJoinFloats floats `addJoinFlts` join_floats
, sfInScope = foldlOL extendInScopeSetBind
(sfInScope floats) join_floats }
extendInScopeSetBind :: InScopeSet -> CoreBind -> InScopeSet
extendInScopeSetBind in_scope bind
= extendInScopeSetList in_scope (bindersOf bind)
addFloats :: SimplFloats -> SimplFloats -> SimplFloats
-- Add both let-floats and join-floats for env2 to env1;
-- *plus* the in-scope set for env2, which is bigger
-- than that for env1
addFloats env1 env2
= env1 { seLetFloats = seLetFloats env1 `addFlts` seLetFloats env2
, seJoinFloats = seJoinFloats env1 `addJoinFlts` seJoinFloats env2
, seInScope = seInScope env2 }
addFloats (SimplFloats { sfLetFloats = lf1, sfJoinFloats = jf1 })
(SimplFloats { sfLetFloats = lf2, sfJoinFloats = jf2, sfInScope = in_scope })
= SimplFloats { sfLetFloats = lf1 `addLetFlts` lf2
, sfJoinFloats = jf1 `addJoinFlts` jf2
, sfInScope = in_scope }
addFlts :: Floats -> Floats -> Floats
addFlts (Floats bs1 l1) (Floats bs2 l2)
= Floats (bs1 `appOL` bs2) (l1 `andFF` l2)
addLetFlts :: LetFloats -> LetFloats -> LetFloats
addLetFlts (LetFloats bs1 l1) (LetFloats bs2 l2)
= LetFloats (bs1 `appOL` bs2) (l1 `andFF` l2)
letFloatBinds :: LetFloats -> [CoreBind]
letFloatBinds (LetFloats bs _) = fromOL bs
addJoinFlts :: JoinFloats -> JoinFloats -> JoinFloats
addJoinFlts = appOL
zapFloats :: SimplEnv -> SimplEnv
zapFloats env = env { seLetFloats = emptyFloats
, seJoinFloats = emptyJoinFloats }
zapJoinFloats :: SimplEnv -> SimplEnv
zapJoinFloats env = env { seJoinFloats = emptyJoinFloats }
addJoinFloats :: SimplEnv -> JoinFloats -> SimplEnv
addJoinFloats env@(SimplEnv { seJoinFloats = fb1 }) fb2
= env { seJoinFloats = fb1 `addJoinFlts` fb2 }
addRecFloats :: SimplEnv -> SimplEnv -> SimplEnv
mkRecFloats :: SimplFloats -> SimplFloats
-- 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 {seLetFloats = Floats bs ff
,seJoinFloats = jbs })
-- They must either all be lifted LetFloats or all JoinFloats
mkRecFloats floats@(SimplFloats { sfLetFloats = LetFloats bs ff
, sfJoinFloats = jbs
, sfInScope = in_scope })
= ASSERT2( case ff of { FltLifted -> True; _ -> False }, ppr (fromOL bs) )
env2 {seLetFloats = seLetFloats env1 `addFlts` floats'
,seJoinFloats = seJoinFloats env1 `addJoinFlts` jfloats'}
ASSERT2( isNilOL bs || isNilOL jbs, ppr floats )
SimplFloats { sfLetFloats = floats'
, sfJoinFloats = jfloats'
, sfInScope = in_scope }
where
floats' | isNilOL bs = emptyFloats
| otherwise = unitFloat (Rec (flattenBinds (fromOL bs)))
floats' | isNilOL bs = emptyLetFloats
| otherwise = unitLetFloat (Rec (flattenBinds (fromOL bs)))
jfloats' | isNilOL jbs = emptyJoinFloats
| otherwise = unitJoinFloat (Rec (flattenBinds (fromOL jbs)))
wrapFloats :: SimplEnv -> OutExpr -> OutExpr
wrapFloats :: SimplFloats -> OutExpr -> OutExpr
-- Wrap the floats around the expression; they should all
-- satisfy the let/app invariant, so mkLets should do the job just fine
wrapFloats (SimplEnv { seLetFloats = Floats bs _
, seJoinFloats = jbs }) body
wrapFloats (SimplFloats { sfLetFloats = LetFloats bs _
, sfJoinFloats = jbs }) body
= foldrOL Let (wrapJoinFloats jbs body) bs