Be even more careful about eta expansion when bottom is involved

See Note [Dealing with bottom], reproduced below.  Fixes Trac #5557.

3.  Note [Dealing with bottom]
~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~
Consider
	f = \x -> error "foo"
Here, arity 1 is fine.  But if it is
	f = \x -> case x of
			True  -> error "foo"
			False -> \y -> x+y
then we want to get arity 2.  Technically, this isn't quite right, because
	(f True) `seq` 1
should diverge, but it'll converge if we eta-expand f.  Nevertheless, we
do so; it improves some programs significantly, and increasing convergence
isn't a bad thing.  Hence the ABot/ATop in ArityType.

However, this really isn't always the Right Thing, and we have several
tickets reporting unexpected bahaviour resulting from this
transformation.  So we try to limit it as much as possible:

 * Do NOT move a lambda outside a known-bottom case expression
      case undefined of { (a,b) -> \y -> e }
   This showed up in Trac #5557

 * Do NOT move a lambda outside a case if all the branches of
   the case are known to return bottom.
      case x of { (a,b) -> \y -> error "urk" }
   This case is less important, but the idea is that if the fn is
   going to diverge eventually anyway then getting the best arity
   isn't an issue, so we might as well play safe

Of course both these are readily defeated by disguising the bottoms.

1 files changed, 31 insertions, 3 deletions

diff --git a/compiler/coreSyn/CoreArity.lhs b/compiler/coreSyn/CoreArity.lhs
index 431508b58b..a3acd47802 100644
--- a/compiler/coreSyn/CoreArity.lhs
+++ b/compiler/coreSyn/CoreArity.lhs
@@ -283,6 +283,23 @@ should diverge, but it'll converge if we eta-expand f.  Nevertheless, we
 do so; it improves some programs significantly, and increasing convergence
 isn't a bad thing.  Hence the ABot/ATop in ArityType.
 
+However, this really isn't always the Right Thing, and we have several
+tickets reporting unexpected bahaviour resulting from this
+transformation.  So we try to limit it as much as possible:
+
+ * Do NOT move a lambda outside a known-bottom case expression
+      case undefined of { (a,b) -> \y -> e }
+   This showed up in Trac #5557
+
+ * Do NOT move a lambda outside a case if all the branches of 
+   the case are known to return bottom.
+      case x of { (a,b) -> \y -> error "urk" }
+   This case is less important, but the idea is that if the fn is 
+   going to diverge eventually anyway then getting the best arity 
+   isn't an issue, so we might as well play safe
+
+Of course both these are readily defeated by disguising the bottoms.
+
 4. Note [Newtype arity]
 ~~~~~~~~~~~~~~~~~~~~~~~~
 Non-recursive newtypes are transparent, and should not get in the way.
@@ -575,9 +592,20 @@ arityType cheap_fn (App fun arg )
 	--  ===>
 	--	f x y = case x of { (a,b) -> e }
 	-- The difference is observable using 'seq'
-arityType cheap_fn (Case scrut bndr _ alts)
-  = floatIn (cheap_fn scrut (Just (idType bndr)))
-	    (foldr1 andArityType [arityType cheap_fn rhs | (_,_,rhs) <- alts])
+	--
+arityType cheap_fn (Case scrut _ _ alts)
+  | exprIsBottom scrut 
+  = ABot 0     -- Do not eta expand
+               -- See Note [Dealing with bottom]
+  | otherwise
+  = case alts_type of
+     ABot n  | n>0       -> ATop []    -- Don't eta expand 
+     	     | otherwise -> ABot 0     -- if RHS is bottomming
+    			               -- See Note [Dealing with bottom]
+     ATop as | exprIsTrivial scrut -> ATop as
+             | otherwise           -> ATop (takeWhile id as)	    
+  where
+    alts_type = foldr1 andArityType [arityType cheap_fn rhs | (_,_,rhs) <- alts]
 
 arityType cheap_fn (Let b e) 
   = floatIn (cheap_bind b) (arityType cheap_fn e)