diff options
author | Simon Peyton Jones <simonpj@microsoft.com> | 2012-01-12 17:17:22 +0000 |
---|---|---|
committer | Simon Peyton Jones <simonpj@microsoft.com> | 2012-01-12 17:18:18 +0000 |
commit | 3beb1a831b37f616b5e8092def2e51cd9825735f (patch) | |
tree | 33bcf8fc8200d4ac221bb5cfe5383436fec916ec | |
parent | 6496c6f1421c3890e7fe72823c29584e5200f3fd (diff) | |
download | haskell-3beb1a831b37f616b5e8092def2e51cd9825735f.tar.gz |
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
-rw-r--r-- | compiler/coreSyn/CorePrep.lhs | 2 | ||||
-rw-r--r-- | compiler/coreSyn/CoreUtils.lhs | 55 | ||||
-rw-r--r-- | compiler/coreSyn/MkCore.lhs | 22 | ||||
-rw-r--r-- | compiler/prelude/PrimOp.lhs | 163 | ||||
-rw-r--r-- | compiler/simplCore/FloatIn.lhs | 123 | ||||
-rw-r--r-- | compiler/simplCore/FloatOut.lhs | 20 | ||||
-rw-r--r-- | compiler/simplCore/SimplEnv.lhs | 1 | ||||
-rw-r--r-- | compiler/simplCore/Simplify.lhs | 10 |
8 files changed, 237 insertions, 159 deletions
diff --git a/compiler/coreSyn/CorePrep.lhs b/compiler/coreSyn/CorePrep.lhs index a8985d0019..ed288096f7 100644 --- a/compiler/coreSyn/CorePrep.lhs +++ b/compiler/coreSyn/CorePrep.lhs @@ -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 diff --git a/compiler/coreSyn/CoreUtils.lhs b/compiler/coreSyn/CoreUtils.lhs index 1549ff3e68..198ac7e610 100644 --- a/compiler/coreSyn/CoreUtils.lhs +++ b/compiler/coreSyn/CoreUtils.lhs @@ -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 where 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. diff --git a/compiler/coreSyn/MkCore.lhs b/compiler/coreSyn/MkCore.lhs index ae6b095f99..5d1c19bc5f 100644 --- a/compiler/coreSyn/MkCore.lhs +++ b/compiler/coreSyn/MkCore.lhs @@ -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 \end{code} + +%************************************************************************ +%* * + Floats +%* * +%************************************************************************ + +\begin{code} +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)] +\end{code} + %************************************************************************ %* * \subsection{Tuple destructors} diff --git a/compiler/prelude/PrimOp.lhs b/compiler/prelude/PrimOp.lhs index d57d1f926e..39bee1fb9d 100644 --- a/compiler/prelude/PrimOp.lhs +++ b/compiler/prelude/PrimOp.lhs @@ -12,7 +12,8 @@ module PrimOp ( tagToEnumKey, primOpOutOfLine, primOpCodeSize, - primOpOkForSpeculation, primOpIsCheap, + primOpOkForSpeculation, primOpOkForSideEffects, + primOpIsCheap, 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. + +Consequences: + +* 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 + this + 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 - times. + * 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 -duplicated. - -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 - - let - t = case readMutVar# v s0 of (# s1, x #) -> (S# s1, x) - y = case t of (s,x) -> x - in - ... 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 -State#. - -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 -duplicated. \begin{code} 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) \end{code} -primOpIsCheap -~~~~~~~~~~~~~ +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 diff --git a/compiler/simplCore/FloatIn.lhs b/compiler/simplCore/FloatIn.lhs index 6745fda8cb..0601d7b7bf 100644 --- a/compiler/simplCore/FloatIn.lhs +++ b/compiler/simplCore/FloatIn.lhs @@ -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. %************************************************************************ \begin{code} -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 where [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. \begin{code} -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) where - [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 \end{code} 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)) where (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] ~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~ Consider 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 where - 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) where (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}!]. \begin{code} +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 + where + 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) where -- 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. \begin{code} sepBindsByDropPoint :: 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)) where - 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 where -- "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 \end{code} diff --git a/compiler/simplCore/FloatOut.lhs b/compiler/simplCore/FloatOut.lhs index 00d6554790..18fc9b4af4 100644 --- a/compiler/simplCore/FloatOut.lhs +++ b/compiler/simplCore/FloatOut.lhs @@ -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') -> let @@ -444,13 +444,6 @@ partitionByMajorLevel. \begin{code} -data FloatBind - = FloatLet FloatLet - - | FloatCase CoreExpr Id DataCon [Var] - -- case e of y { C ys -> ... } - -- See Note [Floating cases] in SetLevels - type FloatLet = CoreBind -- INVARIANT: a FloatLet is always lifted type MajorEnv = M.IntMap MinorEnv -- Keyed by major level type MinorEnv = M.IntMap (Bag FloatBind) -- Keyed by minor level @@ -491,7 +484,7 @@ flattenMinor = M.fold unionBags emptyBag emptyFloats :: FloatBinds emptyFloats = FB emptyBag M.empty -unitCaseFloat :: Level -> CoreExpr -> Id -> DataCon -> [Var] -> FloatBinds +unitCaseFloat :: Level -> CoreExpr -> Id -> AltCon -> [Var] -> FloatBinds unitCaseFloat (Level major minor) e b con bs = FB emptyBag (M.singleton major (M.singleton minor (unitBag (FloatCase e b con bs)))) @@ -514,12 +507,7 @@ plusMinor = M.unionWith unionBags install :: Bag FloatBind -> CoreExpr -> CoreExpr install defn_groups expr - = foldrBag install_group expr defn_groups - where - install_group (FloatLet defns) body - = Let defns body - install_group (FloatCase e b con bs) body - = Case e b (exprType body) [(DataAlt con, bs, body)] + = foldrBag wrapFloat expr defn_groups partitionByLevel :: Level -- Partitioning level diff --git a/compiler/simplCore/SimplEnv.lhs b/compiler/simplCore/SimplEnv.lhs index 62f96e7c6e..8661d71e04 100644 --- a/compiler/simplCore/SimplEnv.lhs +++ b/compiler/simplCore/SimplEnv.lhs @@ -397,6 +397,7 @@ classifyFF (NonRec bndr rhs) | otherwise = FltCareful doFloatFromRhs :: TopLevelFlag -> RecFlag -> Bool -> OutExpr -> SimplEnv -> Bool +-- If you change this function look also at FloatIn.noFloatFromRhs doFloatFromRhs lvl rec str rhs (SimplEnv {seFloats = Floats fs ff}) = not (isNilOL fs) && want_to_float && can_float where diff --git a/compiler/simplCore/Simplify.lhs b/compiler/simplCore/Simplify.lhs index d5b3d76c4a..4d1717f4ea 100644 --- a/compiler/simplCore/Simplify.lhs +++ b/compiler/simplCore/Simplify.lhs @@ -1761,7 +1761,7 @@ rebuildCase env scrut case_bndr [(_, bndrs, rhs)] cont | all isDeadBinder bndrs -- bndrs are [InId] , if isUnLiftedType (idType case_bndr) - then ok_for_spec -- Satisfy the let-binding invariant + then elim_unlifted -- Satisfy the let-binding invariant else elim_lifted = do { -- pprTrace "case elim" (vcat [ppr case_bndr, ppr (exprIsHNF scrut), -- ppr strict_case_bndr, ppr (scrut_is_var scrut), @@ -1781,6 +1781,14 @@ rebuildCase env scrut case_bndr [(_, bndrs, rhs)] cont || (is_plain_seq && ok_for_spec) -- Note: not the same as exprIsHNF + elim_unlifted + | is_plain_seq = exprOkForSideEffects scrut + -- The entire case is dead, so we can drop it, + -- _unless_ the scrutinee has side effects + | otherwise = exprOkForSpeculation scrut + -- The case-binder is alive, but we may be able + -- turn the case into a let, if the expression is ok-for-spec + ok_for_spec = exprOkForSpeculation scrut is_plain_seq = isDeadBinder case_bndr -- Evaluation *only* for effect strict_case_bndr = isStrictDmd (idDemandInfo case_bndr) |