mkCompulsoryUnfolding, seqUnfolding,
evaldUnfolding, mkOtherCon, otherCons,
unfoldingTemplate, maybeUnfoldingTemplate,
- isEvaldUnfolding, isValueUnfolding, isCheapUnfolding, isCompulsoryUnfolding,
+ isEvaldUnfolding, isValueUnfolding, isExpandableUnfolding, isCompulsoryUnfolding,
hasUnfolding, hasSomeUnfolding, neverUnfold,
couldBeSmallEnoughToInline,
= CoreUnfolding (simpleOptExpr emptySubst expr)
True
(exprIsHNF expr)
- (exprIsCheap expr)
+ (exprIsCheap expr)
+ (exprIsExpandable expr)
(calcUnfoldingGuidance opt_UF_CreationThreshold expr)
mkUnfolding :: Bool -> CoreExpr -> Unfolding
(exprIsCheap expr)
-- OK to inline inside a lambda
+ (exprIsExpandable expr)
+
(calcUnfoldingGuidance 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
ppr NoUnfolding = ptext (sLit "No unfolding")
ppr (OtherCon cs) = ptext (sLit "OtherCon") <+> ppr cs
ppr (CompulsoryUnfolding e) = ptext (sLit "Compulsory") <+> ppr e
- ppr (CoreUnfolding e top hnf cheap g)
- = ptext (sLit "Unf") <+> sep [ppr top <+> ppr hnf <+> ppr cheap <+> ppr g,
+ ppr (CoreUnfolding e top hnf cheap expable g)
+ = ptext (sLit "Unf") <+> sep [ppr top <+> ppr hnf <+> ppr cheap <+> ppr expable <+> ppr g,
ppr e]
mkCompulsoryUnfolding :: CoreExpr -> Unfolding
| fun `hasKey` buildIdKey = buildSize
| fun `hasKey` augmentIdKey = augmentSize
| otherwise
- = case globalIdDetails fun of
+ = case idDetails fun of
DataConWorkId dc -> conSizeN dc (valArgCount args)
FCallId _ -> sizeN opt_UF_DearOp
certainlyWillInline :: Unfolding -> Bool
-- Sees if the unfolding is pretty certain to inline
-certainlyWillInline (CoreUnfolding _ _ _ is_cheap (UnfoldIfGoodArgs n_vals _ size _))
+certainlyWillInline (CoreUnfolding _ _ _ is_cheap _ (UnfoldIfGoodArgs n_vals _ size _))
= is_cheap && size - (n_vals +1) <= opt_UF_UseThreshold
certainlyWillInline _
= False
smallEnoughToInline :: Unfolding -> Bool
-smallEnoughToInline (CoreUnfolding _ _ _ _ (UnfoldIfGoodArgs _ _ size _))
+smallEnoughToInline (CoreUnfolding _ _ _ _ _ (UnfoldIfGoodArgs _ _ size _))
= size <= opt_UF_UseThreshold
smallEnoughToInline _
= False
-- => be keener to inline
-- INVARIANT: ArgCtxt False 0 ==> BoringCtxt
+ | ValAppCtxt -- We're applied to at least one value arg
+ -- This arises when we have ((f x |> co) y)
+ -- Then the (f x) has argument 'x' but in a ValAppCtxt
+
| CaseCtxt -- We're the scrutinee of a case
-- that decomposes its scrutinee
ppr BoringCtxt = ptext (sLit "BoringCtxt")
ppr (ArgCtxt _ _) = ptext (sLit "ArgCtxt")
ppr CaseCtxt = ptext (sLit "CaseCtxt")
+ ppr ValAppCtxt = ptext (sLit "ValAppCtxt")
callSiteInline dflags active_inline id lone_variable arg_infos cont_info
= case idUnfolding id of {
-- compulsory unfoldings (see MkId.lhs).
-- We don't allow them to be inactive
- CoreUnfolding unf_template is_top is_value is_cheap guidance ->
+ CoreUnfolding unf_template is_top is_value is_cheap is_expable guidance ->
let
result | yes_or_no = Just unf_template
-> True
| otherwise
- -> some_benefit && small_enough
+ -> some_benefit && small_enough && inline_enough_args
where
enough_args = n_val_args >= n_vals_wanted
+ inline_enough_args =
+ not (dopt Opt_InlineIfEnoughArgs dflags) || enough_args
+
some_benefit = or arg_infos || really_interesting_cont
-- There must be something interesting
= case cont_info of
BoringCtxt -> not is_top && n_vals_wanted > 0 -- Note [Nested functions]
CaseCtxt -> not lone_variable || not is_value -- Note [Lone variables]
- ArgCtxt {} -> n_vals_wanted > 0
- -- See Note [Inlining in ArgCtxt]
+ ArgCtxt {} -> n_vals_wanted > 0 -- Note [Inlining in ArgCtxt]
+ ValAppCtxt -> True -- Note [Cast then apply]
small_enough = (size - discount) <= opt_UF_UseThreshold
discount = computeDiscount n_vals_wanted arg_discounts
res_discount' = case cont_info of
BoringCtxt -> 0
CaseCtxt -> res_discount
- ArgCtxt _ _ -> 4 `min` res_discount
+ _other -> 4 `min` res_discount
-- res_discount can be very large when a function returns
-- construtors; but we only want to invoke that large discount
-- when there's a case continuation.
in
if dopt Opt_D_dump_inlinings dflags then
- pprTrace "Considering inlining"
- (ppr id <+> vcat [text "active:" <+> ppr active_inline,
- text "arg infos" <+> ppr arg_infos,
- text "interesting continuation" <+> ppr cont_info,
- text "is value:" <+> ppr is_value,
- text "is cheap:" <+> ppr is_cheap,
- text "guidance" <+> ppr guidance,
- text "ANSWER =" <+> if yes_or_no then text "YES" else text "NO"])
+ pprTrace ("Considering inlining: " ++ showSDoc (ppr id))
+ (vcat [text "active:" <+> ppr active_inline,
+ text "arg infos" <+> ppr arg_infos,
+ text "interesting continuation" <+> ppr cont_info,
+ text "is value:" <+> ppr is_value,
+ text "is cheap:" <+> ppr is_cheap,
+ text "is expandable:" <+> ppr is_expable,
+ text "guidance" <+> ppr guidance,
+ text "ANSWER =" <+> if yes_or_no then text "YES" else text "NO"])
result
else
result
increase the chance that the constructor won't be allocated at all in
the branches that don't use it.
+Note [Cast then apply]
+~~~~~~~~~~~~~~~~~~~~~~
+Consider
+ myIndex = __inline_me ( (/\a. <blah>) |> co )
+ co :: (forall a. a -> a) ~ (forall a. T a)
+ ... /\a.\x. case ((myIndex a) |> sym co) x of { ... } ...
+
+We need to inline myIndex to unravel this; but the actual call (myIndex a) has
+no value arguments. The ValAppCtxt gives it enough incentive to inline.
+
Note [Inlining in ArgCtxt]
~~~~~~~~~~~~~~~~~~~~~~~~~~
The condition (n_vals_wanted > 0) here is very important, because otherwise
to work ok now.
Note [Lone variables]
-~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~
+~~~~~~~~~~~~~~~~~~~~~
The "lone-variable" case is important. I spent ages messing about
with unsatisfactory varaints, but this is nice. The idea is that if a
variable appears all alone
----------------------
go_nonrec subst b (Type ty') body
| isTyVar b = go (extendTvSubst subst b ty') body
+ -- let a::* = TYPE ty in <body>
go_nonrec subst b r' body
- | isId b
+ | isId b -- let x = e in <body>
, exprIsTrivial r' || safe_to_inline (idOccInfo b)
= go (extendIdSubst subst b r') body
go_nonrec subst b r' body
projects / ghc-hetmet.git / blobdiff