Don't make join points when the case has only one non-bottom alternative

This fixes Trac #4930.  See Note [Bottom alternatives] in Simplify.lhs

diff --git a/compiler/coreSyn/CoreUtils.lhs b/compiler/coreSyn/CoreUtils.lhs
index 61bfd2e..2eedd33 100644 (file)
--- a/compiler/coreSyn/CoreUtils.lhs
+++ b/compiler/coreSyn/CoreUtils.lhs
@@ -25,7 +25,7 @@ module CoreUtils (
 
        -- * Properties of expressions
        exprType, coreAltType, coreAltsType,
-       exprIsDupable, exprIsTrivial, 
+       exprIsDupable, exprIsTrivial, exprIsBottom,
         exprIsCheap, exprIsExpandable, exprIsCheap', CheapAppFun,
        exprIsHNF, exprOkForSpeculation, exprIsBig, exprIsConLike,
        rhsIsStatic, isCheapApp, isExpandableApp,
@@ -424,6 +424,25 @@ exprIsTrivial (Lam b body)     = not (isRuntimeVar b) && exprIsTrivial body
 exprIsTrivial _                = False
 \end{code}
 
+exprIsBottom is a very cheap and cheerful function; it may return
+False for bottoming expressions, but it never costs much to ask.
+See also CoreArity.exprBotStrictness_maybe, but that's a bit more 
+expensive.
+
+\begin{code}
+exprIsBottom :: CoreExpr -> Bool
+exprIsBottom e 
+  = go 0 e
+  where
+    go n (Var v) = isBottomingId v &&  n >= idArity v 
+    go n (App e a) | isTypeArg a = go n e 
+                   | otherwise   = go (n+1) e 
+    go n (Note _ e)             = go n e     
+    go n (Cast e _)             = go n e
+    go n (Let _ e)              = go n e
+    go _ _                      = False
+\end{code}
+
 
 %************************************************************************
 %*                                                                     *

diff --git a/compiler/simplCore/Simplify.lhs b/compiler/simplCore/Simplify.lhs
index 6794e19..1f09bf5 100644 (file)
--- a/compiler/simplCore/Simplify.lhs
+++ b/compiler/simplCore/Simplify.lhs
@@ -1992,16 +1992,44 @@ missingAlt env case_bndr alts cont
 \begin{code}
 prepareCaseCont :: SimplEnv
                 -> [InAlt] -> SimplCont
-                -> SimplM (SimplEnv, SimplCont,SimplCont)
-                        -- Return a duplicatable continuation, a non-duplicable part
-                        -- plus some extra bindings (that scope over the entire
-                        -- continunation)
-
-        -- No need to make it duplicatable if there's only one alternative
-prepareCaseCont env [_] cont = return (env, cont, mkBoringStop)
-prepareCaseCont env _   cont = mkDupableCont env cont
+                -> SimplM (SimplEnv, SimplCont, SimplCont)
+-- We are considering
+--     K[case _ of { p1 -> r1; ...; pn -> rn }] 
+-- where K is some enclosing continuation for the case
+-- Goal: split K into two pieces Kdup,Knodup so that
+--      a) Kdup can be duplicated
+--      b) Knodup[Kdup[e]] = K[e]
+-- The idea is that we'll transform thus:
+--          Knodup[ (case _ of { p1 -> Kdup[r1]; ...; pn -> Kdup[rn] }
+--
+-- We also return some extra bindings in SimplEnv (that scope over 
+-- the entire continuation)
+
+prepareCaseCont env alts cont 
+  | many_alts alts = mkDupableCont env cont 
+  | otherwise      = return (env, cont, mkBoringStop)
+  where
+    many_alts :: [InAlt] -> Bool  -- True iff strictly > 1 non-bottom alternative
+    many_alts []  = False        -- See Note [Bottom alternatives]
+    many_alts [_] = False
+    many_alts (alt:alts) 
+      | is_bot_alt alt = many_alts alts   
+      | otherwise      = not (all is_bot_alt alts)
+  
+    is_bot_alt (_,_,rhs) = exprIsBottom rhs
 \end{code}
 
+Note [Bottom alternatives]
+~~~~~~~~~~~~~~~~~~~~~~~~~~
+When we have
+     case (case x of { A -> error .. ; B -> e; C -> error ..) 
+       of alts
+then we can just duplicate those alts because the A and C cases
+will disappear immediately.  This is more direct than creating
+join points and inlining them away; and in some cases we would
+not even create the join points (see Note [Single-alternative case])
+and we would keep the case-of-case which is silly.  See Trac #4930.
+
 \begin{code}
 mkDupableCont :: SimplEnv -> SimplCont
               -> SimplM (SimplEnv, SimplCont, SimplCont)