Commit 3beb1a83 authored by Simon Peyton Jones's avatar Simon Peyton Jones
Browse files

Fix Trac #5658: strict bindings not floated in

Two changes here

* The main change here is to enhance the FloatIn pass so that it can
  float case-bindings inwards.  In particular the case bindings for
  array indexing.

* Also change the code in Simplify, to allow a case on array
  indexing (ie can_fail is true) to be discarded altogether if its
  results are unused.

Lots of new comments in PrimOp about can_fail and has_side_effects

Some refactoring to share the FloatBind data structure between
FloatIn and FloatOut
parent 6496c6f1
......@@ -26,7 +26,7 @@ import CoreFVs
import CoreMonad ( endPass, CoreToDo(..) )
import CoreSyn
import CoreSubst
import MkCore
import MkCore hiding( FloatBind(..) ) -- We use our own FloatBind here
import Type
import Literal
import Coercion
......@@ -21,7 +21,8 @@ module CoreUtils (
exprType, coreAltType, coreAltsType,
exprIsDupable, exprIsTrivial, getIdFromTrivialExpr, exprIsBottom,
exprIsCheap, exprIsExpandable, exprIsCheap', CheapAppFun,
exprIsHNF, exprOkForSpeculation, exprIsBig, exprIsConLike,
exprIsHNF, exprOkForSpeculation, exprOkForSideEffects,
exprIsBig, exprIsConLike,
rhsIsStatic, isCheapApp, isExpandableApp,
-- * Expression and bindings size
......@@ -756,35 +757,39 @@ it's applied only to dictionaries.
-- We can only do this if the @y + 1@ is ok for speculation: it has no
-- side effects, and can't diverge or raise an exception.
exprOkForSpeculation :: Expr b -> Bool
exprOkForSpeculation, exprOkForSideEffects :: Expr b -> Bool
exprOkForSpeculation = expr_ok primOpOkForSpeculation
exprOkForSideEffects = expr_ok primOpOkForSideEffects
-- Polymorphic in binder type
-- There is one call at a non-Id binder type, in SetLevels
exprOkForSpeculation (Lit _) = True
exprOkForSpeculation (Type _) = True
exprOkForSpeculation (Coercion _) = True
exprOkForSpeculation (Var v) = appOkForSpeculation v []
exprOkForSpeculation (Cast e _) = exprOkForSpeculation e
expr_ok :: (PrimOp -> Bool) -> Expr b -> Bool
expr_ok _ (Lit _) = True
expr_ok _ (Type _) = True
expr_ok _ (Coercion _) = True
expr_ok primop_ok (Var v) = app_ok primop_ok v []
expr_ok primop_ok (Cast e _) = expr_ok primop_ok e
-- Tick annotations that *tick* cannot be speculated, because these
-- are meant to identify whether or not (and how often) the particular
-- source expression was evaluated at runtime.
exprOkForSpeculation (Tick tickish e)
expr_ok primop_ok (Tick tickish e)
| tickishCounts tickish = False
| otherwise = exprOkForSpeculation e
| otherwise = expr_ok primop_ok e
exprOkForSpeculation (Case e _ _ alts)
= exprOkForSpeculation e -- Note [exprOkForSpeculation: case expressions]
&& all (\(_,_,rhs) -> exprOkForSpeculation rhs) alts
&& altsAreExhaustive alts -- Note [exprOkForSpeculation: exhaustive alts]
expr_ok primop_ok (Case e _ _ alts)
= expr_ok primop_ok e -- Note [exprOkForSpeculation: case expressions]
&& all (\(_,_,rhs) -> expr_ok primop_ok rhs) alts
&& altsAreExhaustive alts -- Note [Exhaustive alts]
exprOkForSpeculation other_expr
expr_ok primop_ok other_expr
= case collectArgs other_expr of
(Var f, args) -> appOkForSpeculation f args
(Var f, args) -> app_ok primop_ok f args
_ -> False
appOkForSpeculation :: Id -> [Expr b] -> Bool
appOkForSpeculation fun args
app_ok :: (PrimOp -> Bool) -> Id -> [Expr b] -> Bool
app_ok primop_ok fun args
= case idDetails fun of
DFunId new_type -> not new_type
-- DFuns terminate, unless the dict is implemented
......@@ -798,7 +803,7 @@ appOkForSpeculation fun args
PrimOpId op
| isDivOp op -- Special case for dividing operations that fail
, [arg1, Lit lit] <- args -- only if the divisor is zero
-> not (isZeroLit lit) && exprOkForSpeculation arg1
-> not (isZeroLit lit) && expr_ok primop_ok arg1
-- Often there is a literal divisor, and this
-- can get rid of a thunk in an inner looop
......@@ -806,14 +811,14 @@ appOkForSpeculation fun args
-> True
| otherwise
-> primOpOkForSpeculation op &&
all exprOkForSpeculation args
-- A bit conservative: we don't really need
-> primop_ok op -- A bit conservative: we don't really need
&& all (expr_ok primop_ok) args
-- to care about lazy arguments, but this is easy
_other -> isUnLiftedType (idType fun) -- c.f. the Var case of exprIsHNF
|| idArity fun > n_val_args -- Partial apps
|| (n_val_args ==0 &&
|| (n_val_args == 0 &&
isEvaldUnfolding (idUnfolding fun)) -- Let-bound values
n_val_args = valArgCount args
......@@ -876,13 +881,13 @@ If exprOkForSpeculation doesn't look through case expressions, you get this:
The inner case is redundant, and should be nuked.
Note [exprOkForSpeculation: exhaustive alts]
Note [Exhaustive alts]
We might have something like
case x of {
A -> ...
_ -> ...(case x of { B -> ...; C -> ... })...
Here, the inner case is fine, becuase the A alternative
Here, the inner case is fine, because the A alternative
can't happen, but it's not ok to float the inner case outside
the outer one (even if we know x is evaluated outside), because
then it would be non-exhaustive. See Trac #5453.
......@@ -21,6 +21,9 @@ module MkCore (
mkFloatExpr, mkDoubleExpr,
mkCharExpr, mkStringExpr, mkStringExprFS,
-- * Floats
FloatBind(..), wrapFloat,
-- * Constructing/deconstructing implicit parameter boxes
mkIPUnbox, mkIPBox,
......@@ -389,6 +392,25 @@ mkBigCoreTupTy :: [Type] -> Type
mkBigCoreTupTy = mkChunkified mkBoxedTupleTy
%* *
%* *
data FloatBind
= FloatLet CoreBind
| FloatCase CoreExpr Id AltCon [Var]
-- case e of y { C ys -> ... }
-- See Note [Floating cases] in SetLevels
wrapFloat :: FloatBind -> CoreExpr -> CoreExpr
wrapFloat (FloatLet defns) body = Let defns body
wrapFloat (FloatCase e b con bs) body = Case e b (exprType body) [(con, bs, body)]
%* *
\subsection{Tuple destructors}
......@@ -12,7 +12,8 @@ module PrimOp (
primOpOutOfLine, primOpCodeSize,
primOpOkForSpeculation, primOpIsCheap,
primOpOkForSpeculation, primOpOkForSideEffects,
getPrimOpResultInfo, PrimOpResultInfo(..),
......@@ -307,77 +308,93 @@ primOpOutOfLine :: PrimOp -> Bool
Note [PrimOp can_fail and has_side_effects]
* A primop that is neither can_fail nor has_side_effects can be
executed speculatively, any number of times
Both can_fail and has_side_effects mean that the primop has
some effect that is not captured entirely by its result value.
---------- has_side_effects ---------------------
Has some imperative side effect, perhaps on the world (I/O),
or perhaps on some mutable data structure (writeIORef).
Generally speaking all such primops have a type like
State -> input -> (State, output)
so the state token guarantees ordering, and also ensures
that the primop is executed even if 'output' is discarded.
---------- can_fail ----------------------------
Can fail with a seg-fault or divide-by-zero error on some elements
of its input domain. Main examples:
division (fails on zero demoninator
array indexing (fails if the index is out of bounds)
However (ASSUMPTION), these can_fail primops are ALWAYS surrounded
with a test that checks for the bad cases.
* You can discard a can_fail primop, or float it _inwards_.
But you cannot float it _outwards_, lest you escape the
dynamic scope of the test. Example:
case d ># 0# of
True -> case x /# d of r -> r +# 1
False -> 0
Here we must not float the case outwards to give
case x/# d of r ->
case d ># 0# of
True -> r +# 1
False -> 0
* I believe that exactly the same rules apply to a has_side_effects
primop; you can discard it (remember, the state token will keep
it alive if necessary), or float it in, but not float it out.
Example of the latter
if blah then let! s1 = writeMutVar s0 v True in s1
else s0
Notice that s0 is mentioned in both branches of the 'if', but
only one of these two will actually be consumed. But if we
float out to
let! s1 = writeMutVar s0 v True
in if blah then s1 else s0
the writeMutVar will be performed in both branches, which is
utterly wrong.
* You cannot duplicate a has_side_effect primop. You might wonder
how this can occur given the state token threading, but just look
at Control.Monad.ST.Lazy.Imp.strictToLazy! We get something like
p = case readMutVar# s v of
(# s', r #) -> (S# s', r)
s' = case p of (s', r) -> s'
r = case p of (s', r) -> r
(All these bindings are boxed.) If we inline p at its two call
sites, we get a catastrophe: because the read is performed once when
s' is demanded, and once when 'r' is demanded, which may be much
later. Utterly wrong. Trac #3207 is real example of this happening.
However, it's fine to duplicate a can_fail primop. That is
the difference between can_fail and has_side_effects.
can_fail has_side_effects
Discard YES YES
Float in YES YES
Float out NO NO
Duplicate YES NO
How do we achieve these effects?
* A primop that is marked can_fail cannot be executed speculatively,
(becuase the might provoke the failure), but it can be repeated.
Why would you want to do that? Perhaps it might enable some
eta-expansion, if you can prove that the lambda is definitely
applied at least once. I guess we don't currently do that.
Note [primOpOkForSpeculation]
* The "no-float-out" thing is achieved by ensuring that we never
let-bind a can_fail or has_side_effects primop. The RHS of a
let-binding (which can float in and out freely) satisfies
exprOkForSpeculation. And exprOkForSpeculation is false of
can_fail and no_side_effect.
* A primop that is marked has_side_effects can be neither speculated
nor repeated; it must be executed exactly the right number of
* So can_fail and no_side_effect primops will appear only as the
scrutinees of cases, and that's why the FloatIn pass is capable
of floating case bindings inwards.
So has_side_effects implies can_fail. We don't currently exploit
the case of primops that can_fail but do not have_side_effects.
* The no-duplicate thing is done via primOpIsCheap, by making
has_side_effects things (very very very) not-cheap!
Note [primOpOkForSpeculation]
Sometimes we may choose to execute a PrimOp even though it isn't
certain that its result will be required; ie execute them
``speculatively''. The same thing as ``cheap eagerness.'' Usually
this is OK, because PrimOps are usually cheap, but it isn't OK for
* PrimOps that are expensive
* PrimOps which can fail
* PrimOps that have side effects
Ok-for-speculation also means that it's ok *not* to execute the
primop. For example
case op a b of
r -> 3
Here the result is not used, so we can discard the primop. Anything
that has side effects mustn't be dicarded in this way, of course!
See also @primOpIsCheap@ (below).
Note [primOpHasSideEffects]
Some primops have side-effects and so, for example, must not be
This predicate means a little more than just "modifies the state of
the world". What it really means is "it cosumes the state on its
input". To see what this means, consider
t = case readMutVar# v s0 of (# s1, x #) -> (S# s1, x)
y = case t of (s,x) -> x
... y ... y ...
Now, this is part of an ST or IO thread, so we are guaranteed by
construction that the program uses the state in a single-threaded way.
Whenever the state resulting from the readMutVar# is demanded, the
readMutVar# will be performed, and it will be ordered correctly with
respect to other operations in the monad.
But there's another way this could go wrong: GHC can inline t into y,
and inline y. Then although the original readMutVar# will still be
correctly ordered with respect to the other operations, there will be
one or more extra readMutVar#s performed later, possibly out-of-order.
This really happened; see #3207.
The property we need to capture about readMutVar# is that it consumes
the State# value on its input. We must retain the linearity of the
Our fix for this is to declare any primop that must be used linearly
as having side-effects. When primOpHasSideEffects is True,
primOpOkForSpeculation will be False, and hence primOpIsCheap will
also be False, and applications of the primop will never be
primOpHasSideEffects :: PrimOp -> Bool
......@@ -387,15 +404,19 @@ primOpCanFail :: PrimOp -> Bool
#include "primop-can-fail.hs-incl"
primOpOkForSpeculation :: PrimOp -> Bool
-- See Note [primOpOkForSpeculation]
-- See Note [primOpOkForSpeculation and primOpOkForFloatOut]
-- See comments with CoreUtils.exprOkForSpeculation
primOpOkForSpeculation op
= not (primOpHasSideEffects op || primOpOutOfLine op || primOpCanFail op)
primOpOkForSideEffects :: PrimOp -> Bool
primOpOkForSideEffects op
= not (primOpHasSideEffects op)
Note [primOpIsCheap]
@primOpIsCheap@, as used in \tr{SimplUtils.lhs}. For now (HACK
WARNING), we just borrow some other predicates for a
what-should-be-good-enough test. "Cheap" means willing to call it more
......@@ -24,7 +24,8 @@ module FloatIn ( floatInwards ) where
#include "HsVersions.h"
import CoreSyn
import CoreUtils ( exprIsHNF, exprIsDupable )
import MkCore
import CoreUtils ( exprIsDupable, exprIsExpandable, exprOkForSideEffects )
import CoreFVs ( CoreExprWithFVs, freeVars, freeVarsOf, idRuleAndUnfoldingVars )
import Id ( isOneShotBndr, idType )
import Var
......@@ -119,26 +120,28 @@ the closure for a is not built.
type FreeVarsSet = IdSet
type FreeVarSet = IdSet
type BoundVarSet = IdSet
type FloatingBinds = [(CoreBind, FreeVarsSet)]
-- In reverse dependency order (innermost binder first)
-- The FreeVarsSet is the free variables of the binding. In the case
data FloatInBind = FB BoundVarSet FreeVarSet FloatBind
-- The FreeVarSet is the free variables of the binding. In the case
-- of recursive bindings, the set doesn't include the bound
-- variables.
fiExpr :: FloatingBinds -- Binds we're trying to drop
type FloatInBinds = [FloatInBind]
-- In reverse dependency order (innermost binder first)
fiExpr :: FloatInBinds -- Binds we're trying to drop
-- as far "inwards" as possible
-> CoreExprWithFVs -- Input expr
-> CoreExpr -- Result
fiExpr to_drop (_, AnnLit lit) = ASSERT( null to_drop ) Lit lit
fiExpr to_drop (_, AnnType ty) = ASSERT( null to_drop ) Type ty
fiExpr to_drop (_, AnnVar v) = mkCoLets' to_drop (Var v)
fiExpr to_drop (_, AnnCoercion co) = mkCoLets' to_drop (Coercion co)
fiExpr to_drop (_, AnnVar v) = wrapFloats to_drop (Var v)
fiExpr to_drop (_, AnnCoercion co) = wrapFloats to_drop (Coercion co)
fiExpr to_drop (_, AnnCast expr (fvs_co, co))
= mkCoLets' (drop_here ++ co_drop) $
= wrapFloats (drop_here ++ co_drop) $
Cast (fiExpr e_drop expr) co
[drop_here, e_drop, co_drop] = sepBindsByDropPoint False [freeVarsOf expr, fvs_co] to_drop
......@@ -149,10 +152,16 @@ need to get at all the arguments. The next simplifier run will
pull out any silly ones.
fiExpr to_drop (_,AnnApp fun arg)
= mkCoLets' drop_here (App (fiExpr fun_drop fun) (fiExpr arg_drop arg))
fiExpr to_drop (_,AnnApp fun arg@(arg_fvs, ann_arg))
| noFloatIntoRhs ann_arg = wrapFloats drop_here $ wrapFloats arg_drop $
App (fiExpr fun_drop fun) (fiExpr [] arg)
-- It's inconvenient to test for an unlifted arg here,
-- and it really doesn't matter if we float into one
| otherwise = wrapFloats drop_here $
App (fiExpr fun_drop fun) (fiExpr arg_drop arg)
[drop_here, fun_drop, arg_drop] = sepBindsByDropPoint False [freeVarsOf fun, freeVarsOf arg] to_drop
[drop_here, fun_drop, arg_drop]
= sepBindsByDropPoint False [freeVarsOf fun, arg_fvs] to_drop
Note [Floating in past a lambda group]
......@@ -199,7 +208,7 @@ fiExpr to_drop lam@(_, AnnLam _ _)
= mkLams bndrs (fiExpr to_drop body)
| otherwise -- Dump it all here
= mkCoLets' to_drop (mkLams bndrs (fiExpr [] body))
= wrapFloats to_drop (mkLams bndrs (fiExpr [] body))
(bndrs, body) = collectAnnBndrs lam
......@@ -220,7 +229,7 @@ We don't float lets inwards past an SCC.
fiExpr to_drop (_, AnnTick tickish expr)
| tickishScoped tickish
= -- Wimp out for now - we could push values in
mkCoLets' to_drop (Tick tickish (fiExpr [] expr))
wrapFloats to_drop (Tick tickish (fiExpr [] expr))
| otherwise
= Tick tickish (fiExpr to_drop expr)
......@@ -266,7 +275,7 @@ can't have unboxed bindings.
So we make "extra_fvs" which is the rhs_fvs of such bindings, and
arrange to dump bindings that bind extra_fvs before the entire let.
Note [extra_fvs (s): free variables of rules]
Note [extra_fvs (2): free variables of rules]
let x{rule mentioning y} = rhs in body
......@@ -280,13 +289,13 @@ idFreeVars.
fiExpr to_drop (_,AnnLet (AnnNonRec id rhs@(rhs_fvs, ann_rhs)) body)
= fiExpr new_to_drop body
body_fvs = freeVarsOf body
body_fvs = freeVarsOf body `delVarSet` id
rule_fvs = idRuleAndUnfoldingVars id -- See Note [extra_fvs (2): free variables of rules]
extra_fvs | noFloatIntoRhs ann_rhs
|| isUnLiftedType (idType id) = rule_fvs `unionVarSet` rhs_fvs
| otherwise = rule_fvs
-- See Note [extra_fvs (2): avoid floating into RHS]
-- See Note [extra_fvs (1): avoid floating into RHS]
-- No point in floating in only to float straight out again
-- Ditto ok-for-speculation unlifted RHSs
......@@ -294,7 +303,8 @@ fiExpr to_drop (_,AnnLet (AnnNonRec id rhs@(rhs_fvs, ann_rhs)) body)
= sepBindsByDropPoint False [extra_fvs, rhs_fvs, body_fvs] to_drop
new_to_drop = body_binds ++ -- the bindings used only in the body
[(NonRec id rhs', rhs_fvs')] ++ -- the new binding itself
[FB (unitVarSet id) rhs_fvs'
(FloatLet (NonRec id rhs'))] ++ -- the new binding itself
extra_binds ++ -- bindings from extra_fvs
shared_binds -- the bindings used both in rhs and body
......@@ -308,7 +318,7 @@ fiExpr to_drop (_,AnnLet (AnnRec bindings) body)
(ids, rhss) = unzip bindings
rhss_fvs = map freeVarsOf rhss
body_fvs = freeVarsOf body
body_fvs = freeVarsOf body
-- See Note [extra_fvs (1,2)]
rule_fvs = foldr (unionVarSet . idRuleAndUnfoldingVars) emptyVarSet ids
......@@ -320,7 +330,8 @@ fiExpr to_drop (_,AnnLet (AnnRec bindings) body)
= sepBindsByDropPoint False (extra_fvs:body_fvs:rhss_fvs) to_drop
new_to_drop = body_binds ++ -- the bindings used only in the body
[(Rec (fi_bind rhss_binds bindings), rhs_fvs')] ++
[FB (mkVarSet ids) rhs_fvs'
(FloatLet (Rec (fi_bind rhss_binds bindings)))] ++
-- The new binding itself
extra_binds ++ -- Note [extra_fvs (1,2)]
shared_binds -- Used in more than one place
......@@ -330,7 +341,7 @@ fiExpr to_drop (_,AnnLet (AnnRec bindings) body)
rule_fvs -- Don't forget the rule variables!
-- Push rhs_binds into the right hand side of the binding
fi_bind :: [FloatingBinds] -- one per "drop pt" conjured w/ fvs_of_rhss
fi_bind :: [FloatInBinds] -- one per "drop pt" conjured w/ fvs_of_rhss
-> [(Id, CoreExprWithFVs)]
-> [(Id, CoreExpr)]
......@@ -344,17 +355,32 @@ bindings are: (a)~inside the scrutinee, (b)~inside one of the
alternatives/default [default FVs always {\em first}!].
fiExpr to_drop (_, AnnCase scrut case_bndr _ [(DEFAULT,[],rhs)])
| isUnLiftedType (idType case_bndr)
, exprOkForSideEffects (deAnnotate scrut)
= wrapFloats shared_binds $
fiExpr (case_float : rhs_binds) rhs
case_float = FB (unitVarSet case_bndr) scrut_fvs
(FloatCase scrut' case_bndr DEFAULT [])
scrut' = fiExpr scrut_binds scrut
[shared_binds, scrut_binds, rhs_binds]
= sepBindsByDropPoint False [freeVarsOf scrut, rhs_fvs] to_drop
rhs_fvs = freeVarsOf rhs `delVarSet` case_bndr
scrut_fvs = freeVarsOf scrut
fiExpr to_drop (_, AnnCase scrut case_bndr ty alts)
= mkCoLets' drop_here1 $
mkCoLets' drop_here2 $
= wrapFloats drop_here1 $
wrapFloats drop_here2 $
Case (fiExpr scrut_drops scrut) case_bndr ty
(zipWith fi_alt alts_drops_s alts)
-- Float into the scrut and alts-considered-together just like App
[drop_here1, scrut_drops, alts_drops] = sepBindsByDropPoint False [scrut_fvs, all_alts_fvs] to_drop
[drop_here1, scrut_drops, alts_drops]
= sepBindsByDropPoint False [scrut_fvs, all_alts_fvs] to_drop
-- Float into the alts with the is_case flag set
(drop_here2 : alts_drops_s) = sepBindsByDropPoint True alts_fvs alts_drops
(drop_here2 : alts_drops_s) = sepBindsByDropPoint True alts_fvs alts_drops
scrut_fvs = freeVarsOf scrut
alts_fvs = map alt_fvs alts
......@@ -376,7 +402,9 @@ noFloatIntoRhs (AnnLam b _) = not (is_one_shot b)
-- boxing constructor into it, else we box it every time which is very bad
-- news indeed.
noFloatIntoRhs rhs = exprIsHNF (deAnnotate' rhs) -- We'd just float right back out again...
noFloatIntoRhs rhs = exprIsExpandable (deAnnotate' rhs)
-- We'd just float right back out again...
-- Should match the test in SimplEnv.doFloatFromRhs
is_one_shot :: Var -> Bool
is_one_shot b = isId b && isOneShotBndr b
......@@ -407,9 +435,9 @@ We have to maintain the order on these drop-point-related lists.
:: Bool -- True <=> is case expression
-> [FreeVarsSet] -- One set of FVs per drop point
-> FloatingBinds -- Candidate floaters
-> [FloatingBinds] -- FIRST one is bindings which must not be floated
-> [FreeVarSet] -- One set of FVs per drop point
-> FloatInBinds -- Candidate floaters
-> [FloatInBinds] -- FIRST one is bindings which must not be floated
-- inside any drop point; the rest correspond
-- one-to-one with the input list of FV sets
......@@ -419,7 +447,7 @@ sepBindsByDropPoint
-- a binding (let x = E in B) might have a specialised version of
-- x (say x') stored inside x, but x' isn't free in E or B.
type DropBox = (FreeVarsSet, FloatingBinds)
type DropBox = (FreeVarSet, FloatInBinds)
sepBindsByDropPoint _is_case drop_pts []
= [] : [[] | _ <- drop_pts] -- cut to the chase scene; it happens
......@@ -427,19 +455,19 @@ sepBindsByDropPoint _is_case drop_pts []
sepBindsByDropPoint is_case drop_pts floaters
= go floaters (map (\fvs -> (fvs, [])) (emptyVarSet : drop_pts))
go :: FloatingBinds -> [DropBox] -> [FloatingBinds]
go :: FloatInBinds -> [DropBox] -> [FloatInBinds]
-- The *first* one in the argument list is the drop_here set
-- The FloatingBinds in the lists are in the reverse of
-- the normal FloatingBinds order; that is, they are the right way round!
-- The FloatInBinds in the lists are in the reverse of
-- the normal FloatInBinds order; that is, they are the right way round!
go [] drop_boxes = map (reverse . snd) drop_boxes
go (bind_w_fvs@(bind, bind_fvs) : binds) drop_boxes@(here_box : fork_boxes)
go (bind_w_fvs@(FB bndrs bind_fvs bind) : binds) drop_boxes@(here_box : fork_boxes)
= go binds new_boxes
-- "here" means the group of bindings dropped at the top of the fork
(used_here : used_in_flags) = [ any (`elemVarSet` fvs) (bindersOf bind)
(used_here : used_in_flags) = [ fvs `intersectsVarSet` bndrs
| (fvs, _) <- drop_boxes]
drop_here = used_here || not can_push
......@@ -460,7 +488,7 @@ sepBindsByDropPoint is_case drop_pts floaters
|| (is_case && -- We are looking at case alternatives
n_used_alts > 1 && -- It's used in more than one
n_used_alts < n_alts && -- ...but not all
bindIsDupable bind) -- and we can duplicate the binding
floatIsDupable bind) -- and we can duplicate the binding
new_boxes | drop_here = (insert here_box : fork_boxes)
| otherwise = (here_box : new_fork_boxes)
......@@ -476,14 +504,19 @@ sepBindsByDropPoint is_case drop_pts floaters
go _ _ = panic "sepBindsByDropPoint/go"
floatedBindsFVs :: FloatingBinds -> FreeVarsSet
floatedBindsFVs binds = unionVarSets (map snd binds)
floatedBindsFVs :: FloatInBinds -> FreeVarSet
floatedBindsFVs binds = foldr (unionVarSet . fbFVs) emptyVarSet binds
fbFVs :: FloatInBind -> VarSet
fbFVs (FB _ fvs _) = fvs
mkCoLets' :: FloatingBinds -> CoreExpr -> CoreExpr
mkCoLets' to_drop e = foldl (flip (Let . fst)) e to_drop
-- Remember to_drop is in *reverse* dependency order
wrapFloats :: FloatInBinds -> CoreExpr -> CoreExpr
-- Remember FloatInBinds is in *reverse* dependency order
wrapFloats [] e = e
wrapFloats (FB _ _ fl : bs) e = wrapFloats bs (wrapFloat fl e)
bindIsDupable :: Bind CoreBndr -> Bool
bindIsDupable (Rec prs) = all (exprIsDupable . snd) prs
bindIsDupable (NonRec _ r) = exprIsDupable r
floatIsDupable :: FloatBind -> Bool
floatIsDupable (FloatCase scrut _ _ _) = exprIsDupable scrut
floatIsDupable (FloatLet (Rec prs)) = all (exprIsDupable . snd) prs
floatIsDupable (FloatLet (NonRec _ r)) = exprIsDupable r
......@@ -17,12 +17,12 @@ module FloatOut ( floatOutwards ) where
import CoreSyn
import CoreUtils
import MkCore
import CoreArity ( etaExpand )
import CoreMonad ( FloatOutSwitches(..) )
import DynFlags ( DynFlags, DynFlag(..) )
import ErrUtils ( dumpIfSet_dyn )
import DataCon ( DataCon )
import Id ( Id, idArity, isBottomingId )
import Var ( Var )
import SetLevels
......@@ -326,7 +326,7 @@ floatExpr (Let bind body)
floatExpr (Case scrut (TB case_bndr case_spec) ty alts)
= case case_spec of
FloatMe dest_lvl -- Case expression moves
| [(DataAlt con, bndrs, rhs)] <- alts
| [(con@(DataAlt {}), bndrs, rhs)] <- alts
-> case floatExpr scrut of { (fse, fde, scrut') ->
case floatExpr rhs of { (fsb, fdb, rhs') ->
......@@ -444,13 +444,6 @@ partitionByMajorLevel.
data FloatBind
= FloatLet FloatLet