----------------------------------------------------------
--- Eliminate the case if possible
-
-rebuildCase :: SimplEnv
- -> OutExpr -- Scrutinee
- -> InId -- Case binder
- -> [InAlt] -- Alternatives (inceasing order)
- -> SimplCont
- -> SimplM (SimplEnv, OutExpr)
-
---------------------------------------------------
--- 1. Eliminate the case if there's a known constructor
---------------------------------------------------
-
-rebuildCase env scrut case_bndr alts cont
- | Just (con,args) <- exprIsConApp_maybe scrut
- -- Works when the scrutinee is a variable with a known unfolding
- -- as well as when it's an explicit constructor application
- = knownCon env scrut (DataAlt con) args case_bndr alts cont
-
- | Lit lit <- scrut -- No need for same treatment as constructors
- -- because literals are inlined more vigorously
- = knownCon env scrut (LitAlt lit) [] case_bndr alts cont
-
-
---------------------------------------------------
--- 2. Eliminate the case if scrutinee is evaluated
---------------------------------------------------
-
-rebuildCase env scrut case_bndr [(con,bndrs,rhs)] cont
- -- See if we can get rid of the case altogether
- -- See the extensive notes on case-elimination above
- -- mkCase made sure that if all the alternatives are equal,
- -- then there is now only one (DEFAULT) rhs
- | all isDeadBinder bndrs -- bndrs are [InId]
-
- -- Check that the scrutinee can be let-bound instead of case-bound
- , exprOkForSpeculation scrut
- -- OK not to evaluate it
- -- This includes things like (==# a# b#)::Bool
- -- so that we simplify
- -- case ==# a# b# of { True -> x; False -> x }
- -- to just
- -- x
- -- This particular example shows up in default methods for
- -- comparision operations (e.g. in (>=) for Int.Int32)
- || exprIsHNF scrut -- It's already evaluated
- || var_demanded_later scrut -- It'll be demanded later
-
--- || not opt_SimplPedanticBottoms) -- Or we don't care!
--- We used to allow improving termination by discarding cases, unless -fpedantic-bottoms was on,
--- but that breaks badly for the dataToTag# primop, which relies on a case to evaluate
--- its argument: case x of { y -> dataToTag# y }
--- Here we must *not* discard the case, because dataToTag# just fetches the tag from
--- the info pointer. So we'll be pedantic all the time, and see if that gives any
--- other problems
--- Also we don't want to discard 'seq's
- = do { tick (CaseElim case_bndr)
- ; env <- simplNonRecX env case_bndr scrut
- ; simplExprF env rhs cont }
- where
- -- The case binder is going to be evaluated later,
- -- and the scrutinee is a simple variable
- var_demanded_later (Var v) = isStrictDmd (idNewDemandInfo case_bndr)
- && not (isTickBoxOp v)
- -- ugly hack; covering this case is what
- -- exprOkForSpeculation was intended for.
- var_demanded_later other = False
-
-
---------------------------------------------------
--- 3. Catch-all case
---------------------------------------------------
-
-rebuildCase env scrut case_bndr alts cont
- = do { -- Prepare the continuation;
- -- The new subst_env is in place
- (env, dup_cont, nodup_cont) <- prepareCaseCont env alts cont
-
- -- Simplify the alternatives
- ; (case_bndr', alts') <- simplAlts env scrut case_bndr alts dup_cont
- ; let res_ty' = contResultType dup_cont
- ; case_expr <- mkCase scrut case_bndr' res_ty' alts'
-
- -- Notice that rebuildDone returns the in-scope set from env, not alt_env
- -- The case binder *not* scope over the whole returned case-expression
- ; rebuild env case_expr nodup_cont }
+tryRules :: SimplEnv -> [CoreRule]
+ -> Id -> [OutExpr] -> SimplCont
+ -> SimplM (Maybe (Arity, CoreExpr)) -- The arity is the number of
+ -- args consumed by the rule
+tryRules env rules fn args call_cont
+ | null rules
+ = return Nothing
+ | otherwise
+ = do { dflags <- getDOptsSmpl
+ ; case activeRule dflags env of {
+ Nothing -> return Nothing ; -- No rules apply
+ Just act_fn ->
+ case lookupRule act_fn (getInScope env) fn args rules of {
+ Nothing -> return Nothing ; -- No rule matches
+ Just (rule, rule_rhs) ->
+
+ do { tick (RuleFired (ru_name rule))
+ ; (if dopt Opt_D_dump_rule_firings dflags then
+ pprTrace "Rule fired" (vcat [
+ text "Rule:" <+> ftext (ru_name rule),
+ text "Before:" <+> ppr fn <+> sep (map pprParendExpr args),
+ text "After: " <+> pprCoreExpr rule_rhs,
+ text "Cont: " <+> ppr call_cont])
+ else
+ id) $
+ return (Just (ruleArity rule, rule_rhs)) }}}}