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 @SimpleUnfolding@ unfolding, you will
13 find, unsurprisingly, a Core expression.
16 #include "HsVersions.h"
19 SimpleUnfolding(..), Unfolding(..), UnfoldingGuidance(..), -- types
20 UfExpr, RdrName, -- For closure (delete in 1.3)
22 FormSummary(..), mkFormSummary, whnfOrBottom, exprSmallEnoughToDup, exprIsTrivial,
24 noUnfolding, mkMagicUnfolding, mkUnfolding, getUnfoldingTemplate,
26 smallEnoughToInline, couldBeSmallEnoughToInline, certainlySmallEnoughToInline,
29 calcUnfoldingGuidance,
31 PragmaInfo(..) -- Re-export
35 #if defined (__GLASGOW_HASKELL__) && __GLASGOW_HASKELL__ <= 201
36 IMPORT_DELOOPER(IdLoop) -- for paranoia checking;
37 -- and also to get mkMagicUnfoldingFun
38 IMPORT_DELOOPER(PrelLoop) -- for paranoia checking
39 IMPORT_DELOOPER(SmplLoop)
41 import {-# SOURCE #-} MagicUFs
42 import {-# SOURCE #-} Id ( Id )
45 import Bag ( emptyBag, unitBag, unionBags, Bag )
47 import CmdLineOpts ( opt_UnfoldingCreationThreshold,
48 opt_UnfoldingUseThreshold,
49 opt_UnfoldingConDiscount
51 import Constants ( uNFOLDING_CHEAP_OP_COST,
52 uNFOLDING_DEAR_OP_COST,
53 uNFOLDING_NOREP_LIT_COST
55 import BinderInfo ( BinderInfo(..), FunOrArg, DuplicationDanger, InsideSCC, isDupDanger )
56 import PragmaInfo ( PragmaInfo(..) )
58 import CoreUtils ( unTagBinders )
59 import HsCore ( UfExpr )
60 import RdrHsSyn ( RdrName )
61 import OccurAnal ( occurAnalyseGlobalExpr )
62 import CoreUtils ( coreExprType )
63 --import CostCentre ( ccMentionsId )
64 import Id ( idType, getIdArity, isBottomingId, isDataCon, isPrimitiveId_maybe,
65 SYN_IE(IdSet), GenId{-instances-} )
66 import PrimOp ( primOpCanTriggerGC, fragilePrimOp, PrimOp(..) )
67 import IdInfo ( ArityInfo(..), bottomIsGuaranteed )
68 import Literal ( isNoRepLit, isLitLitLit )
70 import TyCon ( tyConFamilySize )
71 import Type ( maybeAppDataTyConExpandingDicts )
72 import Unique ( Unique )
73 import UniqSet ( emptyUniqSet, unitUniqSet, mkUniqSet,
74 addOneToUniqSet, unionUniqSets
76 import Usage ( SYN_IE(UVar) )
77 import Maybes ( maybeToBool )
78 import Util ( isIn, panic, assertPanic )
79 #if __GLASGOW_HASKELL__ >= 202
85 %************************************************************************
87 \subsection{@Unfolding@ and @UnfoldingGuidance@ types}
89 %************************************************************************
95 | CoreUnfolding SimpleUnfolding
98 Unique -- Unique of the Id whose magic unfolding this is
103 = SimpleUnfolding -- An unfolding with redundant cached information
104 FormSummary -- Tells whether the template is a WHNF or bottom
105 UnfoldingGuidance -- Tells about the *size* of the template.
106 SimplifiableCoreExpr -- Template
109 noUnfolding = NoUnfolding
111 mkUnfolding inline_prag expr
113 -- strictness mangling (depends on there being no CSE)
114 ufg = calcUnfoldingGuidance inline_prag opt_UnfoldingCreationThreshold expr
115 occ = occurAnalyseGlobalExpr expr
116 cuf = CoreUnfolding (SimpleUnfolding (mkFormSummary expr) ufg occ)
118 cont = case occ of { Var _ -> cuf; _ -> cuf }
120 case ufg of { UnfoldAlways -> cont; _ -> cont }
122 mkMagicUnfolding :: Unique -> Unfolding
123 mkMagicUnfolding tag = MagicUnfolding tag (mkMagicUnfoldingFun tag)
125 getUnfoldingTemplate :: Unfolding -> CoreExpr
126 getUnfoldingTemplate (CoreUnfolding (SimpleUnfolding _ _ expr))
128 getUnfoldingTemplate other = panic "getUnfoldingTemplate"
131 data UnfoldingGuidance
133 | UnfoldAlways -- There is no "original" definition,
134 -- so you'd better unfold. Or: something
135 -- so cheap to unfold (e.g., 1#) that
136 -- you should do it absolutely always.
138 | UnfoldIfGoodArgs Int -- if "m" type args
139 Int -- and "n" value args
141 [Int] -- Discount if the argument is evaluated.
142 -- (i.e., a simplification will definitely
143 -- be possible). One elt of the list per *value* arg.
145 Int -- The "size" of the unfolding; to be elaborated
148 Int -- Scrutinee discount: the discount to substract if the thing is in
149 -- a context (case (thing args) of ...),
150 -- (where there are the right number of arguments.)
154 instance Outputable UnfoldingGuidance where
155 ppr sty UnfoldAlways = ptext SLIT("_ALWAYS_")
156 ppr sty (UnfoldIfGoodArgs t v cs size discount)
157 = hsep [ptext SLIT("_IF_ARGS_"), int t, int v,
158 if null cs -- always print *something*
160 else hcat (map (text . show) cs),
166 %************************************************************************
168 \subsection{Figuring out things about expressions}
170 %************************************************************************
174 = VarForm -- Expression is a variable (or scc var, etc)
175 | ValueForm -- Expression is a value: i.e. a value-lambda,constructor, or literal
176 | BottomForm -- Expression is guaranteed to be bottom. We're more gung
177 -- ho about inlining such things, because it can't waste work
178 | OtherForm -- Anything else
180 instance Outputable FormSummary where
181 ppr sty VarForm = ptext SLIT("Var")
182 ppr sty ValueForm = ptext SLIT("Value")
183 ppr sty BottomForm = ptext SLIT("Bot")
184 ppr sty OtherForm = ptext SLIT("Other")
186 mkFormSummary ::GenCoreExpr bndr Id tyvar uvar -> FormSummary
189 = go (0::Int) expr -- The "n" is the number of (value) arguments so far
191 go n (Lit _) = ASSERT(n==0) ValueForm
192 go n (Con _ _) = ASSERT(n==0) ValueForm
193 go n (Prim _ _) = OtherForm
194 go n (SCC _ e) = go n e
195 go n (Coerce _ _ e) = go n e
197 go n (Let (NonRec b r) e) | exprIsTrivial r = go n e -- let f = f' alpha in (f,g)
198 -- should be treated as a value
199 go n (Let _ e) = OtherForm
200 go n (Case _ _) = OtherForm
202 go 0 (Lam (ValBinder x) e) = ValueForm -- NB: \x.bottom /= bottom!
203 go n (Lam (ValBinder x) e) = go (n-1) e -- Applied lambda
204 go n (Lam other_binder e) = go n e
206 go n (App fun arg) | isValArg arg = go (n+1) fun
207 go n (App fun other_arg) = go n fun
209 go n (Var f) | isBottomingId f = BottomForm
210 | isDataCon f = ValueForm -- Can happen inside imported unfoldings
211 go 0 (Var f) = VarForm
212 go n (Var f) = case getIdArity f of
213 ArityExactly a | n < a -> ValueForm
214 ArityAtLeast a | n < a -> ValueForm
217 whnfOrBottom :: GenCoreExpr bndr Id tyvar uvar -> Bool
218 whnfOrBottom e = case mkFormSummary e of
225 @exprIsTrivial@ is true of expressions we are unconditionally happy to duplicate;
226 simple variables and constants, and type applications.
229 exprIsTrivial (Var v) = True
230 exprIsTrivial (Lit lit) = not (isNoRepLit lit)
231 exprIsTrivial (App e (TyArg _)) = exprIsTrivial e
232 exprIsTrivial (Coerce _ _ e) = exprIsTrivial e
233 exprIsTrivial other = False
237 exprSmallEnoughToDup (Con _ _) = True -- Could check # of args
238 exprSmallEnoughToDup (Prim op _) = not (fragilePrimOp op) -- Could check # of args
239 exprSmallEnoughToDup (Lit lit) = not (isNoRepLit lit)
240 exprSmallEnoughToDup (Coerce _ _ e) = exprSmallEnoughToDup e
241 exprSmallEnoughToDup expr
242 = case (collectArgs expr) of { (fun, _, _, vargs) ->
244 Var v | length vargs <= 4 -> True
251 %************************************************************************
253 \subsection[calcUnfoldingGuidance]{Calculate ``unfolding guidance'' for an expression}
255 %************************************************************************
258 calcUnfoldingGuidance
259 :: PragmaInfo -- INLINE pragma stuff
260 -> Int -- bomb out if size gets bigger than this
261 -> CoreExpr -- expression to look at
264 calcUnfoldingGuidance IMustBeINLINEd bOMB_OUT_SIZE expr = UnfoldAlways -- Always inline if the INLINE pragma says so
265 calcUnfoldingGuidance IWantToBeINLINEd bOMB_OUT_SIZE expr = UnfoldAlways -- Always inline if the INLINE pragma says so
266 calcUnfoldingGuidance IMustNotBeINLINEd bOMB_OUT_SIZE expr = UnfoldNever -- ...and vice versa...
268 calcUnfoldingGuidance NoPragmaInfo bOMB_OUT_SIZE expr
269 = case collectBinders expr of { (use_binders, ty_binders, val_binders, body) ->
270 case (sizeExpr bOMB_OUT_SIZE val_binders body) of
272 TooBig -> UnfoldNever
274 SizeIs size cased_args scrut_discount
278 (map discount_for val_binders)
283 | is_data && b `is_elem` cased_args = tyConFamilySize tycon
287 = case (maybeAppDataTyConExpandingDicts (idType b)) of
288 Nothing -> (False, panic "discount")
289 Just (tc,_,_) -> (True, tc)
291 is_elem = isIn "calcUnfoldingGuidance" }
295 sizeExpr :: Int -- Bomb out if it gets bigger than this
296 -> [Id] -- Arguments; we're interested in which of these
301 sizeExpr (I# bOMB_OUT_SIZE) args expr
304 size_up (Var v) = sizeZero
305 size_up (Lit lit) | isNoRepLit lit = sizeN uNFOLDING_NOREP_LIT_COST
306 | otherwise = sizeZero
308 size_up (SCC lbl body) = size_up body -- SCCs cost nothing
309 size_up (Coerce _ _ body) = size_up body -- Coercions cost nothing
311 size_up (App fun arg) = size_up fun `addSize` size_up_arg arg
312 -- NB Zero cost for for type applications;
313 -- others cost 1 or more
315 size_up (Con con args) = conSizeN (numValArgs args)
316 -- We don't count 1 for the constructor because we're
317 -- quite keen to get constructors into the open
319 size_up (Prim op args) = sizeN op_cost -- NB: no charge for PrimOp args
321 op_cost = if primOpCanTriggerGC op
322 then uNFOLDING_DEAR_OP_COST
323 -- these *tend* to be more expensive;
324 -- number chosen to avoid unfolding (HACK)
325 else uNFOLDING_CHEAP_OP_COST
327 size_up expr@(Lam _ _)
329 (uvars, tyvars, args, body) = collectBinders expr
331 size_up body `addSizeN` length args
333 size_up (Let (NonRec binder rhs) body)
334 = nukeScrutDiscount (size_up rhs)
338 size_up (Let (Rec pairs) body)
339 = nukeScrutDiscount (foldr addSize sizeZero [size_up rhs | (_,rhs) <- pairs])
343 size_up (Case scrut alts)
344 = nukeScrutDiscount (size_up scrut)
348 size_up_alts (coreExprType scrut) alts
349 -- We charge for the "case" itself in "size_up_alts"
352 -- In an application we charge 0 for type application
353 -- 1 for most anything else
355 size_up_arg (LitArg lit) | isNoRepLit lit = sizeN uNFOLDING_NOREP_LIT_COST
356 size_up_arg (TyArg _) = sizeZero
357 size_up_arg other = sizeOne
360 size_up_alts scrut_ty (AlgAlts alts deflt)
361 = (foldr (addSize . size_alg_alt) (size_up_deflt deflt) alts)
365 size_alg_alt (con,args,rhs) = size_up rhs
366 -- Don't charge for args, so that wrappers look cheap
368 -- NB: we charge N for an alg. "case", where N is
369 -- the number of constructors in the thing being eval'd.
370 -- (You'll eventually get a "discount" of N if you
371 -- think the "case" is likely to go away.)
372 -- It's important to charge for alternatives. If you don't then you
373 -- get size 1 for things like:
374 -- case x of { A -> 1#; B -> 2#; ... lots }
378 = case (maybeAppDataTyConExpandingDicts scrut_ty) of
380 Just (tc,_,_) -> tyConFamilySize tc
382 size_up_alts _ (PrimAlts alts deflt)
383 = foldr (addSize . size_prim_alt) (size_up_deflt deflt) alts
384 -- *no charge* for a primitive "case"!
386 size_prim_alt (lit,rhs) = size_up rhs
389 size_up_deflt NoDefault = sizeZero
390 size_up_deflt (BindDefault binder rhs) = size_up rhs
393 -- We want to record if we're case'ing an argument
394 arg_discount (Var v) | v `is_elem` args = scrutArg v
395 arg_discount other = sizeZero
397 is_elem :: Id -> [Id] -> Bool
398 is_elem = isIn "size_up_scrut"
401 -- These addSize things have to be here because
402 -- I don't want to give them bOMB_OUT_SIZE as an argument
404 addSizeN TooBig _ = TooBig
405 addSizeN (SizeIs n xs d) (I# m)
406 | n_tot -# d <# bOMB_OUT_SIZE = SizeIs n_tot xs d
411 addSize TooBig _ = TooBig
412 addSize _ TooBig = TooBig
413 addSize (SizeIs n1 xs d1) (SizeIs n2 ys d2)
414 | (n_tot -# d_tot) <# bOMB_OUT_SIZE = SizeIs n_tot xys d_tot
424 Code for manipulating sizes
428 data ExprSize = TooBig
429 | SizeIs Int# -- Size found
430 [Id] -- Arguments cased herein
431 Int# -- Size to subtract if result is scrutinised
432 -- by a case expression
434 sizeZero = SizeIs 0# [] 0#
435 sizeOne = SizeIs 1# [] 0#
436 sizeN (I# n) = SizeIs n [] 0#
437 conSizeN (I# n) = SizeIs n [] n
438 scrutArg v = SizeIs 0# [v] 0#
440 nukeScrutDiscount (SizeIs n vs d) = SizeIs n vs 0#
441 nukeScrutDiscount TooBig = TooBig
444 %************************************************************************
446 \subsection[considerUnfolding]{Given all the info, do (not) do the unfolding}
448 %************************************************************************
450 We have very limited information about an unfolding expression: (1)~so
451 many type arguments and so many value arguments expected---for our
452 purposes here, we assume we've got those. (2)~A ``size'' or ``cost,''
453 a single integer. (3)~An ``argument info'' vector. For this, what we
454 have at the moment is a Boolean per argument position that says, ``I
455 will look with great favour on an explicit constructor in this
456 position.'' (4)~The ``discount'' to subtract if the expression
457 is being scrutinised.
459 Assuming we have enough type- and value arguments (if not, we give up
460 immediately), then we see if the ``discounted size'' is below some
461 (semi-arbitrary) threshold. It works like this: for every argument
462 position where we're looking for a constructor AND WE HAVE ONE in our
463 hands, we get a (again, semi-arbitrary) discount [proportion to the
464 number of constructors in the type being scrutinized].
466 If we're in the context of a scrutinee ( \tr{(case <expr > of A .. -> ...;.. )})
467 and the expression in question will evaluate to a constructor, we use
468 the computed discount size *for the result only* rather than
469 computing the argument discounts. Since we know the result of
470 the expression is going to be taken apart, discounting its size
471 is more accurate (see @sizeExpr@ above for how this discount size
475 smallEnoughToInline :: [Bool] -- Evaluated-ness of value arguments
476 -> Bool -- Result is scrutinised
478 -> Bool -- True => unfold it
480 smallEnoughToInline _ _ UnfoldAlways = True
481 smallEnoughToInline _ _ UnfoldNever = False
482 smallEnoughToInline arg_is_evald_s result_is_scruted
483 (UnfoldIfGoodArgs m_tys_wanted n_vals_wanted discount_vec size scrut_discount)
484 = enough_args n_vals_wanted arg_is_evald_s &&
485 discounted_size <= opt_UnfoldingUseThreshold
488 enough_args n [] | n > 0 = False -- A function with no value args => don't unfold
489 enough_args _ _ = True -- Otherwise it's ok to try
491 {- OLD: require saturated args
492 enough_args 0 evals = True
493 enough_args n [] = False
494 enough_args n (e:es) = enough_args (n-1) es
495 -- NB: don't take the length of arg_is_evald_s because when
496 -- called from couldBeSmallEnoughToInline it is infinite!
499 discounted_size = size - args_discount - result_discount
501 args_discount = sum (zipWith arg_discount discount_vec arg_is_evald_s)
502 result_discount | result_is_scruted = scrut_discount
505 arg_discount no_of_constrs is_evald
506 | is_evald = 1 + no_of_constrs * opt_UnfoldingConDiscount
510 We use this one to avoid exporting inlinings that we ``couldn't possibly
511 use'' on the other side. Can be overridden w/ flaggery.
512 Just the same as smallEnoughToInline, except that it has no actual arguments.
516 couldBeSmallEnoughToInline :: UnfoldingGuidance -> Bool
517 couldBeSmallEnoughToInline guidance = smallEnoughToInline (repeat True) True guidance
519 certainlySmallEnoughToInline :: UnfoldingGuidance -> Bool
520 certainlySmallEnoughToInline guidance = smallEnoughToInline (repeat False) False guidance
528 :: FormSummary -- What the thing to be inlined is like
529 -> BinderInfo -- How the thing to be inlined occurs
530 -> Bool -- True => it's small enough to inline
531 -> Bool -- True => yes, inline it
533 -- If there's no danger of duplicating work, we can inline if it occurs once, or is small
534 okToInline form occ_info small_enough
536 = small_enough || one_occ
538 one_occ = case occ_info of
539 OneOcc _ _ _ n_alts _ -> n_alts <= 1
542 no_dup_danger VarForm = True
543 no_dup_danger ValueForm = True
544 no_dup_danger BottomForm = True
545 no_dup_danger other = False
547 -- A non-WHNF can be inlined if it doesn't occur inside a lambda,
548 -- and occurs exactly once or
549 -- occurs once in each branch of a case and is small
550 okToInline OtherForm (OneOcc _ dup_danger _ n_alts _) small_enough
551 = not (isDupDanger dup_danger) && (n_alts <= 1 || small_enough)
553 okToInline form any_occ small_enough = False