import Type
import TyCon
import DataCon
-import TcGadt ( dataConCanMatch )
+import Unify ( dataConCannotMatch )
import VarSet
import BasicTypes
import Util
instance Outputable SimplCont where
ppr (Stop ty is_rhs _) = ptext SLIT("Stop") <> brackets (ppr is_rhs) <+> ppr ty
- ppr (ApplyTo dup arg se cont) = ((ptext SLIT("ApplyTo") <+> ppr dup <+> pprParendExpr arg) $$
- nest 2 (pprSimplEnv se)) $$ ppr cont
+ ppr (ApplyTo dup arg se 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 f _ _ cont) = (ptext SLIT("StrictArg") <+> ppr f) $$ ppr cont
ppr (Select dup bndr alts se cont) = (ptext SLIT("Select") <+> ppr dup <+> ppr bndr) $$
- (nest 4 (ppr alts $$ pprSimplEnv se)) $$ ppr cont
+ (nest 4 (ppr alts)) $$ ppr cont
ppr (CoerceIt co cont) = (ptext SLIT("CoerceIt") <+> ppr co) $$ ppr cont
data DupFlag = OkToDup | NoDup
where
prag = idInlinePragma id
-activeRule :: SimplEnv -> Maybe (Activation -> Bool)
+activeRule :: DynFlags -> SimplEnv -> Maybe (Activation -> Bool)
-- Nothing => No rules at all
-activeRule env
- | opt_RulesOff = Nothing
+activeRule dflags env
+ | not (dopt Opt_RewriteRules dflags)
+ = Nothing -- Rewriting is off
| otherwise
= case getMode env of
SimplGently -> Just isAlwaysActive
; let (alts_wo_default, maybe_deflt) = findDefault alts
alt_cons = [con | (con,_,_) <- alts_wo_default]
imposs_deflt_cons = nub (imposs_cons ++ alt_cons)
- -- "imposs_deflt_cons" are handled either by the context,
- -- OR by a branch in this case expression.
- -- Don't include DEFAULT!!
+ -- "imposs_deflt_cons" are handled
+ -- EITHER by the context,
+ -- OR by a non-DEFAULT branch in this case expression.
; default_alts <- prepareDefault dflags scrut case_bndr' mb_tc_app
imposs_deflt_cons maybe_deflt
- ; let trimmed_alts = filter possible_alt alts_wo_default
- merged_alts = mergeAlts default_alts trimmed_alts
+ ; let trimmed_alts = filterOut impossible_alt alts_wo_default
+ merged_alts = mergeAlts trimmed_alts default_alts
-- We need the mergeAlts in case the new default_alt
-- has turned into a constructor alternative.
-- The merge keeps the inner DEFAULT at the front, if there is one
- -- and eliminates any inner_alts that are shadowed by the outer_alts
-
+ -- and interleaves the alternatives in the right order
; return (imposs_deflt_cons, merged_alts) }
where
Var v -> otherCons (idUnfolding v)
other -> []
- possible_alt :: CoreAlt -> Bool
- possible_alt (con, _, _) | con `elem` imposs_cons = False
- possible_alt (DataAlt con, _, _) = dataConCanMatch inst_tys con
- possible_alt alt = True
+ impossible_alt :: CoreAlt -> Bool
+ impossible_alt (con, _, _) | con `elem` imposs_cons = True
+ impossible_alt (DataAlt con, _, _) = dataConCannotMatch inst_tys con
+ impossible_alt alt = False
--------------------------------------------------
= do { tick (CaseMerge outer_bndr)
; let munge_rhs rhs = bindCaseBndr inner_bndr (Var outer_bndr) rhs
- ; return [(con, args, munge_rhs rhs) | (con, args, rhs) <- inner_alts] }
+ ; return [(con, args, munge_rhs rhs) | (con, args, rhs) <- inner_alts,
+ not (con `elem` imposs_cons) ]
+ -- NB: filter out any imposs_cons. Example:
+ -- case x of
+ -- A -> e1
+ -- DEFAULT -> case x of
+ -- A -> e2
+ -- B -> e3
+ -- When we merge, we must ensure that e1 takes
+ -- precedence over e2 as the value for A!
+ }
-- Warning: don't call prepareAlts recursively!
-- Firstly, there's no point, because inner alts have already had
-- mkCase applied to them, so they won't have a case in their default
-- which would be quite legitmate. But it's a really obscure corner, and
-- not worth wasting code on.
, let imposs_data_cons = [con | DataAlt con <- imposs_cons] -- We now know it's a data type
- is_possible con = not (con `elem` imposs_data_cons)
- && dataConCanMatch inst_tys con
- = case filter is_possible all_cons of
+ impossible con = con `elem` imposs_data_cons || dataConCannotMatch inst_tys con
+ = case filterOut impossible all_cons of
[] -> return [] -- Eliminate the default alternative
-- altogether if it can't match
-- put an error case here insteadd
mkCase scrut case_bndr ty []
= pprTrace "mkCase: null alts" (ppr case_bndr <+> ppr scrut) $
- return (mkApps (Var eRROR_ID)
+ return (mkApps (Var rUNTIME_ERROR_ID)
[Type ty, Lit (mkStringLit "Impossible alternative")])