substUnfolding subst unf@(CoreUnfolding { uf_tmpl = tmpl, uf_guidance = guide@(InlineRule {}) })
-- Retain an InlineRule!
= seqExpr new_tmpl `seq`
- new_mb_wkr `seq`
- unf { uf_tmpl = new_tmpl, uf_guidance = guide { ug_ir_info = new_mb_wkr } }
+ new_info `seq`
+ unf { uf_tmpl = new_tmpl, uf_guidance = guide { ir_info = new_info } }
where
- new_tmpl = substExpr subst tmpl
- new_mb_wkr = substInlineRuleGuidance subst (ug_ir_info guide)
+ new_tmpl = substExpr subst tmpl
+ new_info = substInlineRuleInfo subst (ir_info guide)
substUnfolding _ (CoreUnfolding {}) = NoUnfolding -- Discard
-- Always zap a CoreUnfolding, to save substitution work
-substUnfolding _ unf = unf -- Otherwise no substitution to do
+substUnfolding _ unf = unf -- NoUnfolding, OtherCon
-------------------
-substInlineRuleGuidance :: Subst -> InlineRuleInfo -> InlineRuleInfo
-substInlineRuleGuidance subst (InlWrapper wkr)
+substInlineRuleInfo :: Subst -> InlineRuleInfo -> InlineRuleInfo
+substInlineRuleInfo subst (InlWrapper wkr)
= case lookupIdSubst subst wkr of
Var w1 -> InlWrapper w1
other -> WARN( not (exprIsTrivial other), text "CoreSubst.substWorker:" <+> ppr wkr )
- InlUnSat -- Worker has got substituted away altogether
+ InlVanilla -- Worker has got substituted away altogether
-- (This can happen if it's trivial, via
-- postInlineUnconditionally, hence only warning)
-substInlineRuleGuidance _ info = info
+substInlineRuleInfo _ info = info
------------------
substIdOcc :: Subst -> Id -> Id
isValArg, isTypeArg, valArgCount, valBndrCount, isRuntimeArg, isRuntimeVar,
-- * Unfolding data types
- Unfolding(..), UnfoldingGuidance(..), InlineRuleInfo(..),
+ Unfolding(..), UnfoldingGuidance(..), InlineRuleInfo(..), InlSatFlag(..),
-- Abstract everywhere but in CoreUnfold.lhs
-- ** Constructing 'Unfolding's
------------------------------------------------
-- | 'UnfoldingGuidance' says when unfolding should take place
data UnfoldingGuidance
- = UnfoldAlways -- There is /no original definition/, so you'd better unfold.
- -- The unfolding is guaranteed to have no free variables
- -- so no need to think about it during dependency analysis
-
- | InlineRule { -- See Note [InlineRules]
- -- Be very keen to inline this
+ = InlineRule { -- Be very keen to inline this; See Note [InlineRules]
-- The uf_tmpl is the *original* RHS; do *not* replace it on
-- each simlifier run. Hence, the *actual* RHS of the function
-- may be different by now, because it may have been optimised.
- ug_ir_info :: InlineRuleInfo, -- Supplementary info about the InlineRule
- ug_small :: Bool -- True <=> the RHS is so small (eg no bigger than a call)
- -- that you should always inline a saturated call,
- } -- regardless of how boring the context is
- -- See Note [INLINE for small functions] in CoreUnfold]
+
+ ir_sat :: InlSatFlag,
+ ir_info :: InlineRuleInfo
+ }
| UnfoldIfGoodArgs { -- Arose from a normal Id; the info here is the
-- result of a simple analysis of the RHS
} -- a context (case (thing args) of ...),
-- (where there are the right number of arguments.)
- | UnfoldNever
+ | UnfoldNever -- A variant of UnfoldIfGoodArgs, used for big RHSs
data InlineRuleInfo
- = InlSat -- A user-specifed or compiler injected INLINE pragma
- -- ONLY inline when it's applied to 'arity' arguments
+ = InlAlways -- Inline absolutely always, however boring the context.
+ -- There is /no original definition/. Only a few primop-like things
+ -- have this property (see MkId.lhs, calls to mkCompulsoryUnfolding).
+
+ | InlSmall -- The RHS is very small (eg no bigger than a call), so inline any
+ -- /saturated/ application, regardless of context
+ -- See Note [INLINE for small functions] in CoreUnfold
+
+ | InlVanilla
- | InlUnSat -- The compiler decided to "capture" the RHS into an
- -- InlineRule, but do not require that it appears saturated
+ | InlWrapper Id -- This unfolding is a the wrapper in a
+ -- worker/wrapper split from the strictness analyser
+ -- Used to abbreviate the uf_tmpl in interface files
+ -- which don't need to contain the RHS;
+ -- it can be derived from the strictness info
+ -- [In principle this is orthogonal to the InlSmall/InVanilla thing,
+ -- but it's convenient to have it here.]
- | InlWrapper Id -- This unfolding is a the wrapper in a
- -- worker/wrapper split from the strictness analyser
- -- Used to abbreviate the uf_tmpl in interface files
- -- which don't need to contain the RHS;
- -- it can be derived from the strictness info
+data InlSatFlag = InlSat | InlUnSat
+ -- Specifies whether to INLINE only if the thing is applied to 'arity' args
------------------------------------------------
noUnfolding :: Unfolding
isInlineRule (CoreUnfolding { uf_guidance = InlineRule {}}) = True
isInlineRule _ = False
-isInlineRule_maybe :: Unfolding -> Maybe InlineRuleInfo
-isInlineRule_maybe (CoreUnfolding {
- uf_guidance = InlineRule { ug_ir_info = inl } }) = Just inl
-isInlineRule_maybe _ = Nothing
+isInlineRule_maybe :: Unfolding -> Maybe (InlineRuleInfo, InlSatFlag)
+isInlineRule_maybe (CoreUnfolding { uf_guidance =
+ InlineRule { ir_info = inl, ir_sat = sat } }) = Just (inl,sat)
+isInlineRule_maybe _ = Nothing
isStableUnfolding :: Unfolding -> Bool
-- True of unfoldings that should not be overwritten
-- For implicit Ids, do a tiny bit of optimising first
mkImplicitUnfolding expr = mkTopUnfolding (simpleOptExpr expr)
-mkWwInlineRule :: Id -> CoreExpr -> Arity -> Unfolding
-mkWwInlineRule id = mkInlineRule (InlWrapper id)
-
-mkInlineRule :: InlineRuleInfo -> CoreExpr -> Arity -> Unfolding
-mkInlineRule inl_info expr arity
- = mkCoreUnfolding True -- Note [Top-level flag on inline rules]
- expr' arity
- (InlineRule { ug_ir_info = inl_info, ug_small = small })
- where
- expr' = simpleOptExpr expr
- small = case calcUnfoldingGuidance (arity+1) expr' of
- (arity_e, UnfoldIfGoodArgs { ug_size = size_e })
- -> uncondInline arity_e size_e
- _other {- actually UnfoldNever -} -> False
-
-- Note [Top-level flag on inline rules]
-- ~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~
-- Slight hack: note that mk_inline_rules conservatively sets the
mkDFunUnfolding :: DataCon -> [Id] -> Unfolding
mkDFunUnfolding con ops = DFunUnfolding con (map Var ops)
+mkWwInlineRule :: Id -> CoreExpr -> Arity -> Unfolding
+mkWwInlineRule id expr arity
+ = mkCoreUnfolding True (simpleOptExpr expr) arity
+ (InlineRule { ir_sat = InlUnSat, ir_info = InlWrapper id })
+
mkCompulsoryUnfolding :: CoreExpr -> Unfolding
-mkCompulsoryUnfolding expr -- Used for things that absolutely must be unfolded
- = mkCoreUnfolding True expr 0 UnfoldAlways -- Arity of unfolding doesn't matter
+mkCompulsoryUnfolding expr -- Used for things that absolutely must be unfolded
+ = mkCoreUnfolding True expr 0 -- Arity of unfolding doesn't matter
+ (InlineRule { ir_info = InlAlways, ir_sat = InlUnSat })
+
+mkInlineRule :: InlSatFlag -> CoreExpr -> Arity -> Unfolding
+mkInlineRule sat expr arity
+ = mkCoreUnfolding True -- Note [Top-level flag on inline rules]
+ expr' arity
+ (InlineRule { ir_sat = sat, ir_info = info })
+ where
+ expr' = simpleOptExpr expr
+ info = if small then InlSmall else InlVanilla
+ small = case calcUnfoldingGuidance (arity+1) expr' of
+ (arity_e, UnfoldIfGoodArgs { ug_size = size_e })
+ -> uncondInline arity_e size_e
+ _other {- actually UnfoldNever -} -> False
\end{code}
-- Sees if the unfolding is pretty certain to inline
certainlyWillInline (CoreUnfolding { uf_is_cheap = is_cheap, uf_arity = n_vals, uf_guidance = guidance })
= case guidance of
- UnfoldAlways {} -> True
UnfoldNever -> False
InlineRule {} -> True
UnfoldIfGoodArgs { ug_size = size}
= case guidance of
UnfoldNever -> False
- UnfoldAlways -> True
- -- UnfoldAlways => there is no top-level binding for
- -- these things, so we must inline it. Only a few
- -- primop-like things have compulsory unfoldings (see
- -- MkId.lhs). Ignore is_active because we want to
- -- inline even if SimplGently is on.
-
- InlineRule { ug_ir_info = inl_info, ug_small = uncond_inline }
+ InlineRule { ir_info = inl_info, ir_sat = sat }
+ | InlAlways <- inl_info -> True -- No top-level binding, so inline!
+ -- Ignore is_active because we want to
+ -- inline even if SimplGently is on.
| not active_inline -> False
| n_val_args < uf_arity -> yes_unsat -- Not enough value args
- | uncond_inline -> True -- Note [INLINE for small functions]
+ | InlSmall <- inl_info -> True -- Note [INLINE for small functions]
| otherwise -> some_benefit -- Saturated or over-saturated
where
-- See Note [Inlining an InlineRule]
- yes_unsat = case inl_info of
- InlSat -> False
- _other -> interesting_args
+ yes_unsat = case sat of
+ InlSat -> False
+ InlUnSat -> interesting_args
UnfoldIfGoodArgs { ug_args = arg_discounts, ug_res = res_discount, ug_size = size }
| not active_inline -> False
g y = f y
Then f's RHS is no larger than its LHS, so we should inline it
into even the most boring context. (We do so if there is no INLINE
-pragma!) That's the reason for the 'inl_small' flag on an InlineRule.
+pragma!) That's the reason for the 'ug_small' flag on an InlineRule.
Note [Things to watch]
CaseCtxt -> 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
+ -- constructors; but we only want to invoke that large discount
-- when there's a case continuation.
-- Otherwise we, rather arbitrarily, threshold it. Yuk.
-- But we want to aovid inlining large functions that return
\begin{code}
instance Outputable UnfoldingGuidance where
ppr UnfoldNever = ptext (sLit "NEVER")
- ppr UnfoldAlways = ptext (sLit "ALWAYS")
- ppr (InlineRule { ug_ir_info = inl_info, ug_small = small })
- = ptext (sLit "InlineRule") <> ppr (inl_info,small)
+ ppr (InlineRule { ir_info = info, ir_sat = sat })
+ = ptext (sLit "InlineRule") <> ppr (sat,info)
ppr (UnfoldIfGoodArgs { ug_args = cs, ug_size = size, ug_res = discount })
= hsep [ ptext (sLit "IF_ARGS"),
brackets (hsep (map int cs)),
int size,
int discount ]
-instance Outputable InlineRuleInfo where
- ppr (InlWrapper w) = ptext (sLit "worker=") <> ppr w
+instance Outputable InlSatFlag where
ppr InlSat = ptext (sLit "sat")
ppr InlUnSat = ptext (sLit "unsat")
+instance Outputable InlineRuleInfo where
+ ppr (InlWrapper w) = ptext (sLit "worker=") <> ppr w
+ ppr InlSmall = ptext (sLit "small")
+ ppr InlAlways = ptext (sLit "always")
+ ppr InlVanilla = ptext (sLit "-")
+
instance Outputable Unfolding where
ppr NoUnfolding = ptext (sLit "No unfolding")
ppr (OtherCon cs) = ptext (sLit "OtherCon") <+> ppr cs
toIfUnfolding :: Unfolding -> Maybe IfaceInfoItem
toIfUnfolding (CoreUnfolding { uf_tmpl = rhs, uf_arity = arity, uf_guidance = guidance })
= case guidance of
- InlineRule { ug_ir_info = InlSat } -> Just (HsUnfold (IfInlineRule arity True (toIfaceExpr rhs)))
- InlineRule { ug_ir_info = InlUnSat } -> Just (HsUnfold (IfInlineRule arity False (toIfaceExpr rhs)))
- InlineRule { ug_ir_info = InlWrapper w } -> Just (HsUnfold (IfWrapper arity (idName w)))
+ InlineRule { ir_info = InlWrapper w } -> Just (HsUnfold (IfWrapper arity (idName w)))
+ InlineRule { ir_sat = InlSat } -> Just (HsUnfold (IfInlineRule arity True (toIfaceExpr rhs)))
+ InlineRule { ir_sat = InlUnSat } -> Just (HsUnfold (IfInlineRule arity False (toIfaceExpr rhs)))
UnfoldNever -> Nothing
UnfoldIfGoodArgs {} -> Just (HsUnfold (IfCoreUnfold (toIfaceExpr rhs)))
- UnfoldAlways -> panic "toIfUnfolding:UnfoldAlways"
- -- Never happens because we never have
- -- bindings for unfold-always things
+
toIfUnfolding (DFunUnfolding _con ops)
= Just (HsUnfold (IfDFunUnfold (map toIfaceExpr ops)))
-- No need to serialise the data constructor;
tidyUnfolding tidy_env _ unf@(CoreUnfolding { uf_tmpl = rhs
, uf_guidance = guide@(InlineRule {}) })
= unf { uf_tmpl = tidyExpr tidy_env rhs, -- Preserves OccInfo
- uf_guidance = guide { ug_ir_info = tidyInl tidy_env (ug_ir_info guide) } }
+ uf_guidance = guide { ir_info = tidyInl tidy_env (ir_info guide) } }
tidyUnfolding tidy_env _ (DFunUnfolding con ids)
= DFunUnfolding con (map (tidyExpr tidy_env) ids)
tidyUnfolding _ tidy_rhs (CoreUnfolding {})
-- where df is the exported dictionary. Then df makes a really
-- bad choice for loop breaker
- | Just inl_rule_info <- isInlineRule_maybe (idUnfolding bndr)
+ | Just (inl_rule_info, _) <- isInlineRule_maybe (idUnfolding bndr)
= case inl_rule_info of
InlWrapper {} -> 10 -- Note [INLINE pragmas]
_other -> 3 -- Data structures are more important than this
settings:
SimplGently (a) Simplifying before specialiser/full laziness
- (b) Simplifiying inside INLINE pragma
+ (b) Simplifiying inside InlineRules
(c) Simplifying the LHS of a rule
(d) Simplifying a GHCi expression or Template
Haskell splice
anything, because the byte-code interpreter might get confused about
unboxed tuples and suchlike.
-INLINE pragmas
-~~~~~~~~~~~~~~
-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
+Note [Simplifying gently inside InlineRules]
+~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~
+We don't do much simplification inside InlineRules (which come from
+INLINE pragmas). It really is important to switch off inlinings
+inside such expressions. Consider the following example
let f = \pq -> BIG
in
in ...g...g...g...g...g...
Now, if that's the ONLY occurrence of f, it will be inlined inside g,
-and thence copied multiple times when g is inlined.
+and thence copied multiple times when g is inlined.
-
-This function may be inlinined in other modules, so we
-don't want to remove (by inlining) calls to functions that have
-specialisations, or that may have transformation rules in an importing
-scope.
+This function may be inlinined in other modules, so we don't want to
+remove (by inlining) calls to functions that have specialisations, or
+that may have transformation rules in an importing scope.
E.g. {-# INLINE f #-}
- f x = ...g...
+ f x = ...g...
and suppose that g is strict *and* has specialisations. If we inline
g's wrapper, we deny f the chance of getting the specialised version
ArgOf continuations. It shouldn't do any harm not to dissolve the
inline-me note under these circumstances.
-Note that the result is that we do very little simplification
-inside an InlineMe.
+Although we do very little simplification inside an InlineRule,
+the RHS is simplified as normal. For example:
all xs = foldr (&&) True xs
any p = all . map p {-# INLINE any #-}
-Problem: any won't get deforested, and so if it's exported and the
-importer doesn't use the inlining, (eg passes it as an arg) then we
-won't get deforestation at all. We havn't solved this problem yet!
+The RHS of 'any' will get optimised and deforested; but the InlineRule
+will still mention the original RHS.
preInlineUnconditionally
(CoreUnfolding { uf_tmpl = expr, uf_arity = arity
, uf_guidance = guide@(InlineRule {}) })
= do { expr' <- simplExpr (setMode SimplGently env) expr
- ; let mb_wkr' = CoreSubst.substInlineRuleGuidance (mkCoreSubst env) (ug_ir_info guide)
+ -- 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 { ug_ir_info = mb_wkr' })) }
+ (guide { ir_info = mb_wkr' })) }
-- See Note [Top-level flag on inline rules] in CoreUnfold
simplUnfolding _ top_lvl _ occ_info new_rhs _
import MkId ( voidArgId, realWorldPrimId )
import FiniteMap
import Maybes ( catMaybes, isJust )
-import BasicTypes ( Arity )
import Bag
import Util
import Outputable
-- Figure out whether the function has an INLINE pragma
-- See Note [Inline specialisations]
- fn_has_inline_rule :: Maybe (InlineRuleInfo, Arity) -- Gives arity of the *specialised* inline rule
- fn_has_inline_rule
- | Just inl <- isInlineRule_maybe fn_unf
- = case inl of
- InlWrapper _ -> Just (InlUnSat, spec_arity)
- _ -> Just (inl, spec_arity)
- | otherwise = Nothing
- where
- spec_arity = unfoldingArity fn_unf - n_dicts
+ fn_has_inline_rule :: Maybe InlSatFlag -- Derive sat-flag from existing thing
+ fn_has_inline_rule = case isInlineRule_maybe fn_unf of
+ Just (_,sat) -> Just sat
+ Nothing -> Nothing
+
+ spec_arity = unfoldingArity fn_unf - n_dicts -- Arity of the *specialised* inline rule
(rhs_tyvars, rhs_ids, rhs_body) = collectTyAndValBinders rhs
final_uds = foldr consDictBind rhs_uds dx_binds
-- See Note [Inline specialisations]
- final_spec_f | Just (inl, spec_arity) <- fn_has_inline_rule
+ final_spec_f | Just sat <- fn_has_inline_rule
= spec_f_w_arity `setInlineActivation` inline_act
- `setIdUnfolding` mkInlineRule inl spec_rhs spec_arity
+ `setIdUnfolding` mkInlineRule sat spec_rhs spec_arity
-- I'm not sure this should be unconditionally InlSat
| otherwise
= spec_f_w_arity
projects / ghc-hetmet.git / commitdiff