import Type hiding ( substTy, extendTvSubst )
import SimplEnv
import SimplUtils
-import MkId ( rUNTIME_ERROR_ID )
import FamInstEnv ( FamInstEnv )
import Id
+import MkId ( mkImpossibleExpr, seqId )
import Var
import IdInfo
import Coercion
import CoreUtils
import CoreArity ( exprArity )
import Rules ( lookupRule, getRules )
-import BasicTypes ( isMarkedStrict )
+import BasicTypes ( isMarkedStrict, Arity )
import CostCentre ( currentCCS )
import TysPrim ( realWorldStatePrimTy )
import PrelInfo ( realWorldPrimId )
completeCall :: SimplEnv -> Id -> SimplCont -> SimplM (SimplEnv, OutExpr)
completeCall env var cont
- = do { dflags <- getDOptsSmpl
- ; let (args,call_cont) = contArgs cont
+ = do { let (args,call_cont) = contArgs cont
-- The args are OutExprs, obtained by *lazily* substituting
-- in the args found in cont. These args are only examined
-- to limited depth (unless a rule fires). But we must do
-- We used to use the black-listing mechanism to ensure that inlining of
-- the wrapper didn't occur for things that have specialisations till a
-- later phase, so but now we just try RULES first
- --
- -- Note [Rules for recursive functions]
- -- ~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~
- -- You might think that we shouldn't apply rules for a loop breaker:
- -- doing so might give rise to an infinite loop, because a RULE is
- -- rather like an extra equation for the function:
- -- RULE: f (g x) y = x+y
- -- Eqn: f a y = a-y
- --
- -- But it's too drastic to disable rules for loop breakers.
- -- Even the foldr/build rule would be disabled, because foldr
- -- is recursive, and hence a loop breaker:
- -- foldr k z (build g) = g k z
- -- So it's up to the programmer: rules can cause divergence
- ; rule_base <- getSimplRules
- ; let in_scope = getInScope env
- rules = getRules rule_base var
- maybe_rule = case activeRule dflags env of
- Nothing -> Nothing -- No rules apply
- Just act_fn -> lookupRule act_fn in_scope
- var args rules
- ; case maybe_rule of {
- 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 var <+> sep (map pprParendExpr args),
- text "After: " <+> pprCoreExpr rule_rhs,
- text "Cont: " <+> ppr call_cont])
- else
- id) $
- simplExprF env rule_rhs (dropArgs (ruleArity rule) cont)
+ --
+ -- See also Note [Rules for recursive functions]
+ ; mb_rule <- tryRules env var args call_cont
+ ; case mb_rule of {
+ Just (n_args, rule_rhs) -> simplExprF env rule_rhs (dropArgs n_args cont) ;
-- The ruleArity says how many args the rule consumed
+ ; Nothing -> do -- No rules
- ; Nothing -> do -- No rules
------------- Next try inlining ----------------
- { let arg_infos = [interestingArg arg | arg <- args, isValArg arg]
+ { dflags <- getDOptsSmpl
+ ; let arg_infos = [interestingArg arg | arg <- args, isValArg arg]
n_val_args = length arg_infos
interesting_cont = interestingCallContext call_cont
active_inline = activeInline env var
discard the entire application and replace it with (error "foo"). Getting
all this at once is TOO HARD!
+
+%************************************************************************
+%* *
+ Rewrite rules
+%* *
+%************************************************************************
+
+\begin{code}
+tryRules :: SimplEnv -> Id -> [OutExpr] -> SimplCont
+ -> SimplM (Maybe (Arity, CoreExpr)) -- The arity is the number of
+ -- args consumed by the rule
+tryRules env fn args call_cont
+ = do { dflags <- getDOptsSmpl
+ ; rule_base <- getSimplRules
+ ; let in_scope = getInScope env
+ rules = getRules rule_base fn
+ maybe_rule = case activeRule dflags env of
+ Nothing -> Nothing -- No rules apply
+ Just act_fn -> lookupRule act_fn in_scope
+ fn args rules
+ ; case (rules, maybe_rule) of {
+ ([], _) -> return Nothing ;
+ (_, Nothing) -> return Nothing ;
+ (_, 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)) }}}
+\end{code}
+
+Note [Rules for recursive functions]
+~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~
+You might think that we shouldn't apply rules for a loop breaker:
+doing so might give rise to an infinite loop, because a RULE is
+rather like an extra equation for the function:
+ RULE: f (g x) y = x+y
+ Eqn: f a y = a-y
+
+But it's too drastic to disable rules for loop breakers.
+Even the foldr/build rule would be disabled, because foldr
+is recursive, and hence a loop breaker:
+ foldr k z (build g) = g k z
+So it's up to the programmer: rules can cause divergence
+
+
%************************************************************************
%* *
Rebuilding a cse expression
---------------------------------------------------------
-- Eliminate the case if possible
-rebuildCase :: SimplEnv
- -> OutExpr -- Scrutinee
- -> InId -- Case binder
- -> [InAlt] -- Alternatives (inceasing order)
- -> SimplCont
- -> SimplM (SimplEnv, OutExpr)
+rebuildCase, reallyRebuildCase
+ :: SimplEnv
+ -> OutExpr -- Scrutinee
+ -> InId -- Case binder
+ -> [InAlt] -- Alternatives (inceasing order)
+ -> SimplCont
+ -> SimplM (SimplEnv, OutExpr)
--------------------------------------------------
-- 1. Eliminate the case if there's a known constructor
-- exprOkForSpeculation was intended for.
var_demanded_later _ = False
+rebuildCase env scrut case_bndr alts@[(_, bndrs, rhs)] cont
+ | all isDeadBinder (case_bndr : bndrs) -- So this is just 'seq'
+ = -- For this case, see Note [Rules for seq] in MkId
+ do { let rhs' = substExpr env rhs
+ out_args = [Type (substTy env (idType case_bndr)),
+ Type (exprType rhs'), scrut, rhs']
+ -- Lazily evaluated, so we don't do most of this
+ ; mb_rule <- tryRules env seqId out_args cont
+ ; case mb_rule of
+ Just (n_args, res) -> simplExprF (zapSubstEnv env)
+ (mkApps res (drop n_args out_args))
+ cont
+ Nothing -> reallyRebuildCase env scrut case_bndr alts cont }
+
+rebuildCase env scrut case_bndr alts cont
+ = reallyRebuildCase env scrut case_bndr alts cont
--------------------------------------------------
-- 3. Catch-all case
--------------------------------------------------
-rebuildCase env scrut case_bndr alts cont
+reallyRebuildCase 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
; (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
projects / ghc-hetmet.git / blobdiff