interestingArg, ArgSummary(..),
- couldBeSmallEnoughToInline,
+ couldBeSmallEnoughToInline, inlineBoringOk,
certainlyWillInline, smallEnoughToInline,
callSiteInline, CallCtxt(..),
import DynFlags
import CoreSyn
import PprCore () -- Instances
-import TcType ( tcSplitSigmaTy, tcSplitDFunHead )
-import OccurAnal
+import TcType ( tcSplitDFunTy )
+import OccurAnal ( occurAnalyseExpr )
import CoreSubst hiding( substTy )
import CoreFVs ( exprFreeVars )
import CoreArity ( manifestArity, exprBotStrictness_maybe )
import PrimOp
import IdInfo
import BasicTypes ( Arity )
-import TcType ( tcSplitDFunTy )
-import Type
+import Type
import Coercion
import PrelNames
import VarEnv ( mkInScopeSet )
mkDFunUnfolding dfun_ty ops
= DFunUnfolding dfun_nargs data_con ops
where
- (tvs, theta, head_ty) = tcSplitSigmaTy dfun_ty
- -- NB: tcSplitSigmaTy: do not look through a newtype
- -- when the dictionary type is a newtype
- (cls, _) = tcSplitDFunHead head_ty
- dfun_nargs = length tvs + length theta
+ (tvs, n_theta, cls, _) = tcSplitDFunTy dfun_ty
+ dfun_nargs = length tvs + n_theta
data_con = classDataCon cls
mkWwInlineRule :: Id -> CoreExpr -> Arity -> Unfolding
Nothing -> (unSaturatedOk, manifestArity expr')
Just ar -> (needSaturated, ar)
- boring_ok = case calcUnfoldingGuidance True -- Treat as cheap
- False -- But not bottoming
- (arity+1) expr' of
- (_, UnfWhen _ boring_ok) -> boring_ok
- _other -> boringCxtNotOk
- -- See Note [INLINE for small functions]
+ boring_ok = inlineBoringOk expr'
mkInlinableUnfolding :: CoreExpr -> Unfolding
mkInlinableUnfolding expr
-- Calculates unfolding guidance
-- Occurrence-analyses the expression before capturing it
mkUnfolding src top_lvl is_bottoming expr
+ | top_lvl && is_bottoming
+ , not (exprIsTrivial expr)
+ = NoUnfolding -- See Note [Do not inline top-level bottoming functions]
+ | otherwise
= CoreUnfolding { uf_tmpl = occurAnalyseExpr expr,
uf_src = src,
uf_arity = arity,
uf_guidance = guidance }
where
is_cheap = exprIsCheap expr
- (arity, guidance) = calcUnfoldingGuidance is_cheap (top_lvl && is_bottoming)
+ (arity, guidance) = calcUnfoldingGuidance is_cheap
opt_UF_CreationThreshold expr
-- Sometimes during simplification, there's a large let-bound thing
-- which has been substituted, and so is now dead; so 'expr' contains
%************************************************************************
\begin{code}
+inlineBoringOk :: CoreExpr -> Bool
+-- See Note [INLINE for small functions]
+-- True => the result of inlining the expression is
+-- no bigger than the expression itself
+-- eg (\x y -> f y x)
+-- This is a quick and dirty version. It doesn't attempt
+-- to deal with (\x y z -> x (y z))
+-- The really important one is (x `cast` c)
+inlineBoringOk e
+ = go 0 e
+ where
+ go :: Int -> CoreExpr -> Bool
+ go credit (Lam x e) | isId x = go (credit+1) e
+ | otherwise = go credit e
+ go credit (App f (Type {})) = go credit f
+ go credit (App f a) | credit > 0
+ , exprIsTrivial a = go (credit-1) f
+ go credit (Note _ e) = go credit e
+ go credit (Cast e _) = go credit e
+ go _ (Var {}) = boringCxtOk
+ go _ _ = boringCxtNotOk
+
calcUnfoldingGuidance
:: Bool -- True <=> the rhs is cheap, or we want to treat it
-- as cheap (INLINE things)
- -> Bool -- True <=> this is a top-level unfolding for a
- -- diverging function; don't inline this
-> Int -- Bomb out if size gets bigger than this
-> CoreExpr -- Expression to look at
-> (Arity, UnfoldingGuidance)
-calcUnfoldingGuidance expr_is_cheap top_bot bOMB_OUT_SIZE expr
+calcUnfoldingGuidance expr_is_cheap bOMB_OUT_SIZE expr
= case collectBinders expr of { (bndrs, body) ->
let
val_bndrs = filter isId bndrs
| uncondInline n_val_bndrs (iBox size)
, expr_is_cheap
-> UnfWhen unSaturatedOk boringCxtOk -- Note [INLINE for small functions]
- | top_bot -- See Note [Do not inline top-level bottoming functions]
- -> UnfNever
-
| otherwise
-> UnfIfGoodArgs { ug_args = map (discount cased_bndrs) val_bndrs
, ug_size = iBox size
-- be a loop breaker (maybe the knot is not yet untied)
CoreUnfolding { uf_tmpl = unf_template, uf_is_top = is_top
, uf_is_cheap = is_cheap, uf_arity = uf_arity
- , uf_guidance = guidance }
+ , uf_guidance = guidance, uf_expandable = is_exp }
| active_unfolding -> tryUnfolding dflags id lone_variable
arg_infos cont_info unf_template is_top
- is_cheap uf_arity guidance
+ is_cheap is_exp uf_arity guidance
| otherwise -> Nothing
NoUnfolding -> Nothing
OtherCon {} -> Nothing
DFunUnfolding {} -> Nothing -- Never unfold a DFun
tryUnfolding :: DynFlags -> Id -> Bool -> [ArgSummary] -> CallCtxt
- -> CoreExpr -> Bool -> Bool -> Arity -> UnfoldingGuidance
+ -> CoreExpr -> Bool -> Bool -> Bool -> Arity -> UnfoldingGuidance
-> Maybe CoreExpr
tryUnfolding dflags id lone_variable
arg_infos cont_info unf_template is_top
- is_cheap uf_arity guidance
+ is_cheap is_exp uf_arity guidance
-- uf_arity will typically be equal to (idArity id),
-- but may be less for InlineRules
| dopt Opt_D_dump_inlinings dflags && dopt Opt_D_verbose_core2core dflags
text "uf arity" <+> ppr uf_arity,
text "interesting continuation" <+> ppr cont_info,
text "some_benefit" <+> ppr some_benefit,
+ text "is exp:" <+> ppr is_exp,
text "is cheap:" <+> ppr is_cheap,
text "guidance" <+> ppr guidance,
extra_doc,
interesting_saturated_call
= case cont_info of
- BoringCtxt -> not is_top && uf_arity > 0 -- Note [Nested functions]
+ BoringCtxt -> not is_top && uf_arity > 0 -- Note [Nested functions]
CaseCtxt -> not (lone_variable && is_cheap) -- Note [Lone variables]
- ArgCtxt {} -> uf_arity > 0 -- Note [Inlining in ArgCtxt]
- ValAppCtxt -> True -- Note [Cast then apply]
+ ArgCtxt {} -> uf_arity > 0 -- Note [Inlining in ArgCtxt]
+ ValAppCtxt -> True -- Note [Cast then apply]
(yes_or_no, extra_doc)
= case guidance of
, let sat = length args == dfun_nargs -- See Note [DFun arity check]
in if sat then True else
pprTrace "Unsaturated dfun" (ppr fun <+> int dfun_nargs $$ ppr args) False
- , let (dfun_tvs, _cls, dfun_res_tys) = tcSplitDFunTy (idType fun)
+ , let (dfun_tvs, _n_theta, _cls, dfun_res_tys) = tcSplitDFunTy (idType fun)
subst = zipOpenTvSubst dfun_tvs (stripTypeArgs (takeList dfun_tvs args))
mk_arg (DFunConstArg e) = e
mk_arg (DFunLamArg i) = args !! i
projects / ghc-hetmet.git / blobdiff