From: simonpj@microsoft.com Date: Thu, 2 Apr 2009 15:28:34 +0000 (+0000) Subject: Fix Trac #3118: missing alternative X-Git-Url: http://git.megacz.com/?p=ghc-hetmet.git;a=commitdiff_plain;h=9414bda057e8ac8422ca5590c8500c7cdee323bb Fix Trac #3118: missing alternative This patch fixes a rather obscure bug, whereby it's possible for (case C a b of ) to have altenatives that do not inclue (C a b)! See Note [Unreachable code] in CoreUtils. --- diff --git a/compiler/basicTypes/MkId.lhs b/compiler/basicTypes/MkId.lhs index 1fe712b..986542b 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 379da8a..0708d7a 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 7c88ad2..974ec58 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 3dfda94..3a4b382 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