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