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,
import TypeRep
import Coercion
import TcType
-import CoreUtils
+import CoreUtils ( exprType, mkCoerce )
import CoreUnfold
import Literal
import TyCon
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
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
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.
+
+
%************************************************************************
%* *
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
; (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'
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)
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}
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
import Rules
import Type hiding( substTy )
import Id
+import MkId ( mkImpossibleExpr )
import Var
import VarEnv
import VarSet
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
projects / ghc-hetmet.git / commitdiff