import CoreSyn
import NewDemand ( isStrictDmd )
import PprCore ( pprParendExpr, pprCoreExpr )
-import CoreUnfold ( mkUnfolding, callSiteInline )
+import CoreUnfold ( mkUnfolding, callSiteInline, CallCtxt(..) )
import CoreUtils
import Rules ( lookupRule )
import BasicTypes ( isMarkedStrict )
import BasicTypes ( TopLevelFlag(..), isTopLevel,
RecFlag(..), isNonRuleLoopBreaker )
import Maybes ( orElse )
+import Data.List ( mapAccumL )
import Outputable
import Util
\end{code}
trace True bind = pprTrace "SimplBind" (ppr (bindersOf bind))
trace False bind = \x -> x
- simpl_bind env (NonRec b r) = simplRecOrTopPair env TopLevel b r
- simpl_bind env (Rec pairs) = simplRecBind env TopLevel pairs
+ simpl_bind env (Rec pairs) = simplRecBind env TopLevel pairs
+ simpl_bind env (NonRec b r) = simplRecOrTopPair env' TopLevel b b' r
+ where
+ (env', b') = addBndrRules env b (lookupRecBndr env b)
\end{code}
-> [(InId, InExpr)]
-> SimplM SimplEnv
simplRecBind env top_lvl pairs
- = do { env' <- go (zapFloats env) pairs
+ = do { let (env_with_info, triples) = mapAccumL add_rules env pairs
+ ; env' <- go (zapFloats env_with_info) triples
; return (env `addRecFloats` env') }
-- addFloats adds the floats from env',
-- *and* updates env with the in-scope set from env'
where
+ add_rules :: SimplEnv -> (InBndr,InExpr) -> (SimplEnv, (InBndr, OutBndr, InExpr))
+ -- Add the (substituted) rules to the binder
+ add_rules env (bndr, rhs) = (env', (bndr, bndr', rhs))
+ where
+ (env', bndr') = addBndrRules env bndr (lookupRecBndr env bndr)
+
go env [] = return env
- go env ((bndr, rhs) : pairs)
- = do { env <- simplRecOrTopPair env top_lvl bndr rhs
+ go env ((old_bndr, new_bndr, rhs) : pairs)
+ = do { env <- simplRecOrTopPair env top_lvl old_bndr new_bndr rhs
; go env pairs }
\end{code}
\begin{code}
simplRecOrTopPair :: SimplEnv
-> TopLevelFlag
- -> InId -> InExpr -- Binder and rhs
+ -> InId -> OutBndr -> InExpr -- Binder and rhs
-> SimplM SimplEnv -- Returns an env that includes the binding
-simplRecOrTopPair env top_lvl bndr rhs
- | preInlineUnconditionally env top_lvl bndr rhs -- Check for unconditional inline
- = do { tick (PreInlineUnconditionally bndr)
- ; return (extendIdSubst env bndr (mkContEx env rhs)) }
+simplRecOrTopPair env top_lvl old_bndr new_bndr rhs
+ | preInlineUnconditionally env top_lvl old_bndr rhs -- Check for unconditional inline
+ = do { tick (PreInlineUnconditionally old_bndr)
+ ; return (extendIdSubst env old_bndr (mkContEx env rhs)) }
| otherwise
- = do { let bndr' = lookupRecBndr env bndr
- (env', bndr'') = addLetIdInfo env bndr bndr'
- ; simplLazyBind env' top_lvl Recursive bndr bndr'' rhs env' }
+ = simplLazyBind env top_lvl Recursive old_bndr new_bndr rhs env
-- May not actually be recursive, but it doesn't matter
\end{code}
-- (for example) be no longer strictly demanded.
-- The solution here is a bit ad hoc...
info_w_unf = new_bndr_info `setUnfoldingInfo` unfolding
+ `setWorkerInfo` worker_info
+
final_info | loop_breaker = new_bndr_info
| isEvaldUnfolding unfolding = zapDemandInfo info_w_unf `orElse` info_w_unf
| otherwise = info_w_unf
return (addNonRec env final_id new_rhs)
where
unfolding = mkUnfolding (isTopLevel top_lvl) new_rhs
+ worker_info = substWorker env (workerInfo old_info)
loop_breaker = isNonRuleLoopBreaker occ_info
old_info = idInfo old_bndr
occ_info = occInfo old_info
-- Kept monadic just so we can do the seqType
simplType env ty
= -- pprTrace "simplType" (ppr ty $$ ppr (seTvSubst env)) $
- seqType new_ty `seq` returnSmpl new_ty
+ seqType new_ty `seq` return new_ty
where
new_ty = substTy env ty
\end{code}
Stop {} -> return (env, expr)
CoerceIt co cont -> rebuild env (mkCoerce co expr) cont
Select _ bndr alts se cont -> rebuildCase (se `setFloats` env) expr bndr alts cont
- StrictArg fun ty info cont -> rebuildCall env (fun `App` expr) (funResultTy ty) info cont
+ StrictArg fun ty _ info cont -> rebuildCall env (fun `App` expr) (funResultTy ty) info cont
StrictBind b bs body se cont -> do { env' <- simplNonRecX (se `setFloats` env) b expr
; simplLam env' bs body cont }
ApplyTo _ arg se cont -> do { arg' <- simplExpr (se `setInScope` env) arg
(StrictBind bndr bndrs body env cont) }
| otherwise
- = do { (env, bndr') <- simplNonRecBndr env bndr
- ; env <- simplLazyBind env NotTopLevel NonRecursive bndr bndr' rhs rhs_se
- ; simplLam env bndrs body cont }
+ = do { (env1, bndr1) <- simplNonRecBndr env bndr
+ ; let (env2, bndr2) = addBndrRules env1 bndr bndr1
+ ; env3 <- simplLazyBind env2 NotTopLevel NonRecursive bndr bndr2 rhs rhs_se
+ ; simplLam env3 bndrs body cont }
\end{code}
-- (even a type application -- anything except Stop)
= simplExprF env e cont
-simplNote env (CoreNote s) e cont
- = simplExpr env e `thenSmpl` \ e' ->
+simplNote env (CoreNote s) e cont = do
+ e' <- simplExpr env e
rebuild env (Note (CoreNote s) e') cont
\end{code}
-- the wrapper didn't occur for things that have specialisations till a
-- later phase, so but now we just try RULES first
--
- -- Note [Self-recursive rules]
- -- ~~~~~~~~~~~~~~~~~~~~~~~~~~~
+ -- 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:
Just act_fn -> lookupRule act_fn in_scope
rules var args
; case maybe_rule of {
- Just (rule, rule_rhs) ->
- tick (RuleFired (ru_name rule)) `thenSmpl_`
+ 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 "Cont: " <+> ppr call_cont])
else
id) $
- simplExprF env rule_rhs (dropArgs (ruleArity rule) cont)
- -- The ruleArity says how many args the rule consumed
+ simplExprF env rule_rhs (dropArgs (ruleArity rule) cont)
+ -- The ruleArity says how many args the rule consumed
; Nothing -> do -- No rules
------------- Next try inlining ----------------
{ let arg_infos = [interestingArg arg | arg <- args, isValArg arg]
n_val_args = length arg_infos
- interesting_cont = interestingCallContext (notNull args)
- (notNull arg_infos)
- call_cont
+ interesting_cont = interestingCallContext call_cont
active_inline = activeInline env var
- maybe_inline = callSiteInline dflags active_inline
- var arg_infos interesting_cont
+ maybe_inline = callSiteInline dflags active_inline var
+ (null args) arg_infos interesting_cont
; case maybe_inline of {
Just unfolding -- There is an inlining!
-> do { tick (UnfoldingDone var)
; (if dopt Opt_D_dump_inlinings dflags then
- pprTrace "Inlining done" (vcat [
+ pprTrace ("Inlining done" ++ showSDoc (ppr var)) (vcat [
text "Before:" <+> ppr var <+> sep (map pprParendExpr args),
text "Inlined fn: " <+> nest 2 (ppr unfolding),
text "Cont: " <+> ppr call_cont])
rebuildCall :: SimplEnv
-> OutExpr -> OutType -- Function and its type
- -> (Bool, [Bool]) -- See SimplUtils.mkArgInfo
+ -> ArgInfo
-> SimplCont
-> SimplM (SimplEnv, OutExpr)
-rebuildCall env fun fun_ty (has_rules, []) cont
+rebuildCall env fun fun_ty (ArgInfo { ai_strs = [] }) cont
-- When we run out of strictness args, it means
-- that the call is definitely bottom; see SimplUtils.mkArgInfo
-- Then we want to discard the entire strict continuation. E.g.
= do { ty' <- simplType (se `setInScope` env) arg_ty
; rebuildCall env (fun `App` Type ty') (applyTy fun_ty ty') info cont }
-rebuildCall env fun fun_ty (has_rules, str:strs) (ApplyTo _ arg arg_se cont)
+rebuildCall env fun fun_ty
+ (ArgInfo { ai_rules = has_rules, ai_strs = str:strs, ai_discs = disc:discs })
+ (ApplyTo _ arg arg_se cont)
| str || isStrictType arg_ty -- Strict argument
= -- pprTrace "Strict Arg" (ppr arg $$ ppr (seIdSubst env) $$ ppr (seInScope env)) $
simplExprF (arg_se `setFloats` env) arg
- (StrictArg fun fun_ty (has_rules, strs) cont)
+ (StrictArg fun fun_ty cci arg_info' cont)
-- Note [Shadowing]
| otherwise -- Lazy argument
-- have to be very careful about bogus strictness through
-- floating a demanded let.
= do { arg' <- simplExprC (arg_se `setInScope` env) arg
- (mkLazyArgStop arg_ty has_rules)
- ; rebuildCall env (fun `App` arg') res_ty (has_rules, strs) cont }
+ (mkLazyArgStop arg_ty cci)
+ ; rebuildCall env (fun `App` arg') res_ty arg_info' cont }
where
(arg_ty, res_ty) = splitFunTy fun_ty
+ arg_info' = ArgInfo { ai_rules = has_rules, ai_strs = strs, ai_discs = discs }
+ cci | has_rules || disc > 0 = ArgCtxt has_rules disc -- Be keener here
+ | otherwise = BoringCtxt -- Nothing interesting
rebuildCall env fun fun_ty info cont
= rebuild env fun cont
I# x# -> let x = x' `cast` sym co
in rhs
-so that 'rhs' can take advantage of hte form of x'. Notice that Note
+so that 'rhs' can take advantage of the form of x'. Notice that Note
[Case of cast] may then apply to the result.
This showed up in Roman's experiments. Example:
-- See Note [no-case-of-case]
= (env, case_bndr)
- | otherwise -- Failed try [see Note 2 above]
+ | otherwise -- Failed try; see Note [Suppressing the case binder-swap]
-- not (isEvaldUnfolding (idUnfolding v))
= case scrut of
Var v -> (modifyInScope env1 v case_bndr', case_bndr')
do { let alt_env = zapFloats env
; (alt_env, scrut', case_bndr') <- simplCaseBinder alt_env scrut case_bndr alts
- ; (imposs_deflt_cons, in_alts) <- prepareAlts scrut case_bndr' alts
+ ; (imposs_deflt_cons, in_alts) <- prepareAlts alt_env scrut case_bndr' alts
; alts' <- mapM (simplAlt alt_env imposs_deflt_cons case_bndr' cont') in_alts
; return (scrut', case_bndr', alts') }
simplAlt env imposs_deflt_cons case_bndr' cont' (DataAlt con, vs, rhs)
= do { -- Deal with the pattern-bound variables
- (env, vs') <- simplBinders env (add_evals con vs)
-
-- Mark the ones that are in ! positions in the
-- data constructor as certainly-evaluated.
- ; let vs'' = add_evals con vs'
+ -- NB: simplLamBinders preserves this eval info
+ let vs_with_evals = add_evals vs (dataConRepStrictness con)
+ ; (env, vs') <- simplLamBndrs env vs_with_evals
-- Bind the case-binder to (con args)
; let inst_tys' = tyConAppArgs (idType case_bndr')
- con_args = map Type inst_tys' ++ varsToCoreExprs vs''
+ con_args = map Type inst_tys' ++ varsToCoreExprs vs'
env' = addBinderUnfolding env case_bndr' (mkConApp con con_args)
; rhs' <- simplExprC env' rhs cont'
- ; return (DataAlt con, vs'', rhs') }
+ ; return (DataAlt con, vs', rhs') }
where
-- add_evals records the evaluated-ness of the bound variables of
-- a case pattern. This is *important*. Consider
-- We really must record that b is already evaluated so that we don't
-- go and re-evaluate it when constructing the result.
-- See Note [Data-con worker strictness] in MkId.lhs
- add_evals dc vs = cat_evals dc vs (dataConRepStrictness dc)
-
- cat_evals dc vs strs
+ add_evals vs strs
= go vs strs
where
go [] [] = []
where
zapped_v = zap_occ_info v
evald_v = zapped_v `setIdUnfolding` evaldUnfolding
- go _ _ = pprPanic "cat_evals" (ppr dc $$ ppr vs $$ ppr strs)
+ go _ _ = pprPanic "cat_evals" (ppr con $$ ppr vs $$ ppr strs)
- -- If the case binder is alive, then we add the unfolding
+ -- zap_occ_info: if the case binder is alive, then we add the unfolding
-- case_bndr = C vs
-- to the envt; so vs are now very much alive
- -- Note [Aug06] I can't see why this actually matters
+ -- Note [Aug06] I can't see why this actually matters, but it's neater
+ -- case e of t { (a,b) -> ...(case t of (p,q) -> p)... }
+ -- ==> case e of t { (a,b) -> ...(a)... }
+ -- Look, Ma, a is alive now.
zap_occ_info | isDeadBinder case_bndr' = \id -> id
| otherwise = zapOccInfo
mkDupableCont env cont
| contIsDupable cont
- = returnSmpl (env, cont, mkBoringStop (contResultType cont))
+ = return (env, cont, mkBoringStop (contResultType cont))
mkDupableCont env (Stop {}) = panic "mkDupableCont" -- Handled by previous eqn
= return (env, mkBoringStop (substTy se (idType bndr)), cont)
-- See Note [Duplicating strict continuations]
-mkDupableCont env cont@(StrictArg _ fun_ty _ _)
+mkDupableCont env cont@(StrictArg _ fun_ty _ _ _)
= return (env, mkBoringStop (funArgTy fun_ty), cont)
-- See Note [Duplicating strict continuations]