Commit 9414bda0 authored by simonpj@microsoft.com's avatar simonpj@microsoft.com
Browse files

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.
parent a1166295
......@@ -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
......
......@@ -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.
%************************************************************************
%* *
......
......@@ -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
......
......@@ -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
......
Markdown is supported
0% or .
You are about to add 0 people to the discussion. Proceed with caution.
Finish editing this message first!
Please register or to comment