2 % (c) The AQUA Project, Glasgow University, 1994-1996
4 \section[CoreUnfold]{Core-syntax unfoldings}
6 Unfoldings (which can travel across module boundaries) are in Core
7 syntax (namely @CoreExpr@s).
9 The type @Unfolding@ sits ``above'' simply-Core-expressions
10 unfoldings, capturing ``higher-level'' things we know about a binding,
11 usually things that the simplifier found out (e.g., ``it's a
12 literal''). In the corner of a @CoreUnfolding@ unfolding, you will
13 find, unsurprisingly, a Core expression.
17 Unfolding(..), UnfoldingGuidance(..), -- types
19 FormSummary(..), mkFormSummary, whnfOrBottom, exprSmallEnoughToDup,
22 noUnfolding, mkMagicUnfolding, mkUnfolding, getUnfoldingTemplate,
24 smallEnoughToInline, couldBeSmallEnoughToInline,
25 certainlySmallEnoughToInline, inlineUnconditionally, okToInline,
31 #include "HsVersions.h"
33 import {-# SOURCE #-} MagicUFs ( MagicUnfoldingFun, mkMagicUnfoldingFun )
35 import CmdLineOpts ( opt_UnfoldingCreationThreshold,
36 opt_UnfoldingUseThreshold,
37 opt_UnfoldingConDiscount,
38 opt_UnfoldingKeenessFactor
40 import Constants ( uNFOLDING_CHEAP_OP_COST,
41 uNFOLDING_DEAR_OP_COST,
42 uNFOLDING_NOREP_LIT_COST
44 import BinderInfo ( BinderInfo, isOneSameSCCFunOcc, isDeadOcc,
45 isInlinableOcc, isOneSafeFunOcc
48 import Literal ( Literal )
49 import CoreUtils ( unTagBinders )
50 import OccurAnal ( occurAnalyseGlobalExpr )
51 import CoreUtils ( coreExprType )
52 import Id ( Id, idType, getIdArity, isBottomingId, isDataCon,
53 idWantsToBeINLINEd, idMustBeINLINEd, idMustNotBeINLINEd,
55 import PrimOp ( fragilePrimOp, primOpCanTriggerGC, PrimOp(..) )
56 import IdInfo ( ArityInfo(..), InlinePragInfo(..) )
57 import Name ( isExported )
58 import Literal ( isNoRepLit, isLitLitLit )
59 import TyCon ( tyConFamilySize )
60 import Type ( splitAlgTyConApp_maybe )
61 import Unique ( Unique )
62 import Util ( isIn, panic, assertPanic )
66 %************************************************************************
68 \subsection{@Unfolding@ and @UnfoldingGuidance@ types}
70 %************************************************************************
76 | OtherLit [Literal] -- It ain't one of these
77 | OtherCon [Id] -- It ain't one of these
79 | CoreUnfolding -- An unfolding with redundant cached information
80 FormSummary -- Tells whether the template is a WHNF or bottom
81 UnfoldingGuidance -- Tells about the *size* of the template.
82 SimplifiableCoreExpr -- Template
85 Unique -- Unique of the Id whose magic unfolding this is
90 noUnfolding = NoUnfolding
94 -- strictness mangling (depends on there being no CSE)
95 ufg = calcUnfoldingGuidance opt_UnfoldingCreationThreshold expr
96 occ = occurAnalyseGlobalExpr expr
97 cuf = CoreUnfolding (mkFormSummary expr) ufg occ
99 cont = case occ of { Var _ -> cuf; _ -> cuf }
101 case ufg of { UnfoldAlways -> cont; _ -> cont }
103 mkMagicUnfolding :: Unique -> Unfolding
104 mkMagicUnfolding tag = MagicUnfolding tag (mkMagicUnfoldingFun tag)
106 getUnfoldingTemplate :: Unfolding -> CoreExpr
107 getUnfoldingTemplate (CoreUnfolding _ _ expr)
109 getUnfoldingTemplate other = panic "getUnfoldingTemplate"
112 data UnfoldingGuidance
114 | UnfoldAlways -- There is no "original" definition,
115 -- so you'd better unfold. Or: something
116 -- so cheap to unfold (e.g., 1#) that
117 -- you should do it absolutely always.
119 | UnfoldIfGoodArgs Int -- if "m" type args
120 Int -- and "n" value args
122 [Int] -- Discount if the argument is evaluated.
123 -- (i.e., a simplification will definitely
124 -- be possible). One elt of the list per *value* arg.
126 Int -- The "size" of the unfolding; to be elaborated
129 Int -- Scrutinee discount: the discount to substract if the thing is in
130 -- a context (case (thing args) of ...),
131 -- (where there are the right number of arguments.)
135 instance Outputable UnfoldingGuidance where
136 ppr UnfoldAlways = ptext SLIT("_ALWAYS_")
137 ppr (UnfoldIfGoodArgs t v cs size discount)
138 = hsep [ptext SLIT("_IF_ARGS_"), int t, int v,
139 if null cs -- always print *something*
141 else hcat (map (text . show) cs),
147 %************************************************************************
149 \subsection{Figuring out things about expressions}
151 %************************************************************************
155 = VarForm -- Expression is a variable (or scc var, etc)
156 | ValueForm -- Expression is a value: i.e. a value-lambda,constructor, or literal
157 | BottomForm -- Expression is guaranteed to be bottom. We're more gung
158 -- ho about inlining such things, because it can't waste work
159 | OtherForm -- Anything else
161 instance Outputable FormSummary where
162 ppr VarForm = ptext SLIT("Var")
163 ppr ValueForm = ptext SLIT("Value")
164 ppr BottomForm = ptext SLIT("Bot")
165 ppr OtherForm = ptext SLIT("Other")
167 mkFormSummary ::GenCoreExpr bndr Id flexi -> FormSummary
170 = go (0::Int) expr -- The "n" is the number of (value) arguments so far
172 go n (Lit _) = ASSERT(n==0) ValueForm
173 go n (Con _ _) = ASSERT(n==0) ValueForm
174 go n (Prim _ _) = OtherForm
175 go n (Note _ e) = go n e
177 go n (Let (NonRec b r) e) | exprIsTrivial r = go n e -- let f = f' alpha in (f,g)
178 -- should be treated as a value
179 go n (Let _ e) = OtherForm
180 go n (Case _ _) = OtherForm
182 go 0 (Lam (ValBinder x) e) = ValueForm -- NB: \x.bottom /= bottom!
183 go n (Lam (ValBinder x) e) = go (n-1) e -- Applied lambda
184 go n (Lam other_binder e) = go n e
186 go n (App fun arg) | isValArg arg = go (n+1) fun
187 go n (App fun other_arg) = go n fun
189 go n (Var f) | isBottomingId f = BottomForm
190 | isDataCon f = ValueForm -- Can happen inside imported unfoldings
191 go 0 (Var f) = VarForm
192 go n (Var f) = case getIdArity f of
193 ArityExactly a | n < a -> ValueForm
194 ArityAtLeast a | n < a -> ValueForm
197 whnfOrBottom :: FormSummary -> Bool
198 whnfOrBottom VarForm = True
199 whnfOrBottom ValueForm = True
200 whnfOrBottom BottomForm = True
201 whnfOrBottom OtherForm = False
204 @exprIsTrivial@ is true of expressions we are unconditionally happy to duplicate;
205 simple variables and constants, and type applications.
208 exprIsTrivial (Var v) = True
209 exprIsTrivial (Lit lit) = not (isNoRepLit lit)
210 exprIsTrivial (App e (TyArg _)) = exprIsTrivial e
211 exprIsTrivial (Note _ e) = exprIsTrivial e
212 exprIsTrivial other = False
216 exprSmallEnoughToDup (Con _ _) = True -- Could check # of args
217 exprSmallEnoughToDup (Prim op _) = not (fragilePrimOp op) -- Could check # of args
218 exprSmallEnoughToDup (Lit lit) = not (isNoRepLit lit)
219 exprSmallEnoughToDup (Note _ e) = exprSmallEnoughToDup e
220 exprSmallEnoughToDup expr
221 = case (collectArgs expr) of { (fun, _, vargs) ->
223 Var v | length vargs <= 4 -> True
230 %************************************************************************
232 \subsection[calcUnfoldingGuidance]{Calculate ``unfolding guidance'' for an expression}
234 %************************************************************************
237 calcUnfoldingGuidance
238 :: Int -- bomb out if size gets bigger than this
239 -> CoreExpr -- expression to look at
241 calcUnfoldingGuidance bOMB_OUT_SIZE expr
242 = case collectBinders expr of { (ty_binders, val_binders, body) ->
243 case (sizeExpr bOMB_OUT_SIZE val_binders body) of
245 TooBig -> UnfoldNever
247 SizeIs size cased_args scrut_discount
251 (map discount_for val_binders)
256 | is_data && b `is_elem` cased_args = tyConFamilySize tycon
260 = case (splitAlgTyConApp_maybe (idType b)) of
261 Nothing -> (False, panic "discount")
262 Just (tc,_,_) -> (True, tc)
264 is_elem = isIn "calcUnfoldingGuidance" }
268 sizeExpr :: Int -- Bomb out if it gets bigger than this
269 -> [Id] -- Arguments; we're interested in which of these
274 sizeExpr (I# bOMB_OUT_SIZE) args expr
277 size_up (Var v) = sizeZero
278 size_up (Lit lit) | isNoRepLit lit = sizeN uNFOLDING_NOREP_LIT_COST
279 | otherwise = sizeZero
281 size_up (Note _ body) = size_up body -- Notes cost nothing
283 size_up (App fun arg) = size_up fun `addSize` size_up_arg arg
284 -- NB Zero cost for for type applications;
285 -- others cost 1 or more
287 size_up (Con con args) = conSizeN (numValArgs args)
288 -- We don't count 1 for the constructor because we're
289 -- quite keen to get constructors into the open
291 size_up (Prim op args) = sizeN op_cost -- NB: no charge for PrimOp args
293 op_cost = if primOpCanTriggerGC op
294 then uNFOLDING_DEAR_OP_COST
295 -- these *tend* to be more expensive;
296 -- number chosen to avoid unfolding (HACK)
297 else uNFOLDING_CHEAP_OP_COST
299 size_up expr@(Lam _ _)
301 (tyvars, args, body) = collectBinders expr
303 size_up body `addSizeN` length args
305 size_up (Let (NonRec binder rhs) body)
306 = nukeScrutDiscount (size_up rhs)
310 1 -- For the allocation
312 size_up (Let (Rec pairs) body)
313 = nukeScrutDiscount (foldr addSize sizeZero [size_up rhs | (_,rhs) <- pairs])
317 length pairs -- For the allocation
319 size_up (Case scrut alts)
320 = nukeScrutDiscount (size_up scrut)
324 size_up_alts (coreExprType scrut) alts
325 -- We charge for the "case" itself in "size_up_alts"
328 -- In an application we charge 0 for type application
329 -- 1 for most anything else
331 size_up_arg (LitArg lit) | isNoRepLit lit = sizeN uNFOLDING_NOREP_LIT_COST
332 size_up_arg (TyArg _) = sizeZero
333 size_up_arg other = sizeOne
336 size_up_alts scrut_ty (AlgAlts alts deflt)
337 = (foldr (addSize . size_alg_alt) (size_up_deflt deflt) alts)
341 size_alg_alt (con,args,rhs) = size_up rhs
342 -- Don't charge for args, so that wrappers look cheap
344 -- NB: we charge N for an alg. "case", where N is
345 -- the number of constructors in the thing being eval'd.
346 -- (You'll eventually get a "discount" of N if you
347 -- think the "case" is likely to go away.)
348 -- It's important to charge for alternatives. If you don't then you
349 -- get size 1 for things like:
350 -- case x of { A -> 1#; B -> 2#; ... lots }
354 = case (splitAlgTyConApp_maybe scrut_ty) of
356 Just (tc,_,_) -> tyConFamilySize tc
358 size_up_alts _ (PrimAlts alts deflt)
359 = foldr (addSize . size_prim_alt) (size_up_deflt deflt) alts
360 -- *no charge* for a primitive "case"!
362 size_prim_alt (lit,rhs) = size_up rhs
365 size_up_deflt NoDefault = sizeZero
366 size_up_deflt (BindDefault binder rhs) = size_up rhs
369 -- We want to record if we're case'ing an argument
370 arg_discount (Var v) | v `is_elem` args = scrutArg v
371 arg_discount other = sizeZero
373 is_elem :: Id -> [Id] -> Bool
374 is_elem = isIn "size_up_scrut"
377 -- These addSize things have to be here because
378 -- I don't want to give them bOMB_OUT_SIZE as an argument
380 addSizeN TooBig _ = TooBig
381 addSizeN (SizeIs n xs d) (I# m)
382 | n_tot -# d <# bOMB_OUT_SIZE = SizeIs n_tot xs d
387 addSize TooBig _ = TooBig
388 addSize _ TooBig = TooBig
389 addSize (SizeIs n1 xs d1) (SizeIs n2 ys d2)
390 | (n_tot -# d_tot) <# bOMB_OUT_SIZE = SizeIs n_tot xys d_tot
400 Code for manipulating sizes
404 data ExprSize = TooBig
405 | SizeIs Int# -- Size found
406 [Id] -- Arguments cased herein
407 Int# -- Size to subtract if result is scrutinised
408 -- by a case expression
410 sizeZero = SizeIs 0# [] 0#
411 sizeOne = SizeIs 1# [] 0#
412 sizeN (I# n) = SizeIs n [] 0#
413 conSizeN (I# n) = SizeIs n [] n
414 scrutArg v = SizeIs 0# [v] 0#
416 nukeScrutDiscount (SizeIs n vs d) = SizeIs n vs 0#
417 nukeScrutDiscount TooBig = TooBig
420 %************************************************************************
422 \subsection[considerUnfolding]{Given all the info, do (not) do the unfolding}
424 %************************************************************************
426 We have very limited information about an unfolding expression: (1)~so
427 many type arguments and so many value arguments expected---for our
428 purposes here, we assume we've got those. (2)~A ``size'' or ``cost,''
429 a single integer. (3)~An ``argument info'' vector. For this, what we
430 have at the moment is a Boolean per argument position that says, ``I
431 will look with great favour on an explicit constructor in this
432 position.'' (4)~The ``discount'' to subtract if the expression
433 is being scrutinised.
435 Assuming we have enough type- and value arguments (if not, we give up
436 immediately), then we see if the ``discounted size'' is below some
437 (semi-arbitrary) threshold. It works like this: for every argument
438 position where we're looking for a constructor AND WE HAVE ONE in our
439 hands, we get a (again, semi-arbitrary) discount [proportion to the
440 number of constructors in the type being scrutinized].
442 If we're in the context of a scrutinee ( \tr{(case <expr > of A .. -> ...;.. )})
443 and the expression in question will evaluate to a constructor, we use
444 the computed discount size *for the result only* rather than
445 computing the argument discounts. Since we know the result of
446 the expression is going to be taken apart, discounting its size
447 is more accurate (see @sizeExpr@ above for how this discount size
451 smallEnoughToInline :: Id -- The function (trace msg only)
452 -> [Bool] -- Evaluated-ness of value arguments
453 -> Bool -- Result is scrutinised
455 -> Bool -- True => unfold it
457 smallEnoughToInline _ _ _ UnfoldAlways = True
458 smallEnoughToInline _ _ _ UnfoldNever = False
459 smallEnoughToInline id arg_is_evald_s result_is_scruted
460 (UnfoldIfGoodArgs m_tys_wanted n_vals_wanted discount_vec size scrut_discount)
461 = if enough_args n_vals_wanted arg_is_evald_s &&
462 size - discount <= opt_UnfoldingUseThreshold
464 -- pprTrace "small enough" (ppr id <+> int size <+> int discount)
470 enough_args n [] | n > 0 = False -- A function with no value args => don't unfold
471 enough_args _ _ = True -- Otherwise it's ok to try
473 -- We multiple the raw discounts (args_discount and result_discount)
474 -- ty opt_UnfoldingKeenessFactor because the former have to do with
475 -- *size* whereas the discounts imply that there's some extra *efficiency*
476 -- to be gained (e.g. beta reductions, case reductions) by inlining.
479 opt_UnfoldingKeenessFactor *
480 fromInt (args_discount + result_discount)
483 args_discount = sum (zipWith arg_discount discount_vec arg_is_evald_s)
484 result_discount | result_is_scruted = scrut_discount
487 arg_discount no_of_constrs is_evald
488 | is_evald = no_of_constrs * opt_UnfoldingConDiscount
492 We use this one to avoid exporting inlinings that we ``couldn't possibly
493 use'' on the other side. Can be overridden w/ flaggery.
494 Just the same as smallEnoughToInline, except that it has no actual arguments.
497 couldBeSmallEnoughToInline :: Id -> UnfoldingGuidance -> Bool
498 couldBeSmallEnoughToInline id guidance = smallEnoughToInline id (repeat True) True guidance
500 certainlySmallEnoughToInline :: Id -> UnfoldingGuidance -> Bool
501 certainlySmallEnoughToInline id guidance = smallEnoughToInline id (repeat False) False guidance
507 @inlineUnconditionally@ decides whether a let-bound thing can
508 *definitely* be inlined at each of its call sites. If so, then
509 we can drop the binding right away. But remember, you have to be
510 certain that every use can be inlined. So, notably, any ArgOccs
511 rule this out. Since ManyOcc doesn't record FunOcc/ArgOcc
514 inlineUnconditionally :: (Id,BinderInfo) -> Bool
516 inlineUnconditionally (id, occ_info)
517 | idMustNotBeINLINEd id
521 | isOneSameSCCFunOcc occ_info
522 && idWantsToBeINLINEd id = True
524 | isOneSafeFunOcc occ_info
531 okToInline is used at call sites, so it is a bit more generous
534 okToInline :: Id -- The Id
535 -> Bool -- The thing is WHNF or bottom;
536 -> Bool -- It's small enough to duplicate the code
538 -> Bool -- True <=> inline it
540 okToInline id _ _ _ -- Check the Id first
541 | idWantsToBeINLINEd id = True
542 | idMustNotBeINLINEd id = False
544 okToInline id whnf small binder_info
546 | isDeadOcc binder_info
547 = pprTrace "okToInline: dead" (ppr id) False
550 = isInlinableOcc whnf small binder_info
553 @okToUnfoldInHifile@ is used when emitting unfolding info into an interface
554 file to determine whether an unfolding candidate really should be unfolded.
555 The predicate is needed to prevent @_casm_@s (+ lit-lits) from being emitted
556 into interface files.
558 The reason for inlining expressions containing _casm_s into interface files
559 is that these fragments of C are likely to mention functions/#defines that
560 will be out-of-scope when inlined into another module. This is not an
561 unfixable problem for the user (just need to -#include the approp. header
562 file), but turning it off seems to the simplest thing to do.
565 okToUnfoldInHiFile :: CoreExpr -> Bool
566 okToUnfoldInHiFile e = go e
568 -- Race over an expression looking for CCalls..
570 go (Lit lit) = not (isLitLitLit lit)
571 go (Note _ body) = go body
572 go (App fun arg) = go fun
573 go (Con con args) = True
574 go (Prim op args) = okToUnfoldPrimOp op
575 go (Lam _ body) = go body
576 go (Let (NonRec binder rhs) body) = go rhs && go body
577 go (Let (Rec pairs) body) = and (map go (body:rhses))
579 rhses = [ rhs | (_, rhs) <- pairs ]
580 go (Case scrut alts) = and (map go (scrut:rhses))
582 rhses = getAltRhs alts
584 getAltRhs (PrimAlts alts deflt) =
585 let ls = map snd alts in
588 BindDefault _ rhs -> rhs:ls
589 getAltRhs (AlgAlts alts deflt) =
590 let ls = map (\ (_,_,r) -> r) alts in
593 BindDefault _ rhs -> rhs:ls
595 -- ok to unfold a PrimOp as long as it's not a _casm_
596 okToUnfoldPrimOp (CCallOp _ is_casm _ _ _) = not is_casm
597 okToUnfoldPrimOp _ = True