Allow cases with empty alterantives

This patch allows, for the first time, case expressions with an empty
list of alternatives. Max suggested the idea, and Trac #6067 showed
that it is really quite important.

So I've implemented the idea, fixing #6067. Main changes

 * See Note [Empty case alternatives] in CoreSyn

 * Various foldr1's become foldrs

 * IfaceCase does not record the type of the alternatives.
   I added IfaceECase for empty-alternative cases.

 * Core Lint does not complain about empty cases

 * MkCore.castBottomExpr constructs an empty-alternative case
   expression   (case e of ty {})

 * CoreToStg converts '(case e of {})' to just 'e'

18 files changed, 201 insertions, 106 deletions

diff --git a/compiler/coreSyn/CoreArity.lhs b/compiler/coreSyn/CoreArity.lhs
index 249861a4e4..7c392c48f2 100644
--- a/compiler/coreSyn/CoreArity.lhs
+++ b/compiler/coreSyn/CoreArity.lhs
@@ -663,7 +663,7 @@ arityType env (App fun arg )
 	-- The difference is observable using 'seq'
 	--
 arityType env (Case scrut _ _ alts)
-  | exprIsBottom scrut 
+  | exprIsBottom scrut || null alts
   = ABot 0     -- Do not eta expand
                -- See Note [Dealing with bottom (1)]
   | otherwise
@@ -829,14 +829,18 @@ etaInfoApp subst (Cast e co1) eis
   where
     co' = CoreSubst.substCo subst co1
 
-etaInfoApp subst (Case e b _ alts) eis 
-  = Case (subst_expr subst e) b1 (coreAltsType alts') alts'
+etaInfoApp subst (Case e b ty alts) eis 
+  = Case (subst_expr subst e) b1 (mk_alts_ty (CoreSubst.substTy subst ty) eis) alts'
   where
     (subst1, b1) = substBndr subst b
     alts' = map subst_alt alts
     subst_alt (con, bs, rhs) = (con, bs', etaInfoApp subst2 rhs eis) 
     	      where
 	      	 (subst2,bs') = substBndrs subst1 bs
+
+    mk_alts_ty ty []               = ty
+    mk_alts_ty ty (EtaVar v : eis) = mk_alts_ty (applyTypeToArg ty (varToCoreExpr v)) eis
+    mk_alts_ty _  (EtaCo co : eis) = mk_alts_ty (pSnd (coercionKind co)) eis
     
 etaInfoApp subst (Let b e) eis 
   = Let b' (etaInfoApp subst' e eis)
diff --git a/compiler/coreSyn/CoreFVs.lhs b/compiler/coreSyn/CoreFVs.lhs
index 369f1a308e..eb3cd5e948 100644
--- a/compiler/coreSyn/CoreFVs.lhs
+++ b/compiler/coreSyn/CoreFVs.lhs
@@ -486,7 +486,7 @@ freeVars (Case scrut bndr ty alts)
     scrut2 = freeVars scrut
 
     (alts_fvs_s, alts2) = mapAndUnzip fv_alt alts
-    alts_fvs            = foldr1 unionFVs alts_fvs_s
+    alts_fvs            = foldr unionFVs noFVs alts_fvs_s
 
     fv_alt (con,args,rhs) = (delBindersFV args (freeVarsOf rhs2),
                              (con, args, rhs2))
diff --git a/compiler/coreSyn/CoreLint.lhs b/compiler/coreSyn/CoreLint.lhs
index 4af5b1c143..41b0f3bd2f 100644
--- a/compiler/coreSyn/CoreLint.lhs
+++ b/compiler/coreSyn/CoreLint.lhs
@@ -498,9 +498,6 @@ checkCaseAlts :: CoreExpr -> OutType -> [CoreAlt] -> LintM ()
 --     the simplifer correctly eliminates case that can't 
 --     possibly match.
 
-checkCaseAlts e _ []
-  = addErrL (mkNullAltsMsg e)
-
 checkCaseAlts e ty alts = 
   do { checkL (all non_deflt con_alts) (mkNonDefltMsg e)
      ; checkL (increasing_tag con_alts) (mkNonIncreasingAltsMsg e)
@@ -1116,11 +1113,6 @@ pp_binder b | isId b    = hsep [ppr b, dcolon, ppr (idType b)]
 ------------------------------------------------------
 --	Messages for case expressions
 
-mkNullAltsMsg :: CoreExpr -> MsgDoc
-mkNullAltsMsg e 
-  = hang (text "Case expression with no alternatives:")
-	 4 (ppr e)
-
 mkDefaultArgsMsg :: [Var] -> MsgDoc
 mkDefaultArgsMsg args 
   = hang (text "DEFAULT case with binders")
diff --git a/compiler/coreSyn/CoreSyn.lhs b/compiler/coreSyn/CoreSyn.lhs
index 4faad7fc25..29fe407e50 100644
--- a/compiler/coreSyn/CoreSyn.lhs
+++ b/compiler/coreSyn/CoreSyn.lhs
@@ -221,7 +221,8 @@ These data types are the heart of the compiler
 --    This is one of the more complicated elements of the Core language, 
 --    and comes with a number of restrictions:
 --    
---    1. The list of alternatives is non-empty
+--    1. The list of alternatives may be empty; 
+--       See Note [Empty case alternatives]
 --
 --    2. The 'DEFAULT' case alternative must be first in the list, 
 --       if it occurs at all.
@@ -338,11 +339,59 @@ Note [CoreSyn let goal]
   application, its arguments are trivial, so that the constructor can be
   inlined vigorously.
 
-
 Note [Type let]
 ~~~~~~~~~~~~~~~
 See #type_let#
 
+Note [Empty case alternatives]
+~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~
+The alternatives of a case expression should be exhaustive.  A case expression
+can have empty alternatives if (and only if) the scrutinee is bound to raise
+an exception or diverge.  So:
+   Case (error Int "Hello") b Bool []
+is fine, and has type Bool.  This is one reason we need a type on 
+the case expression: if the alternatives are empty we can't get the type
+from the alternatives!  I'll write this
+   case (error Int "Hello") of Bool {}
+with the return type just before the alterantives.
+
+Here's another example:
+  data T
+  f :: T -> Bool
+  f = \(x:t). case x of Bool {}
+Since T has no data constructors, the case alterantives are of course
+empty.  However note that 'x' is not bound to a visbily-bottom value;
+it's the *type* that tells us it's going to diverge.  Its a bit of a
+degnerate situation but we do NOT want to replace
+   case x of Bool {}   -->   error Bool "Inaccessible case"
+because x might raise an exception, and *that*'s what we want to see!
+(Trac #6067 is an example.) To preserve semantics we'd have to say
+   x `seq` error Bool "Inaccessible case"   
+ but the 'seq' is just a case, so we are back to square 1.  Or I suppose
+we could say
+   x |> UnsafeCoerce T Bool
+but that loses all trace of the fact that this originated with an empty
+set of alternatives.
+
+We can use the empty-alternative construct to coerce error values from
+one type to another.  For example
+
+    f :: Int -> Int
+    f n = error "urk"
+   
+    g :: Int -> (# Char, Bool #)
+    g x = case f x of { 0 -> ..., n -> ... }
+
+Then if we inline f in g's RHS we get
+    case (error Int "urk") of (# Char, Bool #) { ... }
+and we can discard the alternatives since the scrutinee is bottom to give
+    case (error Int "urk") of (# Char, Bool #) {}
+
+This is nicer than using an unsafe coerce between Int ~ (# Char,Bool #),
+if for no other reason that we don't need to instantiate the (~) at an 
+unboxed type.
+
+
 %************************************************************************
 %*									*
               Ticks
diff --git a/compiler/coreSyn/CoreUnfold.lhs b/compiler/coreSyn/CoreUnfold.lhs
index 8d46b7e9cf..4529dba20d 100644
--- a/compiler/coreSyn/CoreUnfold.lhs
+++ b/compiler/coreSyn/CoreUnfold.lhs
@@ -391,8 +391,8 @@ sizeExpr bOMB_OUT_SIZE top_args expr
 
     size_up (Case (Var v) _ _ alts) 
 	| v `elem` top_args		-- We are scrutinising an argument variable
-	= alts_size (foldr1 addAltSize alt_sizes)
-		    (foldr1 maxSize alt_sizes)
+	= alts_size (foldr addAltSize sizeZero alt_sizes)
+		    (foldr maxSize    sizeZero alt_sizes)
 		-- Good to inline if an arg is scrutinised, because
 		-- that may eliminate allocation in the caller
 		-- And it eliminates the case itself
diff --git a/compiler/coreSyn/MkCore.lhs b/compiler/coreSyn/MkCore.lhs
index 9e42290f7e..53386fec02 100644
--- a/compiler/coreSyn/MkCore.lhs
+++ b/compiler/coreSyn/MkCore.lhs
@@ -13,7 +13,7 @@ module MkCore (
         mkCoreApp, mkCoreApps, mkCoreConApps,
         mkCoreLams, mkWildCase, mkIfThenElse,
         mkWildValBinder, mkWildEvBinder,
-        sortQuantVars,
+        sortQuantVars, castBottomExpr,
         
         -- * Constructing boxed literals
         mkWordExpr, mkWordExprWord,
@@ -209,6 +209,16 @@ mkIfThenElse guard then_expr else_expr
   = mkWildCase guard boolTy (exprType then_expr) 
 	 [ (DataAlt falseDataCon, [], else_expr),	-- Increasing order of tag!
     	   (DataAlt trueDataCon,  [], then_expr) ]
+
+castBottomExpr :: CoreExpr -> Type -> CoreExpr
+-- (castBottomExpr e ty), assuming that 'e' diverges, 
+-- return an expression of type 'ty'
+-- See Note [Empty case alternatives] in CoreSyn
+castBottomExpr e res_ty
+  | e_ty `eqType` res_ty = e
+  | otherwise            = Case e (mkWildValBinder e_ty) res_ty []
+  where
+    e_ty = exprType e
 \end{code}
 
 The functions from this point don't really do anything cleverer than
diff --git a/compiler/iface/BinIface.hs b/compiler/iface/BinIface.hs
index eff699fd6b..3ef6d0998a 100644
--- a/compiler/iface/BinIface.hs
+++ b/compiler/iface/BinIface.hs
@@ -1124,6 +1124,10 @@ instance Binary IfaceExpr where
         putByte bh 12
         put_ bh ie
         put_ bh ico
+    put_ bh (IfaceECase a b) = do
+        putByte bh 13
+        put_ bh a
+        put_ bh b
     get bh = do
         h <- getByte bh
         case h of
@@ -1162,6 +1166,9 @@ instance Binary IfaceExpr where
             12 -> do ie <- get bh
                      ico <- get bh
                      return (IfaceCast ie ico)
+            13 -> do a <- get bh
+                     b <- get bh
+                     return (IfaceECase a b)
             _ -> panic ("get IfaceExpr " ++ show h)
 
 instance Binary IfaceConAlt where
diff --git a/compiler/iface/IfaceSyn.lhs b/compiler/iface/IfaceSyn.lhs
index d3e44fe54f..b53398da7d 100644
--- a/compiler/iface/IfaceSyn.lhs
+++ b/compiler/iface/IfaceSyn.lhs
@@ -249,6 +249,7 @@ data IfaceExpr
   | IfaceLam 	IfaceBndr IfaceExpr
   | IfaceApp 	IfaceExpr IfaceExpr
   | IfaceCase	IfaceExpr IfLclName [IfaceAlt]
+  | IfaceECase  IfaceExpr IfaceType     -- See Note [Empty case alternatives]
   | IfaceLet	IfaceBinding  IfaceExpr
   | IfaceCast   IfaceExpr IfaceCoercion
   | IfaceLit    Literal
@@ -279,6 +280,12 @@ data IfaceBinding
 data IfaceLetBndr = IfLetBndr IfLclName IfaceType IfaceIdInfo
 \end{code}
 
+Note [Empty case alternatives]
+~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~
+In IfaceSyn an IfaceCase does not record the types of the alternatives,
+unlike CorSyn Case.  But we need this type if the alternatives are empty.
+Hence IfaceECase.  See Note [Empty case alternatives] in CoreSyn.
+
 Note [Expose recursive functions]
 ~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~
 For supercompilation we want to put *all* unfoldings in the interface
@@ -621,6 +628,11 @@ pprIfaceExpr add_par i@(IfaceLam _ _)
     collect bs (IfaceLam b e) = collect (b:bs) e
     collect bs e              = (reverse bs, e)
 
+pprIfaceExpr add_par (IfaceECase scrut ty)
+  = add_par (sep [ ptext (sLit "case") <+> pprIfaceExpr noParens scrut 
+                 , ptext (sLit "ret_ty") <+> pprParendIfaceType ty
+                 , ptext (sLit "of {}") ])
+
 pprIfaceExpr add_par (IfaceCase scrut bndr [(con, bs, rhs)])
   = add_par (sep [ptext (sLit "case") 
 			<+> pprIfaceExpr noParens scrut <+> ptext (sLit "of") 
@@ -856,7 +868,7 @@ freeNamesIfExpr (IfaceLam b body) = freeNamesIfBndr b &&& freeNamesIfExpr body
 freeNamesIfExpr (IfaceApp f a)    = freeNamesIfExpr f &&& freeNamesIfExpr a
 freeNamesIfExpr (IfaceCast e co)  = freeNamesIfExpr e &&& freeNamesIfType co
 freeNamesIfExpr (IfaceTick _ e)   = freeNamesIfExpr e
-
+freeNamesIfExpr (IfaceECase e ty) = freeNamesIfExpr e &&& freeNamesIfType ty
 freeNamesIfExpr (IfaceCase s _ alts)
   = freeNamesIfExpr s 
     &&& fnList fn_alt alts &&& fn_cons alts
diff --git a/compiler/iface/MkIface.lhs b/compiler/iface/MkIface.lhs
index 3c8050cff2..0ccab30ae5 100644
--- a/compiler/iface/MkIface.lhs
+++ b/compiler/iface/MkIface.lhs
@@ -1767,7 +1767,9 @@ toIfaceExpr (Type ty)       = IfaceType (toIfaceType ty)
 toIfaceExpr (Coercion co)   = IfaceCo   (coToIfaceType co)
 toIfaceExpr (Lam x b)       = IfaceLam (toIfaceBndr x) (toIfaceExpr b)
 toIfaceExpr (App f a)       = toIfaceApp f [a]
-toIfaceExpr (Case s x _ as) = IfaceCase (toIfaceExpr s) (getFS x) (map toIfaceAlt as)
+toIfaceExpr (Case s x ty as) 
+  | null as                 = IfaceECase (toIfaceExpr s) (toIfaceType ty)
+  | otherwise               = IfaceCase (toIfaceExpr s) (getFS x) (map toIfaceAlt as)
 toIfaceExpr (Let b e)       = IfaceLet (toIfaceBind b) (toIfaceExpr e)
 toIfaceExpr (Cast e co)     = IfaceCast (toIfaceExpr e) (coToIfaceType co)
 toIfaceExpr (Tick t e)    = IfaceTick (toIfaceTickish t) (toIfaceExpr e)
diff --git a/compiler/iface/TcIface.lhs b/compiler/iface/TcIface.lhs
index aad352f1a5..e7360dc935 100644
--- a/compiler/iface/TcIface.lhs
+++ b/compiler/iface/TcIface.lhs
@@ -32,6 +32,7 @@ import CoreUtils
 import CoreUnfold
 import CoreLint
 import WorkWrap
+import MkCore( castBottomExpr )
 import Id
 import MkId
 import IdInfo
@@ -1019,6 +1020,11 @@ tcIfaceExpr (IfaceLam bndr body)
 tcIfaceExpr (IfaceApp fun arg)
   = App <$> tcIfaceExpr fun <*> tcIfaceExpr arg
 
+tcIfaceExpr (IfaceECase scrut ty) 
+  = do { scrut' <- tcIfaceExpr scrut 
+       ; ty' <- tcIfaceType ty
+       ; return (castBottomExpr scrut' ty') }
+
 tcIfaceExpr (IfaceCase scrut case_bndr alts)  = do
     scrut' <- tcIfaceExpr scrut
     case_bndr_name <- newIfaceName (mkVarOccFS case_bndr)
diff --git a/compiler/simplCore/OccurAnal.lhs b/compiler/simplCore/OccurAnal.lhs
index 95a473e2ae..e9ec0bea55 100644
--- a/compiler/simplCore/OccurAnal.lhs
+++ b/compiler/simplCore/OccurAnal.lhs
@@ -1252,7 +1252,7 @@ occAnal env (Case scrut bndr ty alts)
   = case occ_anal_scrut scrut alts     of { (scrut_usage, scrut') ->
     case mapAndUnzip occ_anal_alt alts of { (alts_usage_s, alts')   ->
     let
-        alts_usage  = foldr1 combineAltsUsageDetails alts_usage_s
+        alts_usage  = foldr combineAltsUsageDetails emptyDetails alts_usage_s
         (alts_usage1, tagged_bndr) = tag_case_bndr alts_usage bndr
         total_usage = scrut_usage +++ alts_usage1
     in
diff --git a/compiler/simplCore/SimplCore.lhs b/compiler/simplCore/SimplCore.lhs
index daadcb7988..0ebde64d6f 100644
--- a/compiler/simplCore/SimplCore.lhs
+++ b/compiler/simplCore/SimplCore.lhs
@@ -581,11 +581,11 @@ simplifyPgmIO pass@(CoreDoSimplify max_iterations mode)
         -- about to begin, with '1' for the first
       | iteration_no > max_iterations   -- Stop if we've run out of iterations
       = WARN( debugIsOn && (max_iterations > 2)
-            , ptext (sLit "Simplifier baling out after") <+> int max_iterations
-              <+> ptext (sLit "iterations")
-              <+> (brackets $ hsep $ punctuate comma $
-                   map (int . simplCountN) (reverse counts_so_far))
-              <+> ptext (sLit "Size =") <+> ppr (coreBindsStats binds) )
+            , hang (ptext (sLit "Simplifier baling out after") <+> int max_iterations
+                    <+> ptext (sLit "iterations")
+                    <+> (brackets $ hsep $ punctuate comma $
+                         map (int . simplCountN) (reverse counts_so_far)))
+                 2 (ptext (sLit "Size =") <+> ppr (coreBindsStats binds)))
 
                 -- Subtract 1 from iteration_no to get the
                 -- number of iterations we actually completed
diff --git a/compiler/simplCore/SimplUtils.lhs b/compiler/simplCore/SimplUtils.lhs
index 7bb4289cd3..5ec3276640 100644
--- a/compiler/simplCore/SimplUtils.lhs
+++ b/compiler/simplCore/SimplUtils.lhs
@@ -115,8 +115,8 @@ data SimplCont
 	SimplCont
 
   | Select   		-- case C of alts
-	DupFlag 	        -- See Note [DupFlag invariants]
-	InId [InAlt] StaticEnv	-- The case binder, alts, and subst-env
+	DupFlag 	                -- See Note [DupFlag invariants]
+	InId InType [InAlt] StaticEnv	-- The case binder, alts type, alts, and subst-env
 	SimplCont
 
   -- The two strict forms have no DupFlag, because we never duplicate them
@@ -157,15 +157,15 @@ addArgTo :: ArgInfo -> OutExpr -> ArgInfo
 addArgTo ai arg = ai { ai_args = arg : ai_args ai }
 
 instance Outputable SimplCont where
-  ppr (Stop interesting)    	     = ptext (sLit "Stop") <> brackets (ppr interesting)
-  ppr (ApplyTo dup arg _ cont)       = ((ptext (sLit "ApplyTo") <+> ppr dup <+> pprParendExpr arg)
-					  {-  $$ nest 2 (pprSimplEnv se) -}) $$ ppr cont
-  ppr (StrictBind b _ _ _ cont)      = (ptext (sLit "StrictBind") <+> ppr b) $$ ppr cont
-  ppr (StrictArg ai _ cont)          = (ptext (sLit "StrictArg") <+> ppr (ai_fun ai)) $$ ppr cont
-  ppr (Select dup bndr alts se cont) = (ptext (sLit "Select") <+> ppr dup <+> ppr bndr) $$ 
-				       (nest 2 $ vcat [ppr (seTvSubst se), ppr alts]) $$ ppr cont 
-  ppr (CoerceIt co cont)	     = (ptext (sLit "CoerceIt") <+> ppr co) $$ ppr cont
-  ppr (TickIt t cont)                = (ptext (sLit "TickIt") <+> ppr t) $$ ppr cont
+  ppr (Stop interesting)    	       = ptext (sLit "Stop") <> brackets (ppr interesting)
+  ppr (ApplyTo dup arg _ cont)         = ((ptext (sLit "ApplyTo") <+> ppr dup <+> pprParendExpr arg)
+				       	  {-  $$ nest 2 (pprSimplEnv se) -}) $$ ppr cont
+  ppr (StrictBind b _ _ _ cont)        = (ptext (sLit "StrictBind") <+> ppr b) $$ ppr cont
+  ppr (StrictArg ai _ cont)            = (ptext (sLit "StrictArg") <+> ppr (ai_fun ai)) $$ ppr cont
+  ppr (Select dup bndr ty alts se cont) = (ptext (sLit "Select") <+> ppr dup <+> ppr bndr <+> ppr ty) $$ 
+				         (nest 2 $ vcat [ppr (seTvSubst se), ppr alts]) $$ ppr cont 
+  ppr (CoerceIt co cont)	       = (ptext (sLit "CoerceIt") <+> ppr co) $$ ppr cont
+  ppr (TickIt t cont)                  = (ptext (sLit "TickIt") <+> ppr t) $$ ppr cont
 
 data DupFlag = NoDup       -- Unsimplified, might be big
              | Simplified  -- Simplified
@@ -211,11 +211,11 @@ contIsRhsOrArg _               = False
 
 -------------------
 contIsDupable :: SimplCont -> Bool
-contIsDupable (Stop {})                  = True
-contIsDupable (ApplyTo  OkToDup _ _ _)   = True	-- See Note [DupFlag invariants]
-contIsDupable (Select   OkToDup _ _ _ _) = True -- ...ditto...
-contIsDupable (CoerceIt _ cont)          = contIsDupable cont
-contIsDupable _                          = False
+contIsDupable (Stop {})                    = True
+contIsDupable (ApplyTo  OkToDup _ _ _)     = True	-- See Note [DupFlag invariants]
+contIsDupable (Select   OkToDup _ _ _ _ _) = True -- ...ditto...
+contIsDupable (CoerceIt _ cont)            = contIsDupable cont
+contIsDupable _                            = False
 
 -------------------
 contIsTrivial :: SimplCont -> Bool
@@ -237,7 +237,7 @@ contResultType env ty cont
     go (CoerceIt co cont)             _  = go cont (pSnd (coercionKind co))
     go (StrictBind _ bs body se cont) _  = go cont (subst_ty se (exprType (mkLams bs body)))
     go (StrictArg ai _ cont)          _  = go cont (funResultTy (argInfoResultTy ai))
-    go (Select _ _ alts se cont)      _  = go cont (subst_ty se (coreAltsType alts))
+    go (Select _ _ ty _ se cont)      _  = go cont (subst_ty se ty)
     go (ApplyTo _ arg se cont)        ty = go cont (apply_to_arg ty arg se)
     go (TickIt _ cont)                ty = go cont ty
 
@@ -328,7 +328,7 @@ interestingCallContext :: SimplCont -> CallCtxt
 interestingCallContext cont
   = interesting cont
   where
-    interesting (Select _ bndr _ _ _)
+    interesting (Select _ bndr _ _ _ _)
 	| isDeadBinder bndr = CaseCtxt
 	| otherwise	    = ArgCtxt False	-- If the binder is used, this
 						-- is like a strict let
@@ -1589,14 +1589,14 @@ and similarly in cascade for all the join points!
 mkCase, mkCase1, mkCase2 
    :: DynFlags 
    -> OutExpr -> OutId
-   -> [OutAlt]		-- Alternatives in standard (increasing) order
+   -> OutType -> [OutAlt]		-- Alternatives in standard (increasing) order
    -> SimplM OutExpr
 
 --------------------------------------------------
 --	1. Merge Nested Cases
 --------------------------------------------------
 
-mkCase dflags scrut outer_bndr ((DEFAULT, _, deflt_rhs) : outer_alts)
+mkCase dflags scrut outer_bndr alts_ty ((DEFAULT, _, deflt_rhs) : outer_alts)
   | dopt Opt_CaseMerge dflags
   , Case (Var inner_scrut_var) inner_bndr _ inner_alts <- deflt_rhs
   , inner_scrut_var == outer_bndr
@@ -1622,7 +1622,7 @@ mkCase dflags scrut outer_bndr ((DEFAULT, _, deflt_rhs) : outer_alts)
 		-- When we merge, we must ensure that e1 takes 
 		-- precedence over e2 as the value for A!  
 
-	; mkCase1 dflags scrut outer_bndr merged_alts
+	; mkCase1 dflags scrut outer_bndr alts_ty merged_alts
 	}
     	-- Warning: don't call mkCase recursively!
     	-- Firstly, there's no point, because inner alts have already had
@@ -1630,13 +1630,13 @@ mkCase dflags scrut outer_bndr ((DEFAULT, _, deflt_rhs) : outer_alts)
     	-- Secondly, if you do, you get an infinite loop, because the bindCaseBndr
     	-- in munge_rhs may put a case into the DEFAULT branch!
 
-mkCase dflags scrut bndr alts = mkCase1 dflags scrut bndr alts
+mkCase dflags scrut bndr alts_ty alts = mkCase1 dflags scrut bndr alts_ty alts
 
 --------------------------------------------------
 --	2. Eliminate Identity Case
 --------------------------------------------------
 
-mkCase1 _dflags scrut case_bndr alts	-- Identity case
+mkCase1 _dflags scrut case_bndr _ alts	-- Identity case
   | all identity_alt alts
   = do { tick (CaseIdentity case_bndr)
        ; return (re_cast scrut rhs1) }
@@ -1673,24 +1673,24 @@ mkCase1 _dflags scrut case_bndr alts	-- Identity case
 --------------------------------------------------
 --	3. Merge Identical Alternatives
 --------------------------------------------------
-mkCase1 dflags scrut case_bndr ((_con1,bndrs1,rhs1) : con_alts)
+mkCase1 dflags scrut case_bndr alts_ty ((_con1,bndrs1,rhs1) : con_alts)
   | all isDeadBinder bndrs1			-- Remember the default 
   , length filtered_alts < length con_alts	-- alternative comes first
 	-- Also Note [Dead binders]
   = do	{ tick (AltMerge case_bndr)
-	; mkCase2 dflags scrut case_bndr alts' }
+	; mkCase2 dflags scrut case_bndr alts_ty alts' }
   where
     alts' = (DEFAULT, [], rhs1) : filtered_alts
     filtered_alts	  = filter keep con_alts
     keep (_con,bndrs,rhs) = not (all isDeadBinder bndrs && rhs `cheapEqExpr` rhs1)
 
-mkCase1 dflags scrut bndr alts = mkCase2 dflags scrut bndr alts
+mkCase1 dflags scrut bndr alts_ty alts = mkCase2 dflags scrut bndr alts_ty alts
 
 --------------------------------------------------
 --	Catch-all
 --------------------------------------------------
-mkCase2 _dflags scrut bndr alts 
-  = return (Case scrut bndr (coreAltsType alts) alts)
+mkCase2 _dflags scrut bndr alts_ty alts 
+  = return (Case scrut bndr alts_ty alts)
 \end{code}
 
 Note [Dead binders]
diff --git a/compiler/simplCore/Simplify.lhs b/compiler/simplCore/Simplify.lhs
index 335f86a549..8b361b0bc9 100644
--- a/compiler/simplCore/Simplify.lhs
+++ b/compiler/simplCore/Simplify.lhs
@@ -24,7 +24,7 @@ import FamInstEnv	( FamInstEnv )
 import Literal		( litIsLifted )
 import Id
 import MkId		( seqId, realWorldPrimId )
-import MkCore		( mkImpossibleExpr )
+import MkCore		( mkImpossibleExpr, castBottomExpr )
 import IdInfo
 import Name		( mkSystemVarName, isExternalName )
 import Coercion hiding  ( substCo, substTy, substCoVar, extendTvSubst )
@@ -941,16 +941,16 @@ simplExprF1 env expr@(Lam {}) cont
     zap b | isTyVar b = b
           | otherwise = zapLamIdInfo b
 
-simplExprF1 env (Case scrut bndr _ alts) cont
+simplExprF1 env (Case scrut bndr ty alts) cont
   | sm_case_case (getMode env)
   =     -- Simplify the scrutinee with a Select continuation
-    simplExprF env scrut (Select NoDup bndr alts env cont)
+    simplExprF env scrut (Select NoDup bndr ty alts env cont)
 
   | otherwise
   =     -- If case-of-case is off, simply simplify the case expression
         -- in a vanilla Stop context, and rebuild the result around it
     do  { case_expr' <- simplExprC env scrut
-                             (Select NoDup bndr alts env mkBoringStop)
+                             (Select NoDup bndr ty alts env mkBoringStop)
         ; rebuild env case_expr' cont }
 
 simplExprF1 env (Let (Rec pairs) body) cont
@@ -1035,7 +1035,7 @@ simplTick env tickish expr cont
 
  where
   interesting_cont = case cont of
-                        Select _ _ _ _ _ -> True
+                        Select {} -> True
                         _ -> False
 
   push_tick_inside t expr0
@@ -1157,18 +1157,18 @@ rebuild :: SimplEnv -> OutExpr -> SimplCont -> SimplM (SimplEnv, OutExpr)
 -- only the in-scope set and floats should matter
 rebuild env expr cont
   = case cont of
-      Stop {}                      -> return (env, expr)
-      CoerceIt co cont             -> rebuild env (mkCast expr co) cont 
-                                   -- NB: mkCast implements the (Coercion co |> g) optimisation
-      Select _ bndr alts se cont   -> rebuildCase (se `setFloats` env) expr bndr alts cont
-      StrictArg info _ cont        -> rebuildCall env (info `addArgTo` expr) cont
-      StrictBind b bs body se cont -> do { env' <- simplNonRecX (se `setFloats` env) b expr
-                                         ; simplLam env' bs body cont }
-      ApplyTo dup_flag arg se cont -- See Note [Avoid redundant simplification]
-        | isSimplified dup_flag    -> rebuild env (App expr arg) cont
-        | otherwise                -> do { arg' <- simplExpr (se `setInScope` env) arg
-                                         ; rebuild env (App expr arg') cont }
-      TickIt t cont                -> rebuild env (mkTick t expr) cont
+      Stop {}                       -> return (env, expr)
+      CoerceIt co cont              -> rebuild env (mkCast expr co) cont 
+                                    -- NB: mkCast implements the (Coercion co |> g) optimisation
+      Select _ bndr ty alts se cont -> rebuildCase (se `setFloats` env) expr bndr ty alts cont
+      StrictArg info _ cont         -> rebuildCall env (info `addArgTo` expr) cont
+      StrictBind b bs body se cont  -> do { env' <- simplNonRecX (se `setFloats` env) b expr
+                                          ; simplLam env' bs body cont }
+      ApplyTo dup_flag arg se cont  -- See Note [Avoid redundant simplification]
+        | isSimplified dup_flag     -> rebuild env (App expr arg) cont
+        | otherwise                 -> do { arg' <- simplExpr (se `setInScope` env) arg
+                                          ; rebuild env (App expr arg') cont }
+      TickIt t cont                 -> rebuild env (mkTick t expr) cont
 \end{code}
 
 
@@ -1437,14 +1437,10 @@ rebuildCall env (ArgInfo { ai_fun = fun, ai_args = rev_args, ai_strs = [] }) con
   -- the continuation, leaving just the bottoming expression.  But the
   -- type might not be right, so we may have to add a coerce.
   | not (contIsTrivial cont)     -- Only do this if there is a non-trivial
-  = return (env, mk_coerce res)  -- contination to discard, else we do it
-  where                          -- again and again!
+  = return (env, castBottomExpr res cont_ty)  -- contination to discard, else we do it
+  where                                       -- again and again!
     res     = mkApps (Var fun) (reverse rev_args)
-    res_ty  = exprType res
-    cont_ty = contResultType env res_ty cont
-    co      = mkUnsafeCo res_ty cont_ty
-    mk_coerce expr | cont_ty `eqType` res_ty = expr
-                   | otherwise = mkCast expr co
+    cont_ty = contResultType env (exprType res) cont
 
 rebuildCall env info (ApplyTo dup_flag (Type arg_ty) se cont)
   = do { arg_ty' <- if isSimplified dup_flag then return arg_ty
@@ -1732,6 +1728,7 @@ rebuildCase, reallyRebuildCase
    :: SimplEnv
    -> OutExpr          -- Scrutinee
    -> InId             -- Case binder
+   -> InType           -- Type of alternatives
    -> [InAlt]          -- Alternatives (inceasing order)
    -> SimplCont
    -> SimplM (SimplEnv, OutExpr)
@@ -1740,7 +1737,7 @@ rebuildCase, reallyRebuildCase
 --      1. Eliminate the case if there's a known constructor
 --------------------------------------------------
 
-rebuildCase env scrut case_bndr alts cont
+rebuildCase env scrut case_bndr _ alts cont
   | Lit lit <- scrut    -- No need for same treatment as constructors
                         -- because literals are inlined more vigorously
   , not (litIsLifted lit)
@@ -1769,7 +1766,7 @@ rebuildCase env scrut case_bndr alts cont
 --      2. Eliminate the case if scrutinee is evaluated
 --------------------------------------------------
 
-rebuildCase env scrut case_bndr [(_, bndrs, rhs)] cont
+rebuildCase env scrut case_bndr _ [(_, bndrs, rhs)] cont
   -- See if we can get rid of the case altogether
   -- See Note [Case elimination] 
   -- mkCase made sure that if all the alternatives are equal,
@@ -1819,7 +1816,7 @@ rebuildCase env scrut case_bndr [(_, bndrs, rhs)] cont
 --      3. Try seq rules; see Note [User-defined RULES for seq] in MkId
 --------------------------------------------------
 
-rebuildCase env scrut case_bndr alts@[(_, bndrs, rhs)] cont
+rebuildCase env scrut case_bndr alts_ty alts@[(_, bndrs, rhs)] cont
   | all isDeadBinder (case_bndr : bndrs)  -- So this is just 'seq'
   = do { let rhs' = substExpr (text "rebuild-case") env rhs
              out_args = [Type (substTy env (idType case_bndr)), 
@@ -1832,33 +1829,30 @@ rebuildCase env scrut case_bndr alts@[(_, bndrs, rhs)] cont
            Just (n_args, res) -> simplExprF (zapSubstEnv env) 
 	   	       		    	    (mkApps res (drop n_args out_args))
                                             cont
-	   Nothing -> reallyRebuildCase env scrut case_bndr alts cont }
+	   Nothing -> reallyRebuildCase env scrut case_bndr alts_ty alts cont }
 
-rebuildCase env scrut case_bndr alts cont
-  = reallyRebuildCase env scrut case_bndr alts cont
+rebuildCase env scrut case_bndr alts_ty alts cont
+  = reallyRebuildCase env scrut case_bndr alts_ty alts cont
 
 --------------------------------------------------
 --      3. Catch-all case
 --------------------------------------------------
 
-reallyRebuildCase env scrut case_bndr alts cont
+reallyRebuildCase env scrut case_bndr alts_ty alts cont
   = do  {       -- Prepare the continuation;
                 -- The new subst_env is in place
           (env', dup_cont, nodup_cont) <- prepareCaseCont env alts cont
 
         -- Simplify the alternatives
-        ; (scrut', case_bndr', alts') <- simplAlts env' scrut case_bndr alts dup_cont
+        ; (scrut', case_bndr', alts_ty', alts') <- simplAlts env' scrut case_bndr alts_ty alts dup_cont
 
-	-- Check for empty alternatives
-	; if null alts' then missingAlt env case_bndr alts cont
-	  else do
-        { dflags <- getDynFlags
-        ; case_expr <- mkCase dflags scrut' case_bndr' alts'
+        ; dflags <- getDynFlags
+        ; case_expr <- mkCase dflags scrut' case_bndr' alts_ty' alts'
 
 	-- Notice that rebuild gets the in-scope set from env', not alt_env
 	-- (which in any case is only build in simplAlts)
 	-- The case binder *not* scope over the whole returned case-expression
-	; rebuild env' case_expr nodup_cont } }
+	; rebuild env' case_expr nodup_cont }
 \end{code}
 
 simplCaseBinder checks whether the scrutinee is a variable, v.  If so,
@@ -1941,16 +1935,19 @@ robust here.  (Otherwise, there's a danger that we'll simply drop the
 simplAlts :: SimplEnv
           -> OutExpr
           -> InId                       -- Case binder
+          -> InType
           -> [InAlt]			-- Non-empty
 	  -> SimplCont
-          -> SimplM (OutExpr, OutId, [OutAlt])  -- Includes the continuation
+          -> SimplM (OutExpr, OutId, OutType, [OutAlt])  -- Includes the continuation
 -- Like simplExpr, this just returns the simplified alternatives;
 -- it does not return an environment
 -- The returned alternatives can be empty, none are possible
 
-simplAlts env scrut case_bndr alts cont'
-  = -- pprTrace "simplAlts" (ppr alts $$ ppr (seTvSubst env)) $
-    do  { let env0 = zapFloats env
+simplAlts env scrut case_bndr alts_ty alts cont'
+  = do  { let env0 = zapFloats env
+
+        ; basic_alts_ty' <- simplType env0 alts_ty
+        ; let alts_ty' = contResultType env0 basic_alts_ty' cont'
 
         ; (env1, case_bndr1) <- simplBinder env0 case_bndr
 
@@ -1965,7 +1962,8 @@ simplAlts env scrut case_bndr alts cont'
 	; let mb_var_scrut = case scrut' of { Var v -> Just v; _ -> Nothing }
         ; alts' <- mapM (simplAlt alt_env' mb_var_scrut
                              imposs_deflt_cons case_bndr' cont') in_alts
-        ; return (scrut', case_bndr', alts') }
+        ; -- pprTrace "simplAlts" (ppr case_bndr $$ ppr alts_ty $$ ppr alts_ty' $$ ppr alts $$ ppr cont') $
+          return (scrut', case_bndr', alts_ty', alts') }
 
 
 ------------------------------------
@@ -2276,7 +2274,7 @@ mkDupableCont env (ApplyTo _ arg se cont)
         ; let app_cont = ApplyTo OkToDup arg'' (zapSubstEnv env'') dup_cont
         ; return (env'', app_cont, nodup_cont) }
 
-mkDupableCont env cont@(Select _ case_bndr [(_, bs, _rhs)] _ _)
+mkDupableCont env cont@(Select _ case_bndr _ [(_, bs, _rhs)] _ _)
 --  See Note [Single-alternative case]
 --  | not (exprIsDupable rhs && contIsDupable case_cont)
 --  | not (isDeadBinder case_bndr)
@@ -2285,7 +2283,7 @@ mkDupableCont env cont@(Select _ case_bndr [(_, bs, _rhs)] _ _)
     -- Note [Single-alternative-unlifted]
   = return (env, mkBoringStop, cont)
 
-mkDupableCont env (Select _ case_bndr alts se cont)
+mkDupableCont env (Select _ case_bndr alts_ty alts se cont)
   =     -- e.g.         (case [...hole...] of { pi -> ei })
         --      ===>
         --              let ji = \xij -> ei
@@ -2300,6 +2298,9 @@ mkDupableCont env (Select _ case_bndr alts se cont)
 		-- And this is important: see Note [Fusing case continuations]
 
         ; let alt_env = se `setInScope` env'
+
+        ; basic_alts_ty' <- simplType alt_env alts_ty
+        ; let alts_ty' = contResultType alt_env basic_alts_ty' dup_cont
         ; (alt_env', case_bndr') <- simplBinder alt_env case_bndr
         ; alts' <- mapM (simplAlt alt_env' Nothing [] case_bndr' dup_cont) alts
         -- Safe to say that there are no handled-cons for the DEFAULT case
@@ -2316,7 +2317,7 @@ mkDupableCont env (Select _ case_bndr alts se cont)
 
         ; (env'', alts'') <- mkDupableAlts env' case_bndr' alts'
         ; return (env'',  -- Note [Duplicated env]
-                  Select OkToDup case_bndr' alts'' (zapSubstEnv env'') mkBoringStop,
+                  Select OkToDup case_bndr' alts_ty' alts'' (zapSubstEnv env'') mkBoringStop,
                   nodup_cont) }
 
 
diff --git a/compiler/specialise/SpecConstr.lhs b/compiler/specialise/SpecConstr.lhs
index d2c07bcc1b..a65d46e339 100644
--- a/compiler/specialise/SpecConstr.lhs
+++ b/compiler/specialise/SpecConstr.lhs
@@ -1023,7 +1023,7 @@ scExpr' env (Case scrut b ty alts)
   where
     sc_con_app con args scrut' 	-- Known constructor; simplify
 	= do { let (_, bs, rhs) = findAlt con alts
-	       	   	          `orElse` (DEFAULT, [], mkImpossibleExpr (coreAltsType alts))
+	       	   	          `orElse` (DEFAULT, [], mkImpossibleExpr ty)
 		   alt_env'  = extendScSubstList env ((b,scrut') : bs `zip` trimConArgs con args)
 	     ; scExpr alt_env' rhs }
 				
@@ -1034,7 +1034,7 @@ scExpr' env (Case scrut b ty alts)
 	  ; (alt_usgs, alt_occs, alts')
 		<- mapAndUnzip3M (sc_alt alt_env scrut' b') alts
 
-	  ; let scrut_occ  = foldr1 combineOcc alt_occs	-- Never empty
+	  ; let scrut_occ  = foldr combineOcc NoOcc alt_occs
 		scrut_usg' = setScrutOcc env scrut_usg scrut' scrut_occ
 	  	-- The combined usage of the scrutinee is given
 	  	-- by scrut_occ, which is passed to scScrut, which
diff --git a/compiler/specialise/Specialise.lhs b/compiler/specialise/Specialise.lhs
index 321deb866a..6c80f8fbde 100644
--- a/compiler/specialise/Specialise.lhs
+++ b/compiler/specialise/Specialise.lhs
@@ -1037,12 +1037,12 @@ specCalls subst rules_for_me calls_for_me fn rhs
   = WARN( notNull calls_for_me, ptext (sLit "Missed specialisation opportunity for") 
                                  <+> ppr fn $$ _trace_doc )
 	  -- Note [Specialisation shape]
-    -- pprTrace "specDefn: none" (ppr fn $$ ppr calls_for_me) $
+    -- pprTrace "specDefn: none" (ppr fn <+> ppr calls_for_me) $
     return ([], [], emptyUDs)
   where
-    _trace_doc = vcat [ ppr rhs_tyvars, ppr n_tyvars
-                      , ppr rhs_ids, ppr n_dicts
-                      , ppr (idInlineActivation fn) ]
+    _trace_doc = sep [ ppr rhs_tyvars, ppr n_tyvars
+                     , ppr rhs_ids, ppr n_dicts
+                     , ppr (idInlineActivation fn) ]
 
     fn_type	       = idType fn
     fn_arity	       = idArity fn
diff --git a/compiler/stgSyn/CoreToStg.lhs b/compiler/stgSyn/CoreToStg.lhs
index 71bdfe97c9..c4f289c68e 100644
--- a/compiler/stgSyn/CoreToStg.lhs
+++ b/compiler/stgSyn/CoreToStg.lhs
@@ -363,6 +363,18 @@ coreToStgExpr (Cast expr _)
 
 -- Cases require a little more real work.
 
+coreToStgExpr (Case scrut _ _ []) 
+  = coreToStgExpr scrut   
+    -- See Note [Empty case alternatives] in CoreSyn If the case
+    -- alternatives are empty, the scrutinee must diverge or raise an
+    -- exception, so we can just dive into it.
+    --
+    -- Of course this may seg-fault if the scrutinee *does* return.  A
+    -- belt-and-braces approach would be to move this case into the
+    -- code generator, and put a return point anyway that calls a
+    -- runtime system error function.
+        
+
 coreToStgExpr (Case scrut bndr _ alts) = do
     (alts2, alts_fvs, alts_escs)
        <- extendVarEnvLne [(bndr, LambdaBound)] $ do
diff --git a/compiler/stranal/DmdAnal.lhs b/compiler/stranal/DmdAnal.lhs
index 167debfb55..b85c107bea 100644
--- a/compiler/stranal/DmdAnal.lhs
+++ b/compiler/stranal/DmdAnal.lhs
@@ -277,7 +277,7 @@ dmdAnal env dmd (Case scrut case_bndr ty alts)
   = let
 	(alt_tys, alts')        = mapAndUnzip (dmdAnalAlt env dmd) alts
 	(scrut_ty, scrut')      = dmdAnal env evalDmd scrut
-	(alt_ty, case_bndr')	= annotateBndr (foldr1 lubType alt_tys) case_bndr
+	(alt_ty, case_bndr')	= annotateBndr (foldr lubType botDmdType alt_tys) case_bndr
         res_ty                  = alt_ty `bothType` scrut_ty
     in
 --    pprTrace "dmdAnal:Case2" (vcat [ text "scrut" <+> ppr scrut