ghc/compiler/coreSyn/CoreUnfold.lhs

   1 %
   2 % (c) The AQUA Project, Glasgow University, 1994-1998
   3 %
   4 \section[CoreUnfold]{Core-syntax unfoldings}
   5
   6 Unfoldings (which can travel across module boundaries) are in Core
   7 syntax (namely @CoreExpr@s).
   8
   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.
  14
  15 \begin{code}
  16 module CoreUnfold (
  17         Unfolding, UnfoldingGuidance, -- types
  18
  19         noUnfolding, mkUnfolding,
  20         mkOtherCon, otherCons,
  21         unfoldingTemplate, maybeUnfoldingTemplate,
  22         isEvaldUnfolding, isCheapUnfolding,
  23         hasUnfolding, hasSomeUnfolding,
  24
  25         couldBeSmallEnoughToInline,
  26         certainlySmallEnoughToInline,
  27         okToUnfoldInHiFile,
  28
  29         calcUnfoldingGuidance,
  30
  31         callSiteInline, blackListed
  32     ) where
  33
  34 #include "HsVersions.h"
  35
  36 import CmdLineOpts      ( opt_UF_CreationThreshold,
  37                           opt_UF_UseThreshold,
  38                           opt_UF_ScrutConDiscount,
  39                           opt_UF_FunAppDiscount,
  40                           opt_UF_PrimArgDiscount,
  41                           opt_UF_KeenessFactor,
  42                           opt_UF_CheapOp, opt_UF_DearOp, opt_UF_NoRepLit,
  43                           opt_UnfoldCasms, opt_PprStyle_Debug,
  44                           opt_D_dump_inlinings
  45                         )
  46 import CoreSyn
  47 import PprCore          ( pprCoreExpr )
  48 import OccurAnal        ( occurAnalyseGlobalExpr )
  49 import BinderInfo       ( )
  50 import CoreUtils        ( coreExprType, exprIsTrivial, exprIsValue, exprIsCheap )
  51 import Id               ( Id, idType, idUnique, isId,
  52                           getIdSpecialisation, getInlinePragma, getIdUnfolding
  53                         )
  54 import VarSet
  55 import Name             ( isLocallyDefined )
  56 import Const            ( Con(..), isLitLitLit, isWHNFCon )
  57 import PrimOp           ( PrimOp(..), primOpIsDupable )
  58 import IdInfo           ( ArityInfo(..), InlinePragInfo(..), OccInfo(..) )
  59 import TyCon            ( tyConFamilySize )
  60 import Type             ( splitAlgTyConApp_maybe, splitFunTy_maybe, isUnLiftedType )
  61 import Const            ( isNoRepLit )
  62 import Unique           ( Unique, buildIdKey, augmentIdKey, runSTRepIdKey )
  63 import Maybes           ( maybeToBool )
  64 import Bag
  65 import Util             ( isIn, lengthExceeds )
  66 import Outputable
  67 \end{code}
  68
  69 %************************************************************************
  70 %*                                                                      *
  71 \subsection{@Unfolding@ and @UnfoldingGuidance@ types}
  72 %*                                                                      *
  73 %************************************************************************
  74
  75 \begin{code}
  76 data Unfolding
  77   = NoUnfolding
  78
  79   | OtherCon [Con]              -- It ain't one of these
  80                                 -- (OtherCon xs) also indicates that something has been evaluated
  81                                 -- and hence there's no point in re-evaluating it.
  82                                 -- OtherCon [] is used even for non-data-type values
  83                                 -- to indicated evaluated-ness.  Notably:
  84                                 --      data C = C !(Int -> Int)
  85                                 --      case x of { C f -> ... }
  86                                 -- Here, f gets an OtherCon [] unfolding.
  87
  88   | CoreUnfolding                       -- An unfolding with redundant cached information
  89                 CoreExpr                -- Template; binder-info is correct
  90                 Bool                    -- exprIsCheap template (cached); it won't duplicate (much) work
  91                                         --      if you inline this in more than one place
  92                 Bool                    -- exprIsValue template (cached); it is ok to discard a `seq` on
  93                                         --      this variable
  94                 UnfoldingGuidance       -- Tells about the *size* of the template.
  95 \end{code}
  96
  97 \begin{code}
  98 noUnfolding = NoUnfolding
  99 mkOtherCon  = OtherCon
 100
 101 mkUnfolding expr
 102   = CoreUnfolding (occurAnalyseGlobalExpr expr)
 103                   (exprIsCheap expr)
 104                   (exprIsValue expr)
 105                   (calcUnfoldingGuidance opt_UF_CreationThreshold expr)
 106
 107 unfoldingTemplate :: Unfolding -> CoreExpr
 108 unfoldingTemplate (CoreUnfolding expr _ _ _) = expr
 109 unfoldingTemplate other = panic "getUnfoldingTemplate"
 110
 111 maybeUnfoldingTemplate :: Unfolding -> Maybe CoreExpr
 112 maybeUnfoldingTemplate (CoreUnfolding expr _ _ _) = Just expr
 113 maybeUnfoldingTemplate other                      = Nothing
 114
 115 otherCons (OtherCon cons) = cons
 116 otherCons other           = []
 117
 118 isEvaldUnfolding :: Unfolding -> Bool
 119 isEvaldUnfolding (OtherCon _)                   = True
 120 isEvaldUnfolding (CoreUnfolding _ _ is_evald _) = is_evald
 121 isEvaldUnfolding other                          = False
 122
 123 isCheapUnfolding :: Unfolding -> Bool
 124 isCheapUnfolding (CoreUnfolding _ is_cheap _ _) = is_cheap
 125 isCheapUnfolding other                          = False
 126
 127 hasUnfolding :: Unfolding -> Bool
 128 hasUnfolding (CoreUnfolding _ _ _ _) = True
 129 hasUnfolding other                   = False
 130
 131 hasSomeUnfolding :: Unfolding -> Bool
 132 hasSomeUnfolding NoUnfolding = False
 133 hasSomeUnfolding other       = True
 134
 135 data UnfoldingGuidance
 136   = UnfoldNever
 137   | UnfoldAlways                -- There is no "original" definition,
 138                                 -- so you'd better unfold.  Or: something
 139                                 -- so cheap to unfold (e.g., 1#) that
 140                                 -- you should do it absolutely always.
 141
 142   | UnfoldIfGoodArgs    Int     -- and "n" value args
 143
 144                         [Int]   -- Discount if the argument is evaluated.
 145                                 -- (i.e., a simplification will definitely
 146                                 -- be possible).  One elt of the list per *value* arg.
 147
 148                         Int     -- The "size" of the unfolding; to be elaborated
 149                                 -- later. ToDo
 150
 151                         Int     -- Scrutinee discount: the discount to substract if the thing is in
 152                                 -- a context (case (thing args) of ...),
 153                                 -- (where there are the right number of arguments.)
 154 \end{code}
 155
 156 \begin{code}
 157 instance Outputable UnfoldingGuidance where
 158     ppr UnfoldAlways    = ptext SLIT("ALWAYS")
 159     ppr UnfoldNever     = ptext SLIT("NEVER")
 160     ppr (UnfoldIfGoodArgs v cs size discount)
 161       = hsep [ptext SLIT("IF_ARGS"), int v,
 162                if null cs       -- always print *something*
 163                 then char 'X'
 164                 else hcat (map (text . show) cs),
 165                int size,
 166                int discount ]
 167 \end{code}
 168
 169
 170 %************************************************************************
 171 %*                                                                      *
 172 \subsection[calcUnfoldingGuidance]{Calculate ``unfolding guidance'' for an expression}
 173 %*                                                                      *
 174 %************************************************************************
 175
 176 \begin{code}
 177 calcUnfoldingGuidance
 178         :: Int                  -- bomb out if size gets bigger than this
 179         -> CoreExpr             -- expression to look at
 180         -> UnfoldingGuidance
 181 calcUnfoldingGuidance bOMB_OUT_SIZE expr
 182   | exprIsTrivial expr          -- Often trivial expressions are never bound
 183                                 -- to an expression, but it can happen.  For
 184                                 -- example, the Id for a nullary constructor has
 185                                 -- a trivial expression as its unfolding, and
 186                                 -- we want to make sure that we always unfold it.
 187   = UnfoldAlways
 188
 189   | otherwise
 190   = case collectBinders expr of { (binders, body) ->
 191     let
 192         val_binders = filter isId binders
 193     in
 194     case (sizeExpr bOMB_OUT_SIZE val_binders body) of
 195
 196       TooBig -> UnfoldNever
 197
 198       SizeIs size cased_args scrut_discount
 199         -> UnfoldIfGoodArgs
 200                         (length val_binders)
 201                         (map discount_for val_binders)
 202                         (I# size)
 203                         (I# scrut_discount)
 204         where
 205             discount_for b
 206                 | num_cases == 0 = 0
 207                 | is_fun_ty      = num_cases * opt_UF_FunAppDiscount
 208                 | is_data_ty     = num_cases * opt_UF_ScrutConDiscount
 209                 | otherwise      = num_cases * opt_UF_PrimArgDiscount
 210                 where
 211                   num_cases           = foldlBag (\n b' -> if b==b' then n+1 else n) 0 cased_args
 212                                         -- Count occurrences of b in cased_args
 213                   arg_ty              = idType b
 214                   is_fun_ty           = maybeToBool (splitFunTy_maybe arg_ty)
 215                   (is_data_ty, tycon) = case (splitAlgTyConApp_maybe (idType b)) of
 216                                           Nothing       -> (False, panic "discount")
 217                                           Just (tc,_,_) -> (True,  tc)
 218         }
 219 \end{code}
 220
 221 \begin{code}
 222 sizeExpr :: Int             -- Bomb out if it gets bigger than this
 223          -> [Id]            -- Arguments; we're interested in which of these
 224                             -- get case'd
 225          -> CoreExpr
 226          -> ExprSize
 227
 228 sizeExpr (I# bOMB_OUT_SIZE) args expr
 229   = size_up expr
 230   where
 231     size_up (Type t)          = sizeZero        -- Types cost nothing
 232     size_up (Var v)           = sizeOne
 233
 234     size_up (Note InlineMe _) = sizeTwo         -- The idea is that this is one more
 235                                                 -- than the size of the "call" (i.e. 1)
 236                                                 -- We want to reply "no" to noSizeIncrease
 237                                                 -- for a bare reference (i.e. applied to no args)
 238                                                 -- to an INLINE thing
 239
 240     size_up (Note _ body)     = size_up body    -- Notes cost nothing
 241
 242     size_up (App fun (Type t))  = size_up fun
 243     size_up (App fun arg)       = size_up_app fun [arg]
 244
 245     size_up (Con con args) = foldr (addSize . size_up)
 246                                    (size_up_con con args)
 247                                    args
 248
 249     size_up (Lam b e) | isId b    = size_up e `addSizeN` 1
 250                       | otherwise = size_up e
 251
 252     size_up (Let (NonRec binder rhs) body)
 253       = nukeScrutDiscount (size_up rhs)         `addSize`
 254         size_up body                            `addSizeN`
 255         (if isUnLiftedType (idType binder) then 0 else 1)
 256                 -- For the allocation
 257                 -- If the binder has an unlifted type there is no allocation
 258
 259     size_up (Let (Rec pairs) body)
 260       = nukeScrutDiscount rhs_size              `addSize`
 261         size_up body                            `addSizeN`
 262         length pairs            -- For the allocation
 263       where
 264         rhs_size = foldr (addSize . size_up . snd) sizeZero pairs
 265
 266     size_up (Case scrut _ alts)
 267       = nukeScrutDiscount (size_up scrut)               `addSize`
 268         arg_discount scrut                              `addSize`
 269         foldr (addSize . size_up_alt) sizeZero alts
 270           `addSizeN` 1  -- charge one for the case itself.
 271
 272 -- Just charge for the alts that exist, not the ones that might exist
 273 --      `addSizeN`
 274 --      case (splitAlgTyConApp_maybe (coreExprType scrut)) of
 275 --              Nothing       -> 1
 276 --              Just (tc,_,_) -> tyConFamilySize tc
 277
 278     ------------
 279     size_up_app (App fun arg) args   = size_up_app fun (arg:args)
 280     size_up_app fun           args   = foldr (addSize . size_up) (fun_discount fun) args
 281
 282         -- A function application with at least one value argument
 283         -- so if the function is an argument give it an arg-discount
 284         -- Also behave specially if the function is a build
 285     fun_discount (Var fun) | idUnique fun == buildIdKey   = buildSize
 286                            | idUnique fun == augmentIdKey = augmentSize
 287                            | fun `is_elem` args         = scrutArg fun
 288     fun_discount other                                  = sizeZero
 289
 290     ------------
 291     size_up_alt (con, bndrs, rhs) = size_up rhs
 292             -- Don't charge for args, so that wrappers look cheap
 293
 294     ------------
 295     size_up_con (Literal lit) args | isNoRepLit lit = sizeN opt_UF_NoRepLit
 296                                    | otherwise      = sizeOne
 297
 298     size_up_con (DataCon dc) args = conSizeN (valArgCount args)
 299
 300     size_up_con (PrimOp op) args = foldr addSize (sizeN op_cost) (map arg_discount args)
 301                 -- Give an arg-discount if a primop is applies to
 302                 -- one of the function's arguments
 303       where
 304         op_cost | primOpIsDupable op = opt_UF_CheapOp
 305                 | otherwise          = opt_UF_DearOp
 306
 307         -- We want to record if we're case'ing, or applying, an argument
 308     arg_discount (Var v) | v `is_elem` args = scrutArg v
 309     arg_discount other                      = sizeZero
 310
 311     ------------
 312     is_elem :: Id -> [Id] -> Bool
 313     is_elem = isIn "size_up_scrut"
 314
 315     ------------
 316         -- These addSize things have to be here because
 317         -- I don't want to give them bOMB_OUT_SIZE as an argument
 318
 319     addSizeN TooBig          _ = TooBig
 320     addSizeN (SizeIs n xs d) (I# m)
 321       | n_tot -# d <# bOMB_OUT_SIZE = SizeIs n_tot xs d
 322       | otherwise                   = TooBig
 323       where
 324         n_tot = n +# m
 325
 326     addSize TooBig _ = TooBig
 327     addSize _ TooBig = TooBig
 328     addSize (SizeIs n1 xs d1) (SizeIs n2 ys d2)
 329       | (n_tot -# d_tot) <# bOMB_OUT_SIZE = SizeIs n_tot xys d_tot
 330       | otherwise                         = TooBig
 331       where
 332         n_tot = n1 +# n2
 333         d_tot = d1 +# d2
 334         xys   = xs `unionBags` ys
 335 \end{code}
 336
 337 Code for manipulating sizes
 338
 339 \begin{code}
 340
 341 data ExprSize = TooBig
 342               | SizeIs Int#     -- Size found
 343                        (Bag Id) -- Arguments cased herein
 344                        Int#     -- Size to subtract if result is scrutinised
 345                                 -- by a case expression
 346
 347 sizeZero        = SizeIs 0# emptyBag 0#
 348 sizeOne         = SizeIs 1# emptyBag 0#
 349 sizeTwo         = SizeIs 2# emptyBag 0#
 350 sizeN (I# n)    = SizeIs n  emptyBag 0#
 351 conSizeN (I# n) = SizeIs 1# emptyBag (n +# 1#)
 352         -- Treat constructors as size 1, that unfoldAlways responsds 'False'
 353         -- when asked about 'x' when x is bound to (C 3#).
 354         -- This avoids gratuitous 'ticks' when x itself appears as an
 355         -- atomic constructor argument.
 356
 357 buildSize = SizeIs (-2#) emptyBag 4#
 358         -- We really want to inline applications of build
 359         -- build t (\cn -> e) should cost only the cost of e (because build will be inlined later)
 360         -- Indeed, we should add a result_discount becuause build is
 361         -- very like a constructor.  We don't bother to check that the
 362         -- build is saturated (it usually is).  The "-2" discounts for the \c n,
 363         -- The "4" is rather arbitrary.
 364
 365 augmentSize = SizeIs (-2#) emptyBag 4#
 366         -- Ditto (augment t (\cn -> e) ys) should cost only the cost of
 367         -- e plus ys. The -2 accounts for the \cn
 368
 369 scrutArg v      = SizeIs 0# (unitBag v) 0#
 370
 371 nukeScrutDiscount (SizeIs n vs d) = SizeIs n vs 0#
 372 nukeScrutDiscount TooBig          = TooBig
 373 \end{code}
 374
 375
 376 %************************************************************************
 377 %*                                                                      *
 378 \subsection[considerUnfolding]{Given all the info, do (not) do the unfolding}
 379 %*                                                                      *
 380 %************************************************************************
 381
 382 We have very limited information about an unfolding expression: (1)~so
 383 many type arguments and so many value arguments expected---for our
 384 purposes here, we assume we've got those.  (2)~A ``size'' or ``cost,''
 385 a single integer.  (3)~An ``argument info'' vector.  For this, what we
 386 have at the moment is a Boolean per argument position that says, ``I
 387 will look with great favour on an explicit constructor in this
 388 position.'' (4)~The ``discount'' to subtract if the expression
 389 is being scrutinised.
 390
 391 Assuming we have enough type- and value arguments (if not, we give up
 392 immediately), then we see if the ``discounted size'' is below some
 393 (semi-arbitrary) threshold.  It works like this: for every argument
 394 position where we're looking for a constructor AND WE HAVE ONE in our
 395 hands, we get a (again, semi-arbitrary) discount [proportion to the
 396 number of constructors in the type being scrutinized].
 397
 398 If we're in the context of a scrutinee ( \tr{(case <expr > of A .. -> ...;.. )})
 399 and the expression in question will evaluate to a constructor, we use
 400 the computed discount size *for the result only* rather than
 401 computing the argument discounts. Since we know the result of
 402 the expression is going to be taken apart, discounting its size
 403 is more accurate (see @sizeExpr@ above for how this discount size
 404 is computed).
 405
 406 We use this one to avoid exporting inlinings that we ``couldn't possibly
 407 use'' on the other side.  Can be overridden w/ flaggery.
 408 Just the same as smallEnoughToInline, except that it has no actual arguments.
 409
 410 \begin{code}
 411 couldBeSmallEnoughToInline :: UnfoldingGuidance -> Bool
 412 couldBeSmallEnoughToInline UnfoldNever = False
 413 couldBeSmallEnoughToInline other       = True
 414
 415 certainlySmallEnoughToInline :: UnfoldingGuidance -> Bool
 416 certainlySmallEnoughToInline UnfoldNever                   = False
 417 certainlySmallEnoughToInline UnfoldAlways                  = True
 418 certainlySmallEnoughToInline (UnfoldIfGoodArgs _ _ size _) = size <= opt_UF_UseThreshold
 419 \end{code}
 420
 421 @okToUnfoldInHifile@ is used when emitting unfolding info into an interface
 422 file to determine whether an unfolding candidate really should be unfolded.
 423 The predicate is needed to prevent @_casm_@s (+ lit-lits) from being emitted
 424 into interface files.
 425
 426 The reason for inlining expressions containing _casm_s into interface files
 427 is that these fragments of C are likely to mention functions/#defines that
 428 will be out-of-scope when inlined into another module. This is not an
 429 unfixable problem for the user (just need to -#include the approp. header
 430 file), but turning it off seems to the simplest thing to do.
 431
 432 \begin{code}
 433 okToUnfoldInHiFile :: CoreExpr -> Bool
 434 okToUnfoldInHiFile e = opt_UnfoldCasms || go e
 435  where
 436     -- Race over an expression looking for CCalls..
 437     go (Var _)                = True
 438     go (Con (Literal lit) _)  = not (isLitLitLit lit)
 439     go (Con (PrimOp op) args) = okToUnfoldPrimOp op && all go args
 440     go (Con con args)         = True -- con args are always atomic
 441     go (App fun arg)          = go fun && go arg
 442     go (Lam _ body)           = go body
 443     go (Let binds body)       = and (map go (body :rhssOfBind binds))
 444     go (Case scrut bndr alts) = and (map go (scrut:rhssOfAlts alts))
 445     go (Note _ body)          = go body
 446     go (Type _)               = True
 447
 448     -- ok to unfold a PrimOp as long as it's not a _casm_
 449     okToUnfoldPrimOp (CCallOp _ is_casm _ _) = not is_casm
 450     okToUnfoldPrimOp _                       = True
 451 \end{code}
 452
 453
 454 %************************************************************************
 455 %*                                                                      *
 456 \subsection{callSiteInline}
 457 %*                                                                      *
 458 %************************************************************************
 459
 460 This is the key function.  It decides whether to inline a variable at a call site
 461
 462 callSiteInline is used at call sites, so it is a bit more generous.
 463 It's a very important function that embodies lots of heuristics.
 464 A non-WHNF can be inlined if it doesn't occur inside a lambda,
 465 and occurs exactly once or
 466     occurs once in each branch of a case and is small
 467
 468 If the thing is in WHNF, there's no danger of duplicating work,
 469 so we can inline if it occurs once, or is small
 470
 471 \begin{code}
 472 callSiteInline :: Bool                  -- True <=> the Id is black listed
 473                -> Bool                  -- 'inline' note at call site
 474                -> Id                    -- The Id
 475                -> [Bool]                -- One for each value arg; True if it is interesting
 476                -> Bool                  -- True <=> continuation is interesting
 477                -> Maybe CoreExpr        -- Unfolding, if any
 478
 479
 480 callSiteInline black_listed inline_call id arg_infos interesting_cont
 481   = case getIdUnfolding id of {
 482         NoUnfolding -> Nothing ;
 483         OtherCon _  -> Nothing ;
 484         CoreUnfolding unf_template is_cheap _ guidance ->
 485
 486     let
 487         result | yes_or_no = Just unf_template
 488                | otherwise = Nothing
 489
 490         inline_prag = getInlinePragma id
 491         n_val_args  = length arg_infos
 492
 493         yes_or_no =
 494             case inline_prag of
 495                 IAmDead           -> pprTrace "callSiteInline: dead" (ppr id) False
 496                 IMustNotBeINLINEd -> False
 497                 IAmALoopBreaker   -> False
 498                 IMustBeINLINEd    -> True       -- Overrides absolutely everything, including the black list
 499                 ICanSafelyBeINLINEd in_lam one_br -> consider in_lam    True  one_br
 500                 NoInlinePragInfo                  -> consider InsideLam False False
 501
 502         consider in_lam once once_in_one_branch
 503           | black_listed = False
 504           | inline_call  = True
 505           | once_in_one_branch  -- Be very keen to inline something if this is its unique occurrence; that
 506                                 -- gives a good chance of eliminating the original binding for the thing.
 507                                 -- The only time we hold back is when substituting inside a lambda;
 508                                 -- then if the context is totally uninteresting (not applied, not scrutinised)
 509                                 -- there is no point in substituting because it might just increase allocation.
 510           = WARN( case in_lam of { NotInsideLam -> True; other -> False },
 511                   text "callSiteInline:oneOcc" <+> ppr id )
 512                 -- If it has one occurrence, not inside a lambda, PreInlineUnconditionally
 513                 -- should have zapped it already
 514             is_cheap && (not (null arg_infos) || interesting_cont)
 515
 516           | otherwise   -- Occurs (textually) more than once, so look at its size
 517           = case guidance of
 518               UnfoldAlways -> True
 519               UnfoldNever  -> False
 520               UnfoldIfGoodArgs n_vals_wanted arg_discounts size res_discount
 521                 | enough_args && size <= (n_vals_wanted + 1)
 522                         -- No size increase
 523                         -- Size of call is n_vals_wanted (+1 for the function)
 524                 -> case in_lam of
 525                         NotInsideLam -> True
 526                         InsideLam    -> is_cheap
 527
 528                 | not (or arg_infos || really_interesting_cont || once)
 529                         -- If it occurs more than once, there must be something interesting
 530                         -- about some argument, or the result, to make it worth inlining
 531                         -- We also drop this case if the thing occurs once, although perhaps in
 532                         -- several branches.  In this case we are keener about inlining in the hope
 533                         -- that we'll be able to drop the allocation for the function altogether.
 534                 -> False
 535
 536                 | otherwise
 537                 -> case in_lam of
 538                         NotInsideLam -> small_enough
 539                         InsideLam    -> is_cheap && small_enough
 540
 541                 where
 542                   enough_args             = n_val_args >= n_vals_wanted
 543                   really_interesting_cont | n_val_args <  n_vals_wanted = False -- Too few args
 544                                           | n_val_args == n_vals_wanted = interesting_cont
 545                                           | otherwise                   = True  -- Extra args
 546                         -- This rather elaborate defn for really_interesting_cont is important
 547                         -- Consider an I# = INLINE (\x -> I# {x})
 548                         -- The unfolding guidance deems it to have size 2, and no arguments.
 549                         -- So in an application (I# y) we must take the extra arg 'y' as
 550                         -- evidence of an interesting context!
 551
 552                   small_enough = (size - discount) <= opt_UF_UseThreshold
 553                   discount     = computeDiscount n_vals_wanted arg_discounts res_discount
 554                                                  arg_infos really_interesting_cont
 555
 556
 557     in
 558 #ifdef DEBUG
 559     if opt_D_dump_inlinings then
 560         pprTrace "Considering inlining"
 561                  (ppr id <+> vcat [text "black listed" <+> ppr black_listed,
 562                                    text "inline prag:" <+> ppr inline_prag,
 563                                    text "arg infos" <+> ppr arg_infos,
 564                                    text "interesting continuation" <+> ppr interesting_cont,
 565                                    text "is cheap" <+> ppr is_cheap,
 566                                    text "guidance" <+> ppr guidance,
 567                                    text "ANSWER =" <+> if yes_or_no then text "YES" else text "NO",
 568                                    if yes_or_no then
 569                                         text "Unfolding =" <+> pprCoreExpr unf_template
 570                                    else empty])
 571                   result
 572     else
 573 #endif
 574     result
 575     }
 576
 577 computeDiscount :: Int -> [Int] -> Int -> [Bool] -> Bool -> Int
 578 computeDiscount n_vals_wanted arg_discounts res_discount arg_infos result_used
 579         -- We multiple the raw discounts (args_discount and result_discount)
 580         -- ty opt_UnfoldingKeenessFactor because the former have to do with
 581         -- *size* whereas the discounts imply that there's some extra
 582         -- *efficiency* to be gained (e.g. beta reductions, case reductions)
 583         -- by inlining.
 584
 585         -- we also discount 1 for each argument passed, because these will
 586         -- reduce with the lambdas in the function (we count 1 for a lambda
 587         -- in size_up).
 588   = length (take n_vals_wanted arg_infos) +
 589                         -- Discount of 1 for each arg supplied, because the
 590                         -- result replaces the call
 591     round (opt_UF_KeenessFactor *
 592            fromInt (arg_discount + result_discount))
 593   where
 594     arg_discount = sum (zipWith mk_arg_discount arg_discounts arg_infos)
 595
 596     mk_arg_discount discount is_evald | is_evald  = discount
 597                                       | otherwise = 0
 598
 599         -- Don't give a result discount unless there are enough args
 600     result_discount | result_used = res_discount        -- Over-applied, or case scrut
 601                     | otherwise   = 0
 602 \end{code}
 603
 604
 605 %************************************************************************
 606 %*                                                                      *
 607 \subsection{Black-listing}
 608 %*                                                                      *
 609 %************************************************************************
 610
 611 Inlining is controlled by the "Inline phase" number, which is set
 612 by the per-simplification-pass '-finline-phase' flag.
 613
 614 For optimisation we use phase 1,2 and nothing (i.e. no -finline-phase flag)
 615 in that order.  The meanings of these are determined by the @blackListed@ function
 616 here.
 617
 618 \begin{code}
 619 blackListed :: IdSet            -- Used in transformation rules
 620             -> Maybe Int        -- Inline phase
 621             -> Id -> Bool       -- True <=> blacklisted
 622
 623 -- The blackListed function sees whether a variable should *not* be
 624 -- inlined because of the inline phase we are in.  This is the sole
 625 -- place that the inline phase number is looked at.
 626
 627 -- Phase 0: used for 'no imported inlinings please'
 628 -- This prevents wrappers getting inlined which in turn is bad for full laziness
 629 blackListed rule_vars (Just 0)
 630   = \v -> not (isLocallyDefined v)
 631
 632 -- Phase 1: don't inline any rule-y things or things with specialisations
 633 blackListed rule_vars (Just 1)
 634   = \v -> let v_uniq = idUnique v
 635           in v `elemVarSet` rule_vars
 636           || not (isEmptyCoreRules (getIdSpecialisation v))
 637           || v_uniq == runSTRepIdKey
 638
 639 -- Phase 2: allow build/augment to inline, and specialisations
 640 blackListed rule_vars (Just 2)
 641   = \v -> let v_uniq = idUnique v
 642           in (v `elemVarSet` rule_vars && not (v_uniq == buildIdKey ||
 643                                                v_uniq == augmentIdKey))
 644           || v_uniq == runSTRepIdKey
 645
 646 -- Otherwise just go for it
 647 blackListed rule_vars phase
 648   = \v -> False
 649 \end{code}
 650
 651
 652 SLPJ 95/04: Why @runST@ must be inlined very late:
 653 \begin{verbatim}
 654 f x =
 655   runST ( \ s -> let
 656                     (a, s')  = newArray# 100 [] s
 657                     (_, s'') = fill_in_array_or_something a x s'
 658                   in
 659                   freezeArray# a s'' )
 660 \end{verbatim}
 661 If we inline @runST@, we'll get:
 662 \begin{verbatim}
 663 f x = let
 664         (a, s')  = newArray# 100 [] realWorld#{-NB-}
 665         (_, s'') = fill_in_array_or_something a x s'
 666       in
 667       freezeArray# a s''
 668 \end{verbatim}
 669 And now the @newArray#@ binding can be floated to become a CAF, which
 670 is totally and utterly wrong:
 671 \begin{verbatim}
 672 f = let
 673     (a, s')  = newArray# 100 [] realWorld#{-NB-} -- YIKES!!!
 674     in
 675     \ x ->
 676         let (_, s'') = fill_in_array_or_something a x s' in
 677         freezeArray# a s''
 678 \end{verbatim}
 679 All calls to @f@ will share a {\em single} array!
 680
 681 Yet we do want to inline runST sometime, so we can avoid
 682 needless code.  Solution: black list it until the last moment.
 683