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

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
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.
......
......@@ -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}
......
......@@ -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
......
This diff is collapsed.
......@@ -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
......
......@@ -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
......
......@@ -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)
......
Markdown is supported
0%
or
You are about to add 0 people to the discussion. Proceed with caution.
Finish editing this message first!
Please register or to comment