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))
+ add_rules env (bndr, rhs) = (env', (bndr, bndr', rhs))
where
(env', bndr') = addBndrRules env bndr (lookupRecBndr env bndr)
-- 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}
-- (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}
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)
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:
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
projects / ghc-hetmet.git / blobdiff