module CoreUnfold (
Unfolding, UnfoldingGuidance, -- Abstract types
- noUnfolding, mkTopUnfolding, mkUnfolding, mkCompulsoryUnfolding, seqUnfolding,
+ noUnfolding, mkTopUnfolding, mkImplicitUnfolding, mkUnfolding,
+ mkCompulsoryUnfolding, seqUnfolding,
evaldUnfolding, mkOtherCon, otherCons,
unfoldingTemplate, maybeUnfoldingTemplate,
isEvaldUnfolding, isValueUnfolding, isCheapUnfolding, isCompulsoryUnfolding,
) where
-#include "HsVersions.h"
-
import StaticFlags
import DynFlags
import CoreSyn
import PprCore () -- Instances
import OccurAnal
+import CoreSubst ( Subst, emptySubst, substTy, extendIdSubst, extendTvSubst
+ , lookupIdSubst, substBndr, substBndrs, substRecBndrs )
import CoreUtils
import Id
import DataCon
import Literal
import PrimOp
import IdInfo
-import Type
+import Type hiding( substTy, extendTvSubst )
import PrelNames
import Bag
import FastTypes
+import FastString
import Outputable
\end{code}
mkTopUnfolding :: CoreExpr -> Unfolding
mkTopUnfolding expr = mkUnfolding True {- Top level -} expr
+mkImplicitUnfolding :: CoreExpr -> Unfolding
+-- For implicit Ids, do a tiny bit of optimising first
+mkImplicitUnfolding expr
+ = CoreUnfolding (simpleOptExpr emptySubst expr)
+ True
+ (exprIsHNF expr)
+ (exprIsCheap expr)
+ (calcUnfoldingGuidance opt_UF_CreationThreshold expr)
+
mkUnfolding :: Bool -> CoreExpr -> Unfolding
mkUnfolding top_lvl expr
= CoreUnfolding (occurAnalyseExpr expr)
-- it gets fixed up next round
instance Outputable Unfolding where
- ppr NoUnfolding = ptext SLIT("No unfolding")
- ppr (OtherCon cs) = ptext SLIT("OtherCon") <+> ppr cs
- ppr (CompulsoryUnfolding e) = ptext SLIT("Compulsory") <+> ppr e
+ 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,
+ = ptext (sLit "Unf") <+> sep [ppr top <+> ppr hnf <+> ppr cheap <+> ppr g,
ppr e]
mkCompulsoryUnfolding :: CoreExpr -> Unfolding
\begin{code}
instance Outputable UnfoldingGuidance where
- ppr UnfoldNever = ptext SLIT("NEVER")
+ ppr UnfoldNever = ptext (sLit "NEVER")
ppr (UnfoldIfGoodArgs v cs size discount)
- = hsep [ ptext SLIT("IF_ARGS"), int v,
+ = hsep [ ptext (sLit "IF_ARGS"), int v,
brackets (hsep (map int cs)),
int size,
int discount ]
| 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
-- => 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
instance Outputable CallCtxt where
- ppr BoringCtxt = ptext SLIT("BoringCtxt")
- ppr (ArgCtxt _ _) = ptext SLIT("ArgCtxt")
- ppr CaseCtxt = ptext SLIT("CaseCtxt")
+ 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 {
-> 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 {} -> True
- -- Was: n_vals_wanted > 0; but see test eyeball/inline1.hs
+ 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.
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
+we end up inlining top-level stuff into useless places; eg
+ x = I# 3#
+ f = \y. g x
+This can make a very big difference: it adds 16% to nofib 'integer' allocs,
+and 20% to 'power'.
+
+At one stage I replaced this condition by 'True' (leading to the above
+slow-down). The motivation was test eyeball/inline1.hs; but that seems
+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
mk_arg_discount discount is_evald | is_evald = discount
| otherwise = 0
\end{code}
+
+%************************************************************************
+%* *
+ The Very Simple Optimiser
+%* *
+%************************************************************************
+
+
+\begin{code}
+simpleOptExpr :: Subst -> CoreExpr -> CoreExpr
+-- Return an occur-analysed and slightly optimised expression
+-- The optimisation is very straightforward: just
+-- inline non-recursive bindings that are used only once,
+-- or wheere the RHS is trivial
+
+simpleOptExpr subst expr
+ = go subst (occurAnalyseExpr expr)
+ where
+ go subst (Var v) = lookupIdSubst subst v
+ go subst (App e1 e2) = App (go subst e1) (go subst e2)
+ go subst (Type ty) = Type (substTy subst ty)
+ go _ (Lit lit) = Lit lit
+ go subst (Note note e) = Note note (go subst e)
+ go subst (Cast e co) = Cast (go subst e) (substTy subst co)
+ go subst (Let bind body) = go_bind subst bind body
+ go subst (Lam bndr body) = Lam bndr' (go subst' body)
+ where
+ (subst', bndr') = substBndr subst bndr
+
+ go subst (Case e b ty as) = Case (go subst e) b'
+ (substTy subst ty)
+ (map (go_alt subst') as)
+ where
+ (subst', b') = substBndr subst b
+
+
+ ----------------------
+ go_alt subst (con, bndrs, rhs) = (con, bndrs', go subst' rhs)
+ where
+ (subst', bndrs') = substBndrs subst bndrs
+
+ ----------------------
+ go_bind subst (Rec prs) body = Let (Rec (bndrs' `zip` rhss'))
+ (go subst' body)
+ where
+ (bndrs, rhss) = unzip prs
+ (subst', bndrs') = substRecBndrs subst bndrs
+ rhss' = map (go subst') rhss
+
+ go_bind subst (NonRec b r) body = go_nonrec subst b (go subst r) body
+
+ ----------------------
+ 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 -- let x = e in <body>
+ , exprIsTrivial r' || safe_to_inline (idOccInfo b)
+ = go (extendIdSubst subst b r') body
+ go_nonrec subst b r' body
+ = Let (NonRec b' r') (go subst' body)
+ where
+ (subst', b') = substBndr subst b
+
+ ----------------------
+ -- Unconditionally safe to inline
+ safe_to_inline :: OccInfo -> Bool
+ safe_to_inline IAmDead = True
+ safe_to_inline (OneOcc in_lam one_br _) = not in_lam && one_br
+ safe_to_inline (IAmALoopBreaker {}) = False
+ safe_to_inline NoOccInfo = False
+\end{code}
\ No newline at end of file
projects / ghc-hetmet.git / blobdiff