import MkId ( mkImpossibleExpr, seqId )
import Var
import IdInfo
-import Name ( mkSystemVarName )
+import Name ( mkSystemVarName, isExternalName )
import Coercion
+import OptCoercion ( optCoercion )
import FamInstEnv ( topNormaliseType )
import DataCon ( DataCon, dataConWorkId, dataConRepStrictness )
+import CoreMonad ( SimplifierSwitch(..), Tick(..) )
import CoreSyn
-import NewDemand ( isStrictDmd, splitStrictSig )
+import Demand ( isStrictDmd, splitStrictSig )
import PprCore ( pprParendExpr, pprCoreExpr )
import CoreUnfold ( mkUnfolding, mkCoreUnfolding, mkInlineRule,
exprIsConApp_maybe, callSiteInline, CallCtxt(..) )
-- It's rather as if the top-level binders were imported.
; env1 <- simplRecBndrs env0 (bindersOfBinds binds0)
; dflags <- getDOptsSmpl
- ; let dump_flag = dopt Opt_D_dump_inlinings dflags ||
- dopt Opt_D_dump_rule_firings dflags
+ ; let dump_flag = dopt Opt_D_verbose_core2core dflags
; env2 <- simpl_binds dump_flag env1 binds0
; freeTick SimplifierDone
; return env2 }
= do { (env', rhs') <- makeTrivialWithInfo env sanitised_info rhs
; return (env', Cast rhs' co) }
where
- sanitised_info = vanillaIdInfo `setNewStrictnessInfo` newStrictnessInfo info
- `setNewDemandInfo` newDemandInfo info
+ sanitised_info = vanillaIdInfo `setStrictnessInfo` strictnessInfo info
+ `setDemandInfo` demandInfo info
info = idInfo id
prepareRhs env0 _ rhs0
- = do { (_is_val, env1, rhs1) <- go 0 env0 rhs0
+ = do { (_is_exp, env1, rhs1) <- go 0 env0 rhs0
; return (env1, rhs1) }
where
go n_val_args env (Cast rhs co)
- = do { (is_val, env', rhs') <- go n_val_args env rhs
- ; return (is_val, env', Cast rhs' co) }
+ = do { (is_exp, env', rhs') <- go n_val_args env rhs
+ ; return (is_exp, env', Cast rhs' co) }
go n_val_args env (App fun (Type ty))
- = do { (is_val, env', rhs') <- go n_val_args env fun
- ; return (is_val, env', App rhs' (Type ty)) }
+ = do { (is_exp, env', rhs') <- go n_val_args env fun
+ ; return (is_exp, env', App rhs' (Type ty)) }
go n_val_args env (App fun arg)
- = do { (is_val, env', fun') <- go (n_val_args+1) env fun
- ; case is_val of
+ = do { (is_exp, env', fun') <- go (n_val_args+1) env fun
+ ; case is_exp of
True -> do { (env'', arg') <- makeTrivial env' arg
; return (True, env'', App fun' arg') }
False -> return (False, env, App fun arg) }
go n_val_args env (Var fun)
- = return (is_val, env, Var fun)
+ = return (is_exp, env, Var fun)
where
- is_val = n_val_args > 0 -- There is at least one arg
- -- ...and the fun a constructor or PAP
- && (isConLikeId fun || n_val_args < idArity fun)
- -- See Note [CONLIKE pragma] in BasicTypes
+ is_exp = isExpandableApp fun n_val_args -- The fun a constructor or PAP
+ -- See Note [CONLIKE pragma] in BasicTypes
+ -- The definition of is_exp should match that in
+ -- OccurAnal.occAnalApp
+
go _ env other
= return (False, env, other)
\end{code}
; if postInlineUnconditionally env top_lvl new_bndr occ_info new_rhs new_unfolding
-- Inline and discard the binding
then do { tick (PostInlineUnconditionally old_bndr)
- ; return (extendIdSubst env old_bndr (DoneEx new_rhs)) }
+ ; -- pprTrace "postInlineUnconditionally" (ppr old_bndr <+> equals <+> ppr new_rhs) $
+ return (extendIdSubst env old_bndr (DoneEx new_rhs)) }
-- Use the substitution to make quite, quite sure that the
-- substitution will happen, since we are going to discard the binding
| otherwise = info2
final_id = new_bndr `setIdInfo` info3
- dmd_arity = length $ fst $ splitStrictSig $ idNewStrictness new_bndr
+ dmd_arity = length $ fst $ splitStrictSig $ idStrictness new_bndr
in
ASSERT( isId new_bndr )
WARN( new_arity < old_arity || new_arity < dmd_arity,
------------------------------
simplUnfolding :: SimplEnv-> TopLevelFlag
- -> Id -- Debug output only
+ -> Id
-> OccInfo -> OutExpr
-> Unfolding -> SimplM Unfolding
-- Note [Setting the new unfolding]
where
ops' = map (CoreSubst.substExpr (mkCoreSubst env)) ops
-simplUnfolding env top_lvl _ _ _
+simplUnfolding env top_lvl id _ _
(CoreUnfolding { uf_tmpl = expr, uf_arity = arity
- , uf_guidance = guide@(InlineRule {}) })
- = do { expr' <- simplExpr (updMode updModeForInlineRules env) expr
- -- See Note [Simplifying gently inside InlineRules] in SimplUtils
- ; let mb_wkr' = CoreSubst.substInlineRuleInfo (mkCoreSubst env) (ir_info guide)
- ; return (mkCoreUnfolding (isTopLevel top_lvl) expr' arity
- (guide { ir_info = mb_wkr' })) }
+ , uf_src = src, uf_guidance = guide })
+ | isInlineRuleSource src
+ = -- pprTrace "su" (vcat [ppr id, ppr act, ppr (getMode env), ppr (getMode rule_env)]) $
+ do { expr' <- simplExpr rule_env expr
+ ; let src' = CoreSubst.substUnfoldingSource (mkCoreSubst env) src
+ ; return (mkCoreUnfolding (isTopLevel top_lvl) src' expr' arity guide) }
-- See Note [Top-level flag on inline rules] in CoreUnfold
+ where
+ act = idInlineActivation id
+ rule_env = updMode (updModeForInlineRules act) env
+ -- See Note [Simplifying gently inside InlineRules] in SimplUtils
-simplUnfolding _ top_lvl _ _occ_info new_rhs _
- = return (mkUnfolding (isTopLevel top_lvl) new_rhs)
+simplUnfolding _ top_lvl id _occ_info new_rhs _
+ = return (mkUnfolding (isTopLevel top_lvl) (isBottomingId id) new_rhs)
-- We make an unfolding *even for loop-breakers*.
-- Reason: (a) It might be useful to know that they are WHNF
-- (b) In TidyPgm we currently assume that, if we want to
-- Kept monadic just so we can do the seqType
simplType env ty
= -- pprTrace "simplType" (ppr ty $$ ppr (seTvSubst env)) $
- seqType new_ty `seq` return new_ty
+ seqType new_ty `seq` return new_ty
where
new_ty = substTy env ty
-- The InType isn't *necessarily* a coercion, but it might be
-- (in a type application, say) and optCoercion is a no-op on types
simplCoercion env co
- = do { co' <- simplType env co
- ; return (optCoercion co') }
+ = seqType new_co `seq` return new_co
+ where
+ new_co = optCoercion (getTvSubst env) co
\end{code}
arg_infos = [interestingArg arg | arg <- args, isValArg arg]
n_val_args = length arg_infos
interesting_cont = interestingCallContext call_cont
- active_inline = activeInline env var
- maybe_inline = callSiteInline dflags active_inline var
- (null args) arg_infos interesting_cont
+ unfolding = activeUnfolding env var
+ maybe_inline = callSiteInline dflags var unfolding
+ (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: " ++ showSDoc (ppr var)) (vcat [
- text "Before:" <+> ppr var <+> sep (map pprParendExpr args),
- text "Inlined fn: " <+> nest 2 (ppr unfolding),
- text "Cont: " <+> ppr call_cont])
- else
- id)
+ ; trace_inline dflags unfolding args call_cont $
simplExprF (zapSubstEnv env) unfolding cont }
; Nothing -> do -- No inlining!
; let info = mkArgInfo var (getRules rule_base var) n_val_args call_cont
; rebuildCall env info cont
}}}
+ where
+ trace_inline dflags unfolding args call_cont stuff
+ | not (dopt Opt_D_dump_inlinings dflags) = stuff
+ | not (dopt Opt_D_verbose_core2core dflags)
+ = if isExternalName (idName var) then
+ pprTrace "Inlining done:" (ppr var) stuff
+ else stuff
+ | otherwise
+ = 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])
+ stuff
rebuildCall :: SimplEnv
-> ArgInfo
; case activeRule dflags env of {
Nothing -> return Nothing ; -- No rules apply
Just act_fn ->
- case lookupRule act_fn (getInScope env) fn args rules of {
+ case lookupRule act_fn (activeUnfInRule env) (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)) }}}}
+ ; trace_dump dflags rule rule_rhs $
+ return (Just (ruleArity rule, rule_rhs)) }}}}
+ where
+ trace_dump dflags rule rule_rhs stuff
+ | not (dopt Opt_D_dump_rule_firings dflags) = stuff
+ | not (dopt Opt_D_verbose_core2core dflags)
+
+ = pprTrace "Rule fired:" (ftext (ru_name rule)) stuff
+ | otherwise
+ = 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])
+ stuff
\end{code}
Note [Rules for recursive functions]
Nothing -> missingAlt env case_bndr alts cont
Just (_, bs, rhs) -> simple_rhs bs rhs }
- | Just (con, ty_args, other_args) <- exprIsConApp_maybe scrut
+ | Just (con, ty_args, other_args) <- exprIsConApp_maybe (activeUnfInRule env) scrut
-- Works when the scrutinee is a variable with a known unfolding
-- as well as when it's an explicit constructor application
= do { tick (KnownBranch case_bndr)
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)
+ var_demanded_later (Var v) = isStrictDmd (idDemandInfo case_bndr)
&& not (isTickBoxOp v)
-- ugly hack; covering this case is what
-- exprOkForSpeculation was intended for.
addBinderUnfolding :: SimplEnv -> Id -> CoreExpr -> SimplEnv
addBinderUnfolding env bndr rhs
- = modifyInScope env (bndr `setIdUnfolding` mkUnfolding False rhs)
+ = modifyInScope env (bndr `setIdUnfolding` mkUnfolding False False rhs)
addBinderOtherCon :: SimplEnv -> Id -> [AltCon] -> SimplEnv
addBinderOtherCon env bndr cons
DataAlt dc -> setIdUnfolding case_bndr unf
where
-- See Note [Case binders and join points]
- unf = mkInlineRule InlSat rhs 0
+ unf = mkInlineRule needSaturated rhs 0
rhs = mkConApp dc (map Type (tyConAppArgs scrut_ty)
++ varsToCoreExprs bndrs')
projects / ghc-hetmet.git / blobdiff