Skip to content
Snippets Groups Projects
Commit acd157f7 authored by Ian Lynagh's avatar Ian Lynagh
Browse files

Merged: Fix two bugs in caes-floating (fixes Trac #5453)

Changeset bd6f5de7
Author: Simon Peyton Jones <simonpj@microsoft.com>

Fix two bugs in caes-floating (fixes Trac #5453)

The problem is documented in the ticket. The patch
does two things

1. Make exprOkForSpeculation return False for a non-exhaustive case

2. In SetLevels?.lvlExpr, look at the *result* scrutinee, not the
    *input* scrutinee, when testing for evaluated-ness
parent edbea0b7
No related branches found
No related tags found
No related merge requests found
...@@ -688,7 +688,9 @@ it's applied only to dictionaries. ...@@ -688,7 +688,9 @@ it's applied only to dictionaries.
-- --
-- We can only do this if the @y + 1@ is ok for speculation: it has no -- 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. -- side effects, and can't diverge or raise an exception.
exprOkForSpeculation :: CoreExpr -> Bool exprOkForSpeculation :: Expr b -> Bool
-- Polymorphic in binder type
-- There is one call at a non-Id binder type, in SetLevels
exprOkForSpeculation (Lit _) = True exprOkForSpeculation (Lit _) = True
exprOkForSpeculation (Type _) = True exprOkForSpeculation (Type _) = True
exprOkForSpeculation (Coercion _) = True exprOkForSpeculation (Coercion _) = True
...@@ -706,6 +708,7 @@ exprOkForSpeculation (Cast e _) = exprOkForSpeculation e ...@@ -706,6 +708,7 @@ exprOkForSpeculation (Cast e _) = exprOkForSpeculation e
exprOkForSpeculation (Case e _ _ alts) exprOkForSpeculation (Case e _ _ alts)
= exprOkForSpeculation e -- Note [exprOkForSpeculation: case expressions] = exprOkForSpeculation e -- Note [exprOkForSpeculation: case expressions]
&& all (\(_,_,rhs) -> exprOkForSpeculation rhs) alts && all (\(_,_,rhs) -> exprOkForSpeculation rhs) alts
&& altsAreExhaustive alts -- Note [exprOkForSpeculation: exhaustive alts]
exprOkForSpeculation other_expr exprOkForSpeculation other_expr
= case collectArgs other_expr of = case collectArgs other_expr of
...@@ -740,6 +743,21 @@ exprOkForSpeculation other_expr ...@@ -740,6 +743,21 @@ exprOkForSpeculation other_expr
spec_ok _ _ = False spec_ok _ _ = False
altsAreExhaustive :: [Alt b] -> Bool
-- True <=> the case alterantives are definiely exhaustive
-- False <=> they may or may not be
altsAreExhaustive []
= False -- Should not happen
altsAreExhaustive ((con1,_,_) : alts)
= case con1 of
DEFAULT -> True
LitAlt {} -> False
DataAlt c -> 1 + length alts == tyConFamilySize (dataConTyCon c)
-- It is possible to have an exhaustive case that does not
-- enumerate all constructors, notably in a GADT match, but
-- we behave conservatively here -- I don't think it's important
-- enough to deserve special treatment
-- | True of dyadic operators that can fail only if the second arg is zero! -- | True of dyadic operators that can fail only if the second arg is zero!
isDivOp :: PrimOp -> Bool isDivOp :: PrimOp -> Bool
-- This function probably belongs in PrimOp, or even in -- This function probably belongs in PrimOp, or even in
...@@ -782,6 +800,27 @@ If exprOkForSpeculation doesn't look through case expressions, you get this: ...@@ -782,6 +800,27 @@ If exprOkForSpeculation doesn't look through case expressions, you get this:
The inner case is redundant, and should be nuked. The inner case is redundant, and should be nuked.
Note [exprOkForSpeculation: 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
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.
Similarly, this is a valid program (albeit a slightly dodgy one)
let v = case x of { B -> ...; C -> ... }
in case x of
A -> ...
_ -> ...v...v....
But we don't want to speculate the v binding.
One could try to be clever, but the easy fix is simpy to regard
a non-exhaustive case as *not* okForSpeculation.
Note [dataToTag speculation] Note [dataToTag speculation]
~~~~~~~~~~~~~~~~~~~~~~~~~~~~ ~~~~~~~~~~~~~~~~~~~~~~~~~~~~
Is this OK? Is this OK?
......
...@@ -440,7 +440,9 @@ partitionByMajorLevel. ...@@ -440,7 +440,9 @@ partitionByMajorLevel.
\begin{code} \begin{code}
data FloatBind data FloatBind
= FloatLet FloatLet = FloatLet FloatLet
| FloatCase CoreExpr Id DataCon [Var] -- case e of y { C ys -> ... } | 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 FloatLet = CoreBind -- INVARIANT: a FloatLet is always lifted
type MajorEnv = M.IntMap MinorEnv -- Keyed by major level type MajorEnv = M.IntMap MinorEnv -- Keyed by major level
......
...@@ -341,12 +341,24 @@ lvlExpr ctxt_lvl env (_, AnnLet bind body) = do ...@@ -341,12 +341,24 @@ lvlExpr ctxt_lvl env (_, AnnLet bind body) = do
return (Let bind' body') return (Let bind' body')
lvlExpr ctxt_lvl env (_, AnnCase scrut@(scrut_fvs,_) case_bndr ty alts) lvlExpr ctxt_lvl env (_, AnnCase scrut@(scrut_fvs,_) case_bndr ty alts)
= do { scrut' <- lvlMFE True ctxt_lvl env scrut
; lvlCase ctxt_lvl env scrut_fvs scrut' case_bndr ty alts }
-------------------------------------------
lvlCase :: Level -- ctxt_lvl: Level of enclosing expression
-> LevelEnv -- Level of in-scope names/tyvars
-> VarSet -- Free vars of input scrutinee
-> LevelledExpr -- Processed scrutinee
-> Id -> Type -- Case binder and result type
-> [AnnAlt Id VarSet] -- Input alternatives
-> LvlM LevelledExpr -- Result expression
lvlCase ctxt_lvl env scrut_fvs scrut' case_bndr ty alts
| [(con@(DataAlt {}), bs, rhs)] <- alts | [(con@(DataAlt {}), bs, rhs)] <- alts
, exprOkForSpeculation (deAnnotate scrut) , exprOkForSpeculation scrut' -- See Note [Check the output scrutinee for okForSpec]
, not (isTopLvl dest_lvl) -- Can't have top-level cases , not (isTopLvl dest_lvl) -- Can't have top-level cases
= -- Float the case = -- See Note [Case floating]
do { scrut' <- lvlMFE True ctxt_lvl env scrut -- Always float the case if possible
; (rhs_env, (case_bndr':bs')) <- cloneVars env (case_bndr:bs) dest_lvl do { (rhs_env, (case_bndr':bs')) <- cloneVars env (case_bndr:bs) dest_lvl
-- We don't need to use extendCaseBndrLvlEnv here -- We don't need to use extendCaseBndrLvlEnv here
-- because we are floating the case outwards so -- because we are floating the case outwards so
-- no need to do the binder-swap thing -- no need to do the binder-swap thing
...@@ -355,8 +367,7 @@ lvlExpr ctxt_lvl env (_, AnnCase scrut@(scrut_fvs,_) case_bndr ty alts) ...@@ -355,8 +367,7 @@ lvlExpr ctxt_lvl env (_, AnnCase scrut@(scrut_fvs,_) case_bndr ty alts)
; return (Case scrut' (TB case_bndr' (FloatMe dest_lvl)) ty [alt']) } ; return (Case scrut' (TB case_bndr' (FloatMe dest_lvl)) ty [alt']) }
| otherwise -- Stays put | otherwise -- Stays put
= do { scrut' <- lvlMFE True ctxt_lvl env scrut = do { let case_bndr' = TB case_bndr bndr_spec
; let case_bndr' = TB case_bndr bndr_spec
alts_env = extendCaseBndrLvlEnv env scrut' case_bndr' alts_env = extendCaseBndrLvlEnv env scrut' case_bndr'
; alts' <- mapM (lvl_alt alts_env) alts ; alts' <- mapM (lvl_alt alts_env) alts
; return (Case scrut' case_bndr' ty alts') } ; return (Case scrut' case_bndr' ty alts') }
...@@ -374,51 +385,46 @@ lvlExpr ctxt_lvl env (_, AnnCase scrut@(scrut_fvs,_) case_bndr ty alts) ...@@ -374,51 +385,46 @@ lvlExpr ctxt_lvl env (_, AnnCase scrut@(scrut_fvs,_) case_bndr ty alts)
new_env = extendLvlEnv alts_env bs' new_env = extendLvlEnv alts_env bs'
\end{code} \end{code}
@lvlMFE@ is just like @lvlExpr@, except that it might let-bind Note [Floating cases]
the expression, so that it can itself be floated. ~~~~~~~~~~~~~~~~~~~~~
Consider this:
Note [Unlifted MFEs] data T a = MkT !a
~~~~~~~~~~~~~~~~~~~~ f :: T Int -> blah
We don't float unlifted MFEs, which potentially loses big opportunites. f x vs = case x of { MkT y ->
For example: let f vs = ...(case y of I# w -> e)...f..
\x -> f (h y) in f vs
where h :: Int -> Int# is expensive. We'd like to float the (h y) outside Here we can float the (case y ...) out , because y is sure
the \x, but we don't because it's unboxed. Possible solution: box it. to be evaluated, to give
f x vs = case x of { MkT y ->
Note [Bottoming floats] caes y of I# w ->
~~~~~~~~~~~~~~~~~~~~~~~ let f vs = ...(e)...f..
If we see in f vs
f = \x. g (error "urk")
we'd like to float the call to error, to get That saves unboxing it every time round the loop. It's important in
lvl = error "urk" some DPH stuff where we really want to avoid that repeated unboxing in
f = \x. g lvl the inner loop.
Furthermore, we want to float a bottoming expression even if it has free
variables: Things to note
f = \x. g (let v = h x in error ("urk" ++ v)) * We can't float a case to top level
Then we'd like to abstact over 'x' can float the whole arg of g: * It's worth doing this float even if we don't float
lvl = \x. let v = h x in error ("urk" ++ v) the case outside a value lambda
f = \x. g (lvl x) * We only do this with a single-alternative case
See Maessen's paper 1999 "Bottom extraction: factoring error handling out
of functional programs" (unpublished I think). Note [Check the output scrutinee for okForSpec]
~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~
When we do this, we set the strictness and arity of the new bottoming Consider this:
Id, so that it's properly exposed as such in the interface file, even if case x of y {
this is all happening after strictness analysis. A -> ....(case y of alts)....
}
Note [Bottoming floats: eta expansion] c.f Note [Bottoming floats] Because of the binder-swap, the inner case will get substituted to
~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~ (case x of ..). So when testing whether the scrutinee is
Tiresomely, though, the simplifier has an invariant that the manifest okForSpecuation we must be careful to test the *result* scrutinee ('x'
arity of the RHS should be the same as the arity; but we can't call in this case), not the *input* one 'y'. The latter *is* ok for
etaExpand during SetLevels because it works over a decorated form of speculation here, but the former is not -- and ideed we can't float
CoreExpr. So we do the eta expansion later, in FloatOut. the inner case out, at least not unless x is also evaluated at its
binding site.
Note [Case MFEs]
~~~~~~~~~~~~~~~~ That's why we apply exprOkForSpeculation to scrut' and not to scrut.
We don't float a case expression as an MFE from a strict context. Why not?
Because in doing so we share a tiny bit of computation (the switch) but
in exchange we build a thunk, which is bad. This case reduces allocation
by 7% in spectral/puzzle (a rather strange benchmark) and 1.2% in real/fem.
Doesn't change any other allocation at all.
\begin{code} \begin{code}
lvlMFE :: Bool -- True <=> strict context [body of case or let] lvlMFE :: Bool -- True <=> strict context [body of case or let]
...@@ -426,6 +432,8 @@ lvlMFE :: Bool -- True <=> strict context [body of case or let] ...@@ -426,6 +432,8 @@ lvlMFE :: Bool -- True <=> strict context [body of case or let]
-> LevelEnv -- Level of in-scope names/tyvars -> LevelEnv -- Level of in-scope names/tyvars
-> CoreExprWithFVs -- input expression -> CoreExprWithFVs -- input expression
-> LvlM LevelledExpr -- Result expression -> LvlM LevelledExpr -- Result expression
-- lvlMFE is just like lvlExpr, except that it might let-bind
-- the expression, so that it can itself be floated.
lvlMFE _ _ _ (_, AnnType ty) lvlMFE _ _ _ (_, AnnType ty)
= return (Type ty) = return (Type ty)
...@@ -491,7 +499,52 @@ lvlMFE strict_ctxt ctxt_lvl env ann_expr@(fvs, _) ...@@ -491,7 +499,52 @@ lvlMFE strict_ctxt ctxt_lvl env ann_expr@(fvs, _)
-- --
-- Also a strict contxt includes uboxed values, and they -- Also a strict contxt includes uboxed values, and they
-- can't be bound at top level -- can't be bound at top level
\end{code}
Note [Unlifted MFEs]
~~~~~~~~~~~~~~~~~~~~
We don't float unlifted MFEs, which potentially loses big opportunites.
For example:
\x -> f (h y)
where h :: Int -> Int# is expensive. We'd like to float the (h y) outside
the \x, but we don't because it's unboxed. Possible solution: box it.
Note [Bottoming floats]
~~~~~~~~~~~~~~~~~~~~~~~
If we see
f = \x. g (error "urk")
we'd like to float the call to error, to get
lvl = error "urk"
f = \x. g lvl
Furthermore, we want to float a bottoming expression even if it has free
variables:
f = \x. g (let v = h x in error ("urk" ++ v))
Then we'd like to abstact over 'x' can float the whole arg of g:
lvl = \x. let v = h x in error ("urk" ++ v)
f = \x. g (lvl x)
See Maessen's paper 1999 "Bottom extraction: factoring error handling out
of functional programs" (unpublished I think).
When we do this, we set the strictness and arity of the new bottoming
Id, so that it's properly exposed as such in the interface file, even if
this is all happening after strictness analysis.
Note [Bottoming floats: eta expansion] c.f Note [Bottoming floats]
~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~
Tiresomely, though, the simplifier has an invariant that the manifest
arity of the RHS should be the same as the arity; but we can't call
etaExpand during SetLevels because it works over a decorated form of
CoreExpr. So we do the eta expansion later, in FloatOut.
Note [Case MFEs]
~~~~~~~~~~~~~~~~
We don't float a case expression as an MFE from a strict context. Why not?
Because in doing so we share a tiny bit of computation (the switch) but
in exchange we build a thunk, which is bad. This case reduces allocation
by 7% in spectral/puzzle (a rather strange benchmark) and 1.2% in real/fem.
Doesn't change any other allocation at all.
\begin{code}
annotateBotStr :: Id -> Maybe (Arity, StrictSig) -> Id annotateBotStr :: Id -> Maybe (Arity, StrictSig) -> Id
annotateBotStr id Nothing = id annotateBotStr id Nothing = id
annotateBotStr id (Just (arity,sig)) = id `setIdArity` arity annotateBotStr id (Just (arity,sig)) = id `setIdArity` arity
......
...@@ -9,6 +9,14 @@ ...@@ -9,6 +9,14 @@
</para> </para>
<itemizedlist> <itemizedlist>
<listitem>
<para>
An optimiser bug
(<ulink url="http://hackage.haskell.org/trac/ghc/ticket/5453">#5453</ulink>)
which can cause segfaults has been fixed.
</para>
</listitem>
<listitem> <listitem>
<para> <para>
A native code generator bug A native code generator bug
......
0% Loading or .
You are about to add 0 people to the discussion. Proceed with caution.
Finish editing this message first!
Please register or to comment