-- Inlining,
preInlineUnconditionally, postInlineUnconditionally,
- activeInline, activeRule, inlineMode,
+ activeInline, activeRule,
-- The continuation type
SimplCont(..), DupFlag(..), ArgInfo(..),
contIsDupable, contResultType, contIsTrivial, contArgs, dropArgs,
- countValArgs, countArgs, splitInlineCont,
+ countValArgs, countArgs,
mkBoringStop, mkLazyArgStop, contIsRhsOrArg,
- interestingCallContext, interestingArgContext,
+ interestingCallContext,
interestingArg, mkArgInfo,
import PprCore
import CoreFVs
import CoreUtils
+import CoreArity ( etaExpand, exprEtaExpandArity )
import CoreUnfold
import Name
import Id
import Outputable
import FastString
-import List( nub )
+import Data.List
\end{code}
SimplCont
| StrictArg -- e C
- OutExpr -- e
+ OutExpr -- e; *always* of form (Var v `App1` e1 .. `App` en)
CallCtxt -- Whether *this* argument position is interesting
ArgInfo -- Whether the function at the head of e has rules, etc
SimplCont -- plus strictness flags for *further* args
dropArgs 0 cont = cont
dropArgs n (ApplyTo _ _ _ cont) = dropArgs (n-1) cont
dropArgs n other = pprPanic "dropArgs" (ppr n <+> ppr other)
-
---------------------
-splitInlineCont :: SimplCont -> Maybe (SimplCont, SimplCont)
--- Returns Nothing if the continuation should dissolve an InlineMe Note
--- Return Just (c1,c2) otherwise,
--- where c1 is the continuation to put inside the InlineMe
--- and c2 outside
-
--- Example: (__inline_me__ (/\a. e)) ty
--- Here we want to do the beta-redex without dissolving the InlineMe
--- See test simpl017 (and Trac #1627) for a good example of why this is important
-
-splitInlineCont (ApplyTo dup (Type ty) se c)
- | Just (c1, c2) <- splitInlineCont c = Just (ApplyTo dup (Type ty) se c1, c2)
-splitInlineCont cont@(Stop {}) = Just (mkBoringStop, cont)
-splitInlineCont cont@(StrictBind {}) = Just (mkBoringStop, cont)
-splitInlineCont cont@(StrictArg {}) = Just (mkBoringStop, cont)
-splitInlineCont _ = Nothing
-\end{code}
-
-
-\begin{code}
-interestingArg :: OutExpr -> Bool
- -- An argument is interesting if it has *some* structure
- -- We are here trying to avoid unfolding a function that
- -- is applied only to variables that have no unfolding
- -- (i.e. they are probably lambda bound): f x y z
- -- There is little point in inlining f here.
-interestingArg (Var v) = hasSomeUnfolding (idUnfolding v)
- -- Was: isValueUnfolding (idUnfolding v')
- -- But that seems over-pessimistic
- || isDataConWorkId v
- -- This accounts for an argument like
- -- () or [], which is definitely interesting
-interestingArg (Type _) = False
-interestingArg (App fn (Type _)) = interestingArg fn
-interestingArg (Note _ a) = interestingArg a
-
--- Idea (from Sam B); I'm not sure if it's a good idea, so commented out for now
--- interestingArg expr | isUnLiftedType (exprType expr)
--- -- Unlifted args are only ever interesting if we know what they are
--- = case expr of
--- Lit lit -> True
--- _ -> False
-
-interestingArg _ = True
- -- Consider let x = 3 in f x
- -- The substitution will contain (x -> ContEx 3), and we want to
- -- to say that x is an interesting argument.
- -- But consider also (\x. f x y) y
- -- The substitution will contain (x -> ContEx y), and we want to say
- -- that x is not interesting (assuming y has no unfolding)
\end{code}
-Comment about interestingCallContext
-~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~
+Note [Interesting call context]
+~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~
We want to avoid inlining an expression where there can't possibly be
any gain, such as in an argument position. Hence, if the continuation
is interesting (eg. a case scrutinee, application etc.) then we
\begin{code}
interestingCallContext :: SimplCont -> CallCtxt
+-- See Note [Interesting call context]
interestingCallContext cont
= interesting cont
where
- interestingCtxt = ArgCtxt False 2 -- Give *some* incentive!
-
interesting (Select _ bndr _ _ _)
- | isDeadBinder bndr = CaseCtxt
- | otherwise = interestingCtxt
+ | isDeadBinder bndr = CaseCtxt
+ | otherwise = ArgCtxt False 2 -- If the binder is used, this
+ -- is like a strict let
- interesting (ApplyTo {}) = interestingCtxt
- -- Can happen if we have (coerce t (f x)) y
- -- Perhaps interestingCtxt is a bit over-keen, but I've
- -- seen (coerce f) x, where f has an INLINE prag,
- -- So we have to give some motivation for inlining it
+ interesting (ApplyTo _ arg _ cont)
+ | isTypeArg arg = interesting cont
+ | otherwise = ValAppCtxt -- Can happen if we have (f Int |> co) y
+ -- If f has an INLINE prag we need to give it some
+ -- motivation to inline. See Note [Cast then apply]
+ -- in CoreUnfold
interesting (StrictArg _ cci _ _) = cci
interesting (StrictBind {}) = BoringCtxt
-------------------
mkArgInfo :: Id
+ -> [CoreRule] -- Rules for function
-> Int -- Number of value args
- -> SimplCont -- Context of the cal
+ -> SimplCont -- Context of the call
-> ArgInfo
-mkArgInfo fun n_val_args call_cont
+mkArgInfo fun rules n_val_args call_cont
| n_val_args < idArity fun -- Note [Unsaturated functions]
= ArgInfo { ai_rules = False
, ai_strs = vanilla_stricts
, ai_discs = vanilla_discounts }
| otherwise
- = ArgInfo { ai_rules = interestingArgContext fun call_cont
+ = ArgInfo { ai_rules = interestingArgContext rules call_cont
, ai_strs = add_type_str (idType fun) arg_stricts
, ai_discs = arg_discounts }
where
vanilla_discounts, arg_discounts :: [Int]
vanilla_discounts = repeat 0
arg_discounts = case idUnfolding fun of
- CoreUnfolding _ _ _ _ (UnfoldIfGoodArgs _ discounts _ _)
+ CoreUnfolding {uf_guidance = UnfoldIfGoodArgs {ug_args = discounts}}
-> discounts ++ vanilla_discounts
_ -> vanilla_discounts
on its first argument -- it must be saturated for these to kick in
-}
-interestingArgContext :: Id -> SimplCont -> Bool
+interestingArgContext :: [CoreRule] -> SimplCont -> Bool
-- If the argument has form (f x y), where x,y are boring,
-- and f is marked INLINE, then we don't want to inline f.
-- But if the context of the argument is
-- where h has rules, then we do want to inline f; hence the
-- call_cont argument to interestingArgContext
--
--- The interesting_arg_ctxt flag makes this happen; if it's
+-- The ai-rules flag makes this happen; if it's
-- set, the inliner gets just enough keener to inline f
-- regardless of how boring f's arguments are, if it's marked INLINE
--
-- The alternative would be to *always* inline an INLINE function,
-- regardless of how boring its context is; but that seems overkill
-- For example, it'd mean that wrapper functions were always inlined
-interestingArgContext fn call_cont
- = idHasRules fn || go call_cont
+interestingArgContext rules call_cont
+ = notNull rules || enclosing_fn_has_rules
where
+ enclosing_fn_has_rules = go call_cont
+
go (Select {}) = False
go (ApplyTo {}) = False
go (StrictArg _ cci _ _) = interesting cci
INLINE pragmas
~~~~~~~~~~~~~~
-SimplGently is also used as the mode to simplify inside an InlineMe note.
-
-\begin{code}
-inlineMode :: SimplifierMode
-inlineMode = SimplGently
-\end{code}
-
+We don't simplify inside InlineRules (which come from INLINE pragmas).
It really is important to switch off inlinings inside such
expressions. Consider the following example
where
phase = getMode env
active = case phase of
- SimplGently -> isAlwaysActive prag
- SimplPhase n _ -> isActive n prag
- prag = idInlinePragma bndr
+ SimplGently -> isEarlyActive act
+ SimplPhase n _ -> isActive n act
+ act = idInlineActivation bndr
try_once in_lam int_cxt -- There's one textual occurrence
| not in_lam = isNotTopLevel top_lvl || early_phase
\begin{code}
postInlineUnconditionally
:: SimplEnv -> TopLevelFlag
- -> InId -- The binder (an OutId would be fine too)
+ -> OutId -- The binder (an InId would be fine too)
-> OccInfo -- From the InId
-> OutExpr
-> Unfolding
| isLoopBreaker occ_info = False -- If it's a loop-breaker of any kind, don't inline
-- because it might be referred to "earlier"
| isExportedId bndr = False
+ | isInlineRule unfolding = False -- Note [InlineRule and postInlineUnconditionally]
| exprIsTrivial rhs = True
| otherwise
= case occ_info of
-- in \y. ....case f of {...} ....
-- Here f is used just once, and duplicating the case work is fine (exprIsCheap).
-- But
--- * We can't preInlineUnconditionally because that woud invalidate
--- the occ info for b.
--- * We can't postInlineUnconditionally because the RHS is big, and
--- that risks exponential behaviour
--- * We can't call-site inline, because the rhs is big
+-- - We can't preInlineUnconditionally because that woud invalidate
+-- the occ info for b.
+-- - We can't postInlineUnconditionally because the RHS is big, and
+-- that risks exponential behaviour
+-- - We can't call-site inline, because the rhs is big
-- Alas!
where
active = case getMode env of
- SimplGently -> isAlwaysActive prag
- SimplPhase n _ -> isActive n prag
- prag = idInlinePragma bndr
+ SimplGently -> isAlwaysActive act
+ SimplPhase n _ -> isActive n act
+ act = idInlineActivation bndr
activeInline :: SimplEnv -> OutId -> Bool
activeInline env id
-- and they are now constructed as Compulsory unfoldings (in MkId)
-- so they'll happen anyway.
- SimplPhase n _ -> isActive n prag
+ SimplPhase n _ -> isActive n act
where
- prag = idInlinePragma id
+ act = idInlineActivation id
activeRule :: DynFlags -> SimplEnv -> Maybe (Activation -> Bool)
-- Nothing => No rules at all
activeRule dflags env
- | not (dopt Opt_RewriteRules dflags)
+ | not (dopt Opt_EnableRewriteRules dflags)
= Nothing -- Rewriting is off
| otherwise
= case getMode env of
SimplPhase n _ -> Just (isActive n)
\end{code}
+Note [InlineRule and postInlineUnconditionally]
+~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~
+Do not do postInlineUnconditionally if the Id has an InlineRule, otherwise
+we lose the unfolding. Example
+
+ -- f has InlineRule with rhs (e |> co)
+ -- where 'e' is big
+ f = e |> co
+
+Then there's a danger we'll optimise to
+
+ f' = e
+ f = f' |> co
+
+and now postInlineUnconditionally, losing the InlineRule on f. Now f'
+won't inline because 'e' is too big.
+
%************************************************************************
%* *
%************************************************************************
\begin{code}
-mkLam :: [OutBndr] -> OutExpr -> SimplM OutExpr
+mkLam :: SimplEnv -> [OutBndr] -> OutExpr -> SimplM OutExpr
-- mkLam tries three things
-- a) eta reduction, if that gives a trivial expression
-- b) eta expansion [only if there are some value lambdas]
-mkLam [] body
+mkLam _b [] body
= return body
-mkLam bndrs body
+mkLam env bndrs body
= do { dflags <- getDOptsSmpl
; mkLam' dflags bndrs body }
where
; return etad_lam }
| dopt Opt_DoLambdaEtaExpansion dflags,
- any isRuntimeVar bndrs
- = do { body' <- tryEtaExpansion dflags body
+ not (inGentleMode env), -- In gentle mode don't eta-expansion
+ any isRuntimeVar bndrs -- because it can clutter up the code
+ -- with casts etc that may not be removed
+ = do { let body' = tryEtaExpansion dflags body
; return (mkLams bndrs body') }
| otherwise
So it's important to to the right thing.
-* We need to be careful if we just look at f's arity. Currently (Dec07),
- f's arity is visible in its own RHS (see Note [Arity robustness] in
- SimplEnv) so we must *not* trust the arity when checking that 'f' is
- a value. Instead, look at the unfolding.
+* Note [Arity care]: we need to be careful if we just look at f's
+ arity. Currently (Dec07), f's arity is visible in its own RHS (see
+ Note [Arity robustness] in SimplEnv) so we must *not* trust the
+ arity when checking that 'f' is a value. Otherwise we will
+ eta-reduce
+ f = \x. f x
+ to
+ f = f
+ Which might change a terminiating program (think (f `seq` e)) to a
+ non-terminating one. So we check for being a loop breaker first.
However for GlobalIds we can look at the arity; and for primops we
must, since they have no unfolding.
with both type and dictionary lambdas; hence the slightly
ad-hoc isDictId
+* Never *reduce* arity. For example
+ f = \xy. g x y
+ Then if h has arity 1 we don't want to eta-reduce because then
+ f's arity would decrease, and that is bad
+
These delicacies are why we don't use exprIsTrivial and exprIsHNF here.
Alas.
tryEtaReduce bndrs body
= go (reverse bndrs) body
where
+ incoming_arity = count isId bndrs
+
go (b : bs) (App fun arg) | ok_arg b arg = go bs fun -- Loop round
go [] fun | ok_fun fun = Just fun -- Success!
go _ _ = Nothing -- Failure!
&& (ok_fun_id fun_id || all ok_lam bndrs)
ok_fun _fun = False
- ok_fun_id fun
- | isLocalId fun = isEvaldUnfolding (idUnfolding fun)
- | isDataConWorkId fun = True
- | isGlobalId fun = idArity fun > 0
- | otherwise = panic "tryEtaReduce/ok_fun_id"
+ ok_fun_id fun = fun_arity fun >= incoming_arity
+
+ fun_arity fun -- See Note [Arity care]
+ | isLocalId fun && isLoopBreaker (idOccInfo fun) = 0
+ | otherwise = idArity fun
ok_lam v = isTyVar v || isDictId v
actually computing the expansion.
\begin{code}
-tryEtaExpansion :: DynFlags -> OutExpr -> SimplM OutExpr
+tryEtaExpansion :: DynFlags -> OutExpr -> OutExpr
-- There is at least one runtime binder in the binders
-tryEtaExpansion dflags body = do
- us <- getUniquesM
- return (etaExpand fun_arity us body (exprType body))
+tryEtaExpansion dflags body
+ = etaExpand fun_arity body
where
fun_arity = exprEtaExpandArity dflags body
\end{code}
= do { uniq <- getUniqueM
; let poly_name = setNameUnique (idName var) uniq -- Keep same name
poly_ty = mkForAllTys tvs_here (idType var) -- But new type of course
- poly_id = transferPolyIdInfo var $ -- Note [transferPolyIdInfo] in Id.lhs
+ poly_id = transferPolyIdInfo var tvs_here $ -- Note [transferPolyIdInfo] in Id.lhs
mkLocalId poly_name poly_ty
; return (poly_id, mkTyApps (Var poly_id) (mkTyVarTys tvs_here)) }
-- In the olden days, it was crucial to copy the occInfo of the original var,
_ -> return [(DEFAULT, [], deflt_rhs)]
+ | debugIsOn, isAlgTyCon tycon, not (isOpenTyCon tycon), null (tyConDataCons tycon)
+ -- This can legitimately happen for type families, so don't report that
+ = pprTrace "prepareDefault" (ppr case_bndr <+> ppr tycon)
+ $ return [(DEFAULT, [], deflt_rhs)]
+
--------- Catch-all cases -----------
prepareDefault _dflags _env _case_bndr _bndr_ty _imposs_cons (Just deflt_rhs)
= return [(DEFAULT, [], deflt_rhs)]
projects / ghc-hetmet.git / blobdiff