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