Fix Trac #3118: missing alternative

This patch fixes a rather obscure bug, whereby it's possible
for (case C a b of <alts>) to have altenatives that do not inclue
(C a b)!  See Note [Unreachable code] in CoreUtils.

4 files changed, 79 insertions, 41 deletions

diff --git a/compiler/basicTypes/MkId.lhs b/compiler/basicTypes/MkId.lhs
index 1fe712b285..986542bdb3 100644
--- a/compiler/basicTypes/MkId.lhs
+++ b/compiler/basicTypes/MkId.lhs
@@ -35,7 +35,7 @@ module MkId (
         unsafeCoerceId, realWorldPrimId, voidArgId, nullAddrId, seqId,
         lazyId, lazyIdUnfolding, lazyIdKey,
 
-        mkRuntimeErrorApp,
+        mkRuntimeErrorApp, mkImpossibleExpr,
         rEC_CON_ERROR_ID, iRREFUT_PAT_ERROR_ID, rUNTIME_ERROR_ID,
         nON_EXHAUSTIVE_GUARDS_ERROR_ID, nO_METHOD_BINDING_ERROR_ID,
         pAT_ERROR_ID, eRROR_ID, rEC_SEL_ERROR_ID,
@@ -53,7 +53,7 @@ import Type
 import TypeRep
 import Coercion
 import TcType
-import CoreUtils
+import CoreUtils	( exprType, mkCoerce )
 import CoreUnfold
 import Literal
 import TyCon
@@ -977,6 +977,10 @@ mkRuntimeErrorApp err_id res_ty err_msg
   where
     err_string = Lit (mkMachString err_msg)
 
+mkImpossibleExpr :: Type -> CoreExpr
+mkImpossibleExpr res_ty
+  = mkRuntimeErrorApp rUNTIME_ERROR_ID res_ty "Impossible case alternative"
+
 rEC_SEL_ERROR_ID                = mkRuntimeErrorId recSelErrorName
 rUNTIME_ERROR_ID                = mkRuntimeErrorId runtimeErrorName
 iRREFUT_PAT_ERROR_ID            = mkRuntimeErrorId irrefutPatErrorName
diff --git a/compiler/coreSyn/CoreUtils.lhs b/compiler/coreSyn/CoreUtils.lhs
index 379da8aef3..0708d7aa75 100644
--- a/compiler/coreSyn/CoreUtils.lhs
+++ b/compiler/coreSyn/CoreUtils.lhs
@@ -308,27 +308,28 @@ findDefault :: [CoreAlt] -> ([CoreAlt], Maybe CoreExpr)
 findDefault ((DEFAULT,args,rhs) : alts) = ASSERT( null args ) (alts, Just rhs)
 findDefault alts			= 		      (alts, Nothing)
 
+isDefaultAlt :: CoreAlt -> Bool
+isDefaultAlt (DEFAULT, _, _) = True
+isDefaultAlt _               = False
+
+
 -- | Find the case alternative corresponding to a particular 
 -- constructor: panics if no such constructor exists
-findAlt :: AltCon -> [CoreAlt] -> CoreAlt
+findAlt :: AltCon -> [CoreAlt] -> Maybe CoreAlt
+    -- A "Nothing" result *is* legitmiate
+    -- See Note [Unreachable code]
 findAlt con alts
   = case alts of
-	(deflt@(DEFAULT,_,_):alts) -> go alts deflt
-        _                          -> go alts panic_deflt
+	(deflt@(DEFAULT,_,_):alts) -> go alts (Just deflt)
+        _                          -> go alts Nothing
   where
-    panic_deflt = pprPanic "Missing alternative" (ppr con $$ vcat (map ppr alts))
-
-    go []	 	       deflt = deflt
+    go []	 	      deflt = deflt
     go (alt@(con1,_,_) : alts) deflt
       =	case con `cmpAltCon` con1 of
 	  LT -> deflt	-- Missed it already; the alts are in increasing order
-	  EQ -> alt
+	  EQ -> Just alt
 	  GT -> ASSERT( not (con1 == DEFAULT) ) go alts deflt
 
-isDefaultAlt :: CoreAlt -> Bool
-isDefaultAlt (DEFAULT, _, _) = True
-isDefaultAlt _               = False
-
 ---------------------------------
 mergeAlts :: [CoreAlt] -> [CoreAlt] -> [CoreAlt]
 -- ^ Merge alternatives preserving order; alternatives in
@@ -357,6 +358,36 @@ trimConArgs (LitAlt _)   args = ASSERT( null args ) []
 trimConArgs (DataAlt dc) args = dropList (dataConUnivTyVars dc) args
 \end{code}
 
+Note [Unreachable code]
+~~~~~~~~~~~~~~~~~~~~~~~
+It is possible (although unusual) for GHC to find a case expression
+that cannot match.  For example: 
+
+     data Col = Red | Green | Blue
+     x = Red
+     f v = case x of 
+              Red -> ...
+	      _ -> ...(case x of { Green -> e1; Blue -> e2 })...
+
+Suppose that for some silly reason, x isn't substituted in the case
+expression.  (Perhaps there's a NOINLINE on it, or profiling SCC stuff
+gets in the way; cf Trac #3118.)  Then the full-lazines pass might produce
+this
+
+     x = Red
+     lvl = case x of { Green -> e1; Blue -> e2 })
+     f v = case x of 
+             Red -> ...
+	     _ -> ...lvl...
+
+Now if x gets inlined, we won't be able to find a matching alternative
+for 'Red'.  That's because 'lvl' is unreachable.  So rather than crashing
+we generate (error "Inaccessible alternative").
+
+Similar things can happen (augmented by GADTs) when the Simplifier
+filters down the matching alternatives in Simplify.rebuildCase.
+
+
 
 %************************************************************************
 %*									*
diff --git a/compiler/simplCore/Simplify.lhs b/compiler/simplCore/Simplify.lhs
index 7c88ad29e8..974ec58d03 100644
--- a/compiler/simplCore/Simplify.lhs
+++ b/compiler/simplCore/Simplify.lhs
@@ -13,9 +13,9 @@ import SimplMonad
 import Type hiding      ( substTy, extendTvSubst )
 import SimplEnv
 import SimplUtils
-import MkId		( rUNTIME_ERROR_ID )
 import FamInstEnv	( FamInstEnv )
 import Id
+import MkId		( mkImpossibleExpr )
 import Var
 import IdInfo
 import Coercion
@@ -1390,17 +1390,7 @@ rebuildCase env scrut case_bndr alts cont
         ; (scrut', case_bndr', alts') <- simplAlts env' scrut case_bndr alts dup_cont
 
 	-- Check for empty alternatives
-	; if null alts' then
-		-- This isn't strictly an error, although it is unusual. 
-		-- It's possible that the simplifer might "see" that 
-		-- an inner case has no accessible alternatives before 
-		-- it "sees" that the entire branch of an outer case is 
-		-- inaccessible.  So we simply put an error case here instead.
-	    pprTrace "mkCase: null alts" (ppr case_bndr <+> ppr scrut) $
-	    let res_ty' = contResultType env' (substTy env' (coreAltsType alts)) dup_cont
-		lit = mkStringLit "Impossible alternative"
-	    in return (env', mkApps (Var rUNTIME_ERROR_ID) [Type res_ty', lit])
-
+	; if null alts' then missingAlt env case_bndr alts cont
 	  else do
 	{ case_expr <- mkCase scrut' case_bndr' alts'
 
@@ -1687,23 +1677,15 @@ knownCon :: SimplEnv -> OutExpr -> AltCon
 
 knownCon env scrut con args bndr alts cont
   = do  { tick (KnownBranch bndr)
-        ; knownAlt env scrut args bndr (findAlt con alts) cont }
+        ; case findAlt con alts of
+	    Nothing  -> missingAlt env bndr alts cont
+	    Just alt -> knownAlt env scrut args bndr alt cont
+	}
 
+-------------------
 knownAlt :: SimplEnv -> OutExpr -> [OutExpr]
-         -> InId -> (AltCon, [CoreBndr], InExpr) -> SimplCont
+         -> InId -> InAlt -> SimplCont
          -> SimplM (SimplEnv, OutExpr)
-knownAlt env scrut _ bndr (DEFAULT, bs, rhs) cont
-  = ASSERT( null bs )
-    do  { env' <- simplNonRecX env bndr scrut
-                -- This might give rise to a binding with non-atomic args
-                -- like x = Node (f x) (g x)
-                -- but simplNonRecX will atomic-ify it
-        ; simplExprF env' rhs cont }
-
-knownAlt env scrut _ bndr (LitAlt _, bs, rhs) cont
-  = ASSERT( null bs )
-    do  { env' <- simplNonRecX env bndr scrut
-        ; simplExprF env' rhs cont }
 
 knownAlt env scrut the_args bndr (DataAlt dc, bs, rhs) cont
   = do  { let n_drop_tys = length (dataConUnivTyVars dc)
@@ -1749,6 +1731,25 @@ knownAlt env scrut the_args bndr (DataAlt dc, bs, rhs) cont
     bind_args _ _ _ =
       pprPanic "bind_args" $ ppr dc $$ ppr bs $$ ppr the_args $$
                              text "scrut:" <+> ppr scrut
+
+knownAlt env scrut _ bndr (_, bs, rhs) cont
+  = ASSERT( null bs )	  -- Works for LitAlt and DEFAULT
+    do  { env' <- simplNonRecX env bndr scrut
+        ; simplExprF env' rhs cont }
+
+
+-------------------
+missingAlt :: SimplEnv -> Id -> [InAlt] -> SimplCont -> SimplM (SimplEnv, OutExpr)
+   		-- This isn't strictly an error, although it is unusual. 
+		-- It's possible that the simplifer might "see" that 
+		-- an inner case has no accessible alternatives before 
+		-- it "sees" that the entire branch of an outer case is 
+		-- inaccessible.  So we simply put an error case here instead.
+missingAlt env case_bndr alts cont
+  = WARN( True, ptext (sLit "missingAlt") <+> ppr case_bndr )
+    return (env, mkImpossibleExpr res_ty)
+  where
+    res_ty = contResultType env (substTy env (coreAltsType alts)) cont
 \end{code}
 
 
@@ -1912,7 +1913,7 @@ we'd lose that when zapping the subst-env.  We could have a per-alt subst-env,
 but zapping it (as we do in mkDupableCont, the Select case) is safe, and
 at worst delays the join-point inlining.
 
-Note [Small alterantive rhs]
+Note [Small alternative rhs]
 ~~~~~~~~~~~~~~~~~~~~~~~~~~~~
 It is worth checking for a small RHS because otherwise we
 get extra let bindings that may cause an extra iteration of the simplifier to
diff --git a/compiler/specialise/SpecConstr.lhs b/compiler/specialise/SpecConstr.lhs
index 3dfda94ca3..3a4b382910 100644
--- a/compiler/specialise/SpecConstr.lhs
+++ b/compiler/specialise/SpecConstr.lhs
@@ -27,6 +27,7 @@ import Coercion
 import Rules
 import Type		hiding( substTy )
 import Id
+import MkId		( mkImpossibleExpr )
 import Var
 import VarEnv
 import VarSet
@@ -778,7 +779,8 @@ scExpr' env (Case scrut b ty alts)
   where
     sc_con_app con args scrut' 	-- Known constructor; simplify
 	= do { let (_, bs, rhs) = findAlt con alts
-		   alt_env' = extendScSubstList env ((b,scrut') : bs `zip` trimConArgs con args)
+	       	   	          `orElse` (DEFAULT, [], mkImpossibleExpr (coreAltsType alts))
+		   alt_env'  = extendScSubstList env ((b,scrut') : bs `zip` trimConArgs con args)
 	     ; scExpr alt_env' rhs }
 				
     sc_vanilla scrut_usg scrut'	-- Normal case