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,   -- Abstract types
  18
  19         noUnfolding, mkTopUnfolding, mkUnfolding, mkCompulsoryUnfolding, seqUnfolding,
  20         mkOtherCon, otherCons,
  21         unfoldingTemplate, maybeUnfoldingTemplate,
  22         isEvaldUnfolding, isValueUnfolding, isCheapUnfolding, isCompulsoryUnfolding,
  23         hasUnfolding, hasSomeUnfolding,
  24
  25         couldBeSmallEnoughToInline,
  26         certainlyWillInline,
  27         okToUnfoldInHiFile,
  28
  29         callSiteInline, blackListed
  30     ) where
  31
  32 #include "HsVersions.h"
  33
  34 import CmdLineOpts      ( opt_UF_CreationThreshold,
  35                           opt_UF_UseThreshold,
  36                           opt_UF_ScrutConDiscount,
  37                           opt_UF_FunAppDiscount,
  38                           opt_UF_PrimArgDiscount,
  39                           opt_UF_KeenessFactor,
  40                           opt_UF_CheapOp, opt_UF_DearOp,
  41                           opt_UnfoldCasms, opt_PprStyle_Debug,
  42                           opt_D_dump_inlinings
  43                         )
  44 import CoreSyn
  45 import PprCore          ( pprCoreExpr )
  46 import OccurAnal        ( occurAnalyseGlobalExpr )
  47 import CoreUtils        ( exprIsValue, exprIsCheap, exprIsBottom, exprIsTrivial )
  48 import Id               ( Id, idType, idFlavour, isId, idWorkerInfo,
  49                           idSpecialisation, idInlinePragma, idUnfolding,
  50                           isPrimOpId_maybe
  51                         )
  52 import VarSet
  53 import Literal          ( isLitLitLit, litIsDupable )
  54 import PrimOp           ( PrimOp(..), primOpIsDupable, primOpOutOfLine, ccallIsCasm )
  55 import IdInfo           ( ArityInfo(..), InlinePragInfo(..), OccInfo(..), IdFlavour(..), CprInfo(..),
  56                           insideLam, workerExists, isNeverInlinePrag
  57                         )
  58 import Type             ( splitFunTy_maybe, isUnLiftedType )
  59 import Unique           ( Unique, buildIdKey, augmentIdKey, hasKey )
  60 import Bag
  61 import Outputable
  62
  63 #if __GLASGOW_HASKELL__ >= 404
  64 import GlaExts          ( fromInt )
  65 #endif
  66 \end{code}
  67
  68
  69 %************************************************************************
  70 %*                                                                      *
  71 \subsection{Making unfoldings}
  72 %*                                                                      *
  73 %************************************************************************
  74
  75 \begin{code}
  76 mkTopUnfolding expr = mkUnfolding True {- Top level -} expr
  77
  78 mkUnfolding top_lvl expr
  79   = CoreUnfolding (occurAnalyseGlobalExpr expr)
  80                   top_lvl
  81                   (exprIsCheap expr)
  82                   (exprIsValue expr)
  83                   (exprIsBottom expr)
  84                   (calcUnfoldingGuidance opt_UF_CreationThreshold expr)
  85         -- Sometimes during simplification, there's a large let-bound thing
  86         -- which has been substituted, and so is now dead; so 'expr' contains
  87         -- two copies of the thing while the occurrence-analysed expression doesn't
  88         -- Nevertheless, we don't occ-analyse before computing the size because the
  89         -- size computation bales out after a while, whereas occurrence analysis does not.
  90         --
  91         -- This can occasionally mean that the guidance is very pessimistic;
  92         -- it gets fixed up next round
  93
  94 mkCompulsoryUnfolding expr      -- Used for things that absolutely must be unfolded
  95   = CompulsoryUnfolding (occurAnalyseGlobalExpr expr)
  96 \end{code}
  97
  98
  99 %************************************************************************
 100 %*                                                                      *
 101 \subsection{The UnfoldingGuidance type}
 102 %*                                                                      *
 103 %************************************************************************
 104
 105 \begin{code}
 106 instance Outputable UnfoldingGuidance where
 107     ppr UnfoldNever     = ptext SLIT("NEVER")
 108     ppr (UnfoldIfGoodArgs v cs size discount)
 109       = hsep [ ptext SLIT("IF_ARGS"), int v,
 110                brackets (hsep (map int cs)),
 111                int size,
 112                int discount ]
 113 \end{code}
 114
 115
 116 \begin{code}
 117 calcUnfoldingGuidance
 118         :: Int                  -- bomb out if size gets bigger than this
 119         -> CoreExpr             -- expression to look at
 120         -> UnfoldingGuidance
 121 calcUnfoldingGuidance bOMB_OUT_SIZE expr
 122   = case collect_val_bndrs expr of { (inline, val_binders, body) ->
 123     let
 124         n_val_binders = length val_binders
 125
 126         max_inline_size = n_val_binders+2
 127         -- The idea is that if there is an INLINE pragma (inline is True)
 128         -- and there's a big body, we give a size of n_val_binders+2.  This
 129         -- This is just enough to fail the no-size-increase test in callSiteInline,
 130         --   so that INLINE things don't get inlined into entirely boring contexts,
 131         --   but no more.
 132
 133     in
 134     case (sizeExpr bOMB_OUT_SIZE val_binders body) of
 135
 136       TooBig
 137         | not inline -> UnfoldNever
 138                 -- A big function with an INLINE pragma must
 139                 -- have an UnfoldIfGoodArgs guidance
 140         | inline     -> UnfoldIfGoodArgs n_val_binders
 141                                          (map (const 0) val_binders)
 142                                          max_inline_size 0
 143
 144       SizeIs size cased_args scrut_discount
 145         -> UnfoldIfGoodArgs
 146                         n_val_binders
 147                         (map discount_for val_binders)
 148                         final_size
 149                         (I# scrut_discount)
 150         where
 151             boxed_size    = I# size
 152
 153             final_size | inline     = boxed_size `min` max_inline_size
 154                        | otherwise  = boxed_size
 155
 156                 -- Sometimes an INLINE thing is smaller than n_val_binders+2.
 157                 -- A particular case in point is a constructor, which has size 1.
 158                 -- We want to inline this regardless, hence the `min`
 159
 160             discount_for b = foldlBag (\acc (b',n) -> if b==b' then acc+n else acc)
 161                                       0 cased_args
 162         }
 163   where
 164     collect_val_bndrs e = go False [] e
 165         -- We need to be a bit careful about how we collect the
 166         -- value binders.  In ptic, if we see
 167         --      __inline_me (\x y -> e)
 168         -- We want to say "2 value binders".  Why?  So that
 169         -- we take account of information given for the arguments
 170
 171     go inline rev_vbs (Note InlineMe e)     = go True   rev_vbs     e
 172     go inline rev_vbs (Lam b e) | isId b    = go inline (b:rev_vbs) e
 173                                 | otherwise = go inline rev_vbs     e
 174     go inline rev_vbs e                     = (inline, reverse rev_vbs, e)
 175 \end{code}
 176
 177 \begin{code}
 178 sizeExpr :: Int             -- Bomb out if it gets bigger than this
 179          -> [Id]            -- Arguments; we're interested in which of these
 180                             -- get case'd
 181          -> CoreExpr
 182          -> ExprSize
 183
 184 sizeExpr (I# bOMB_OUT_SIZE) top_args expr
 185   = size_up expr
 186   where
 187     size_up (Type t)          = sizeZero        -- Types cost nothing
 188     size_up (Var v)           = sizeOne
 189
 190     size_up (Note _ body)     = size_up body    -- Notes cost nothing
 191
 192     size_up (App fun (Type t))  = size_up fun
 193     size_up (App fun arg)     = size_up_app fun [arg]
 194
 195     size_up (Lit lit) | litIsDupable lit = sizeOne
 196                       | otherwise        = sizeN opt_UF_DearOp  -- For lack of anything better
 197
 198     size_up (Lam b e) | isId b    = lamScrutDiscount (size_up e `addSizeN` 1)
 199                       | otherwise = size_up e
 200
 201     size_up (Let (NonRec binder rhs) body)
 202       = nukeScrutDiscount (size_up rhs)         `addSize`
 203         size_up body                            `addSizeN`
 204         (if isUnLiftedType (idType binder) then 0 else 1)
 205                 -- For the allocation
 206                 -- If the binder has an unlifted type there is no allocation
 207
 208     size_up (Let (Rec pairs) body)
 209       = nukeScrutDiscount rhs_size              `addSize`
 210         size_up body                            `addSizeN`
 211         length pairs            -- For the allocation
 212       where
 213         rhs_size = foldr (addSize . size_up . snd) sizeZero pairs
 214
 215     size_up (Case (Var v) _ alts)
 216         | v `elem` top_args             -- We are scrutinising an argument variable
 217         =
 218 {-      I'm nuking this special case; BUT see the comment with case alternatives.
 219
 220         (a) It's too eager.  We don't want to inline a wrapper into a
 221             context with no benefit.
 222             E.g.  \ x. f (x+x)          o point in inlining (+) here!
 223
 224         (b) It's ineffective. Once g's wrapper is inlined, its case-expressions
 225             aren't scrutinising arguments any more
 226
 227             case alts of
 228
 229                 [alt] -> size_up_alt alt `addSize` SizeIs 0# (unitBag (v, 1)) 0#
 230                 -- We want to make wrapper-style evaluation look cheap, so that
 231                 -- when we inline a wrapper it doesn't make call site (much) bigger
 232                 -- Otherwise we get nasty phase ordering stuff:
 233                 --      f x = g x x
 234                 --      h y = ...(f e)...
 235                 -- If we inline g's wrapper, f looks big, and doesn't get inlined
 236                 -- into h; if we inline f first, while it looks small, then g's
 237                 -- wrapper will get inlined later anyway.  To avoid this nasty
 238                 -- ordering difference, we make (case a of (x,y) -> ...),
 239                 -- *where a is one of the arguments* look free.
 240
 241                 other ->
 242 -}
 243                          alts_size (foldr addSize sizeOne alt_sizes)    -- The 1 is for the scrutinee
 244                                    (foldr1 maxSize alt_sizes)
 245
 246                 -- Good to inline if an arg is scrutinised, because
 247                 -- that may eliminate allocation in the caller
 248                 -- And it eliminates the case itself
 249
 250         where
 251           alt_sizes = map size_up_alt alts
 252
 253                 -- alts_size tries to compute a good discount for
 254                 -- the case when we are scrutinising an argument variable
 255           alts_size (SizeIs tot tot_disc tot_scrut)             -- Size of all alternatives
 256                     (SizeIs max max_disc max_scrut)             -- Size of biggest alternative
 257                 = SizeIs tot (unitBag (v, I# (1# +# tot -# max)) `unionBags` max_disc) max_scrut
 258                         -- If the variable is known, we produce a discount that
 259                         -- will take us back to 'max', the size of rh largest alternative
 260                         -- The 1+ is a little discount for reduced allocation in the caller
 261           alts_size tot_size _ = tot_size
 262
 263
 264     size_up (Case e _ alts) = nukeScrutDiscount (size_up e) `addSize`
 265                               foldr (addSize . size_up_alt) sizeZero alts
 266                 -- We don't charge for the case itself
 267                 -- It's a strict thing, and the price of the call
 268                 -- is paid by scrut.  Also consider
 269                 --      case f x of DEFAULT -> e
 270                 -- This is just ';'!  Don't charge for it.
 271
 272     ------------
 273     size_up_app (App fun arg) args
 274         | isTypeArg arg              = size_up_app fun args
 275         | otherwise                  = size_up_app fun (arg:args)
 276     size_up_app fun           args   = foldr (addSize . nukeScrutDiscount . size_up)
 277                                              (size_up_fun fun args)
 278                                              args
 279
 280         -- A function application with at least one value argument
 281         -- so if the function is an argument give it an arg-discount
 282         --
 283         -- Also behave specially if the function is a build
 284         --
 285         -- Also if the function is a constant Id (constr or primop)
 286         -- compute discounts specially
 287     size_up_fun (Var fun) args
 288       | fun `hasKey` buildIdKey   = buildSize
 289       | fun `hasKey` augmentIdKey = augmentSize
 290       | otherwise
 291       = case idFlavour fun of
 292           DataConId dc -> conSizeN (valArgCount args)
 293
 294           PrimOpId op  -> primOpSize op (valArgCount args)
 295                           -- foldr addSize (primOpSize op) (map arg_discount args)
 296                           -- At one time I tried giving an arg-discount if a primop
 297                           -- is applied to one of the function's arguments, but it's
 298                           -- not good.  At the moment, any unlifted-type arg gets a
 299                           -- 'True' for 'yes I'm evald', so we collect the discount even
 300                           -- if we know nothing about it.  And just having it in a primop
 301                           -- doesn't help at all if we don't know something more.
 302
 303           other        -> fun_discount fun `addSizeN`
 304                           (1 + length (filter (not . exprIsTrivial) args))
 305                                 -- The 1+ is for the function itself
 306                                 -- Add 1 for each non-trivial arg;
 307                                 -- the allocation cost, as in let(rec)
 308                                 -- Slight hack here: for constructors the args are almost always
 309                                 --      trivial; and for primops they are almost always prim typed
 310                                 --      We should really only count for non-prim-typed args in the
 311                                 --      general case, but that seems too much like hard work
 312
 313     size_up_fun other args = size_up other
 314
 315     ------------
 316     size_up_alt (con, bndrs, rhs) = size_up rhs
 317         -- Don't charge for args, so that wrappers look cheap
 318         -- (See comments about wrappers with Case)
 319
 320     ------------
 321         -- We want to record if we're case'ing, or applying, an argument
 322     fun_discount v | v `elem` top_args = SizeIs 0# (unitBag (v, opt_UF_FunAppDiscount)) 0#
 323     fun_discount other                 = sizeZero
 324
 325     ------------
 326         -- These addSize things have to be here because
 327         -- I don't want to give them bOMB_OUT_SIZE as an argument
 328
 329     addSizeN TooBig          _      = TooBig
 330     addSizeN (SizeIs n xs d) (I# m)
 331       | n_tot ># bOMB_OUT_SIZE      = TooBig
 332       | otherwise                   = SizeIs n_tot xs d
 333       where
 334         n_tot = n +# m
 335
 336     addSize TooBig _ = TooBig
 337     addSize _ TooBig = TooBig
 338     addSize (SizeIs n1 xs d1) (SizeIs n2 ys d2)
 339       | n_tot ># bOMB_OUT_SIZE = TooBig
 340       | otherwise              = SizeIs n_tot xys d_tot
 341       where
 342         n_tot = n1 +# n2
 343         d_tot = d1 +# d2
 344         xys   = xs `unionBags` ys
 345 \end{code}
 346
 347 Code for manipulating sizes
 348
 349 \begin{code}
 350
 351 data ExprSize = TooBig
 352               | SizeIs Int#             -- Size found
 353                        (Bag (Id,Int))   -- Arguments cased herein, and discount for each such
 354                        Int#             -- Size to subtract if result is scrutinised
 355                                         -- by a case expression
 356
 357 isTooBig TooBig = True
 358 isTooBig _      = False
 359
 360 maxSize TooBig         _                                  = TooBig
 361 maxSize _              TooBig                             = TooBig
 362 maxSize s1@(SizeIs n1 _ _) s2@(SizeIs n2 _ _) | n1 ># n2  = s1
 363                                               | otherwise = s2
 364
 365 sizeZero        = SizeIs 0# emptyBag 0#
 366 sizeOne         = SizeIs 1# emptyBag 0#
 367 sizeTwo         = SizeIs 2# emptyBag 0#
 368 sizeN (I# n)    = SizeIs n  emptyBag 0#
 369 conSizeN (I# n) = SizeIs 1# emptyBag (n +# 1#)
 370         -- Treat constructors as size 1; we are keen to expose them
 371         -- (and we charge separately for their args).  We can't treat
 372         -- them as size zero, else we find that (I# x) has size 1,
 373         -- which is the same as a lone variable; and hence 'v' will
 374         -- always be replaced by (I# x), where v is bound to I# x.
 375
 376 primOpSize op n_args
 377  | not (primOpIsDupable op) = sizeN opt_UF_DearOp
 378  | not (primOpOutOfLine op) = sizeZero                  -- These are good to inline
 379  | otherwise                = sizeOne
 380
 381 buildSize = SizeIs (-2#) emptyBag 4#
 382         -- We really want to inline applications of build
 383         -- build t (\cn -> e) should cost only the cost of e (because build will be inlined later)
 384         -- Indeed, we should add a result_discount becuause build is
 385         -- very like a constructor.  We don't bother to check that the
 386         -- build is saturated (it usually is).  The "-2" discounts for the \c n,
 387         -- The "4" is rather arbitrary.
 388
 389 augmentSize = SizeIs (-2#) emptyBag 4#
 390         -- Ditto (augment t (\cn -> e) ys) should cost only the cost of
 391         -- e plus ys. The -2 accounts for the \cn
 392
 393 nukeScrutDiscount (SizeIs n vs d) = SizeIs n vs 0#
 394 nukeScrutDiscount TooBig          = TooBig
 395
 396 -- When we return a lambda, give a discount if it's used (applied)
 397 lamScrutDiscount  (SizeIs n vs d) = case opt_UF_FunAppDiscount of { I# d -> SizeIs n vs d }
 398 lamScrutDiscount TooBig           = TooBig
 399 \end{code}
 400
 401
 402 %************************************************************************
 403 %*                                                                      *
 404 \subsection[considerUnfolding]{Given all the info, do (not) do the unfolding}
 405 %*                                                                      *
 406 %************************************************************************
 407
 408 We have very limited information about an unfolding expression: (1)~so
 409 many type arguments and so many value arguments expected---for our
 410 purposes here, we assume we've got those.  (2)~A ``size'' or ``cost,''
 411 a single integer.  (3)~An ``argument info'' vector.  For this, what we
 412 have at the moment is a Boolean per argument position that says, ``I
 413 will look with great favour on an explicit constructor in this
 414 position.'' (4)~The ``discount'' to subtract if the expression
 415 is being scrutinised.
 416
 417 Assuming we have enough type- and value arguments (if not, we give up
 418 immediately), then we see if the ``discounted size'' is below some
 419 (semi-arbitrary) threshold.  It works like this: for every argument
 420 position where we're looking for a constructor AND WE HAVE ONE in our
 421 hands, we get a (again, semi-arbitrary) discount [proportion to the
 422 number of constructors in the type being scrutinized].
 423
 424 If we're in the context of a scrutinee ( \tr{(case <expr > of A .. -> ...;.. )})
 425 and the expression in question will evaluate to a constructor, we use
 426 the computed discount size *for the result only* rather than
 427 computing the argument discounts. Since we know the result of
 428 the expression is going to be taken apart, discounting its size
 429 is more accurate (see @sizeExpr@ above for how this discount size
 430 is computed).
 431
 432 We use this one to avoid exporting inlinings that we ``couldn't possibly
 433 use'' on the other side.  Can be overridden w/ flaggery.
 434 Just the same as smallEnoughToInline, except that it has no actual arguments.
 435
 436 \begin{code}
 437 couldBeSmallEnoughToInline :: Int -> CoreExpr -> Bool
 438 couldBeSmallEnoughToInline threshold rhs = case calcUnfoldingGuidance threshold rhs of
 439                                                 UnfoldNever -> False
 440                                                 other       -> True
 441
 442 certainlyWillInline :: Id -> Bool
 443         -- Sees if the Id is pretty certain to inline
 444 certainlyWillInline v
 445   = case idUnfolding v of
 446
 447         CoreUnfolding _ _ _ is_value _ g@(UnfoldIfGoodArgs n_vals _ size _)
 448            ->    is_value
 449               && size - (n_vals +1) <= opt_UF_UseThreshold
 450
 451         other -> False
 452 \end{code}
 453
 454 @okToUnfoldInHifile@ is used when emitting unfolding info into an interface
 455 file to determine whether an unfolding candidate really should be unfolded.
 456 The predicate is needed to prevent @_casm_@s (+ lit-lits) from being emitted
 457 into interface files.
 458
 459 The reason for inlining expressions containing _casm_s into interface files
 460 is that these fragments of C are likely to mention functions/#defines that
 461 will be out-of-scope when inlined into another module. This is not an
 462 unfixable problem for the user (just need to -#include the approp. header
 463 file), but turning it off seems to the simplest thing to do.
 464
 465 \begin{code}
 466 okToUnfoldInHiFile :: CoreExpr -> Bool
 467 okToUnfoldInHiFile e = opt_UnfoldCasms || go e
 468  where
 469     -- Race over an expression looking for CCalls..
 470     go (Var v)                = case isPrimOpId_maybe v of
 471                                   Just op -> okToUnfoldPrimOp op
 472                                   Nothing -> True
 473     go (Lit lit)              = not (isLitLitLit lit)
 474     go (App fun arg)          = go fun && go arg
 475     go (Lam _ body)           = go body
 476     go (Let binds body)       = and (map go (body :rhssOfBind binds))
 477     go (Case scrut bndr alts) = and (map go (scrut:rhssOfAlts alts)) &&
 478                                 not (any isLitLitLit [ lit | (LitAlt lit, _, _) <- alts ])
 479     go (Note _ body)          = go body
 480     go (Type _)               = True
 481
 482     -- ok to unfold a PrimOp as long as it's not a _casm_
 483     okToUnfoldPrimOp (CCallOp ccall) = not (ccallIsCasm ccall)
 484     okToUnfoldPrimOp _               = True
 485 \end{code}
 486
 487
 488 %************************************************************************
 489 %*                                                                      *
 490 \subsection{callSiteInline}
 491 %*                                                                      *
 492 %************************************************************************
 493
 494 This is the key function.  It decides whether to inline a variable at a call site
 495
 496 callSiteInline is used at call sites, so it is a bit more generous.
 497 It's a very important function that embodies lots of heuristics.
 498 A non-WHNF can be inlined if it doesn't occur inside a lambda,
 499 and occurs exactly once or
 500     occurs once in each branch of a case and is small
 501
 502 If the thing is in WHNF, there's no danger of duplicating work,
 503 so we can inline if it occurs once, or is small
 504
 505 NOTE: we don't want to inline top-level functions that always diverge.
 506 It just makes the code bigger.  Tt turns out that the convenient way to prevent
 507 them inlining is to give them a NOINLINE pragma, which we do in
 508 StrictAnal.addStrictnessInfoToTopId
 509
 510 \begin{code}
 511 callSiteInline :: Bool                  -- True <=> the Id is black listed
 512                -> Bool                  -- 'inline' note at call site
 513                -> OccInfo
 514                -> Id                    -- The Id
 515                -> [Bool]                -- One for each value arg; True if it is interesting
 516                -> Bool                  -- True <=> continuation is interesting
 517                -> Maybe CoreExpr        -- Unfolding, if any
 518
 519
 520 callSiteInline black_listed inline_call occ id arg_infos interesting_cont
 521   = case idUnfolding id of {
 522         NoUnfolding -> Nothing ;
 523         OtherCon cs -> Nothing ;
 524         CompulsoryUnfolding unf_template | black_listed -> Nothing
 525                                          | otherwise    -> Just unf_template ;
 526                 -- Constructors have compulsory unfoldings, but
 527                 -- may have rules, in which case they are
 528                 -- black listed till later
 529         CoreUnfolding unf_template is_top is_cheap is_value is_bot guidance ->
 530
 531     let
 532         result | yes_or_no = Just unf_template
 533                | otherwise = Nothing
 534
 535         n_val_args  = length arg_infos
 536
 537         ok_inside_lam = is_value || is_bot || (is_cheap && not is_top)
 538                                 -- I'm experimenting with is_cheap && not is_top
 539
 540         yes_or_no
 541           | black_listed = False
 542           | otherwise    = case occ of
 543                                 IAmDead              -> pprTrace "callSiteInline: dead" (ppr id) False
 544                                 IAmALoopBreaker      -> False
 545                                 OneOcc in_lam one_br -> (not in_lam || ok_inside_lam) && consider_safe in_lam True  one_br
 546                                 NoOccInfo            -> ok_inside_lam                 && consider_safe True   False False
 547
 548         consider_safe in_lam once once_in_one_branch
 549                 -- consider_safe decides whether it's a good idea to inline something,
 550                 -- given that there's no work-duplication issue (the caller checks that).
 551                 -- once_in_one_branch = True means there's a unique textual occurrence
 552           | inline_call  = True
 553
 554           | once_in_one_branch
 555                 -- Be very keen to inline something if this is its unique occurrence:
 556                 --
 557                 --   a) Inlining gives a good chance of eliminating the original
 558                 --      binding (and hence the allocation) for the thing.
 559                 --      (Provided it's not a top level binding, in which case the
 560                 --       allocation costs nothing.)
 561                 --
 562                 --   b) Inlining a function that is called only once exposes the
 563                 --      body function to the call site.
 564                 --
 565                 -- The only time we hold back is when substituting inside a lambda;
 566                 -- then if the context is totally uninteresting (not applied, not scrutinised)
 567                 -- there is no point in substituting because it might just increase allocation,
 568                 -- by allocating the function itself many times
 569                 --
 570                 -- Note: there used to be a '&& not top_level' in the guard above,
 571                 --       but that stopped us inlining top-level functions used only once,
 572                 --       which is stupid
 573           = not in_lam || not (null arg_infos) || interesting_cont
 574
 575           | otherwise
 576           = case guidance of
 577               UnfoldNever  -> False ;
 578               UnfoldIfGoodArgs n_vals_wanted arg_discounts size res_discount
 579
 580                   | enough_args && size <= (n_vals_wanted + 1)
 581                         -- No size increase
 582                         -- Size of call is n_vals_wanted (+1 for the function)
 583                   -> True
 584
 585                   | otherwise
 586                   -> some_benefit && small_enough
 587
 588                   where
 589                     some_benefit = or arg_infos || really_interesting_cont ||
 590                                    (not is_top && (once || (n_vals_wanted > 0 && enough_args)))
 591                         -- If it occurs more than once, there must be something interesting
 592                         -- about some argument, or the result context, to make it worth inlining
 593                         --
 594                         -- If a function has a nested defn we also record some-benefit,
 595                         -- on the grounds that we are often able to eliminate the binding,
 596                         -- and hence the allocation, for the function altogether; this is good
 597                         -- for join points.  But this only makes sense for *functions*;
 598                         -- inlining a constructor doesn't help allocation unless the result is
 599                         -- scrutinised.  UNLESS the constructor occurs just once, albeit possibly
 600                         -- in multiple case branches.  Then inlining it doesn't increase allocation,
 601                         -- but it does increase the chance that the constructor won't be allocated at all
 602                         -- in the branches that don't use it.
 603
 604                     enough_args           = n_val_args >= n_vals_wanted
 605                     really_interesting_cont | n_val_args <  n_vals_wanted = False       -- Too few args
 606                                             | n_val_args == n_vals_wanted = interesting_cont
 607                                             | otherwise                   = True        -- Extra args
 608                         -- really_interesting_cont tells if the result of the
 609                         -- call is in an interesting context.
 610
 611                     small_enough = (size - discount) <= opt_UF_UseThreshold
 612                     discount     = computeDiscount n_vals_wanted arg_discounts res_discount
 613                                                  arg_infos really_interesting_cont
 614
 615     in
 616 #ifdef DEBUG
 617     if opt_D_dump_inlinings then
 618         pprTrace "Considering inlining"
 619                  (ppr id <+> vcat [text "black listed:" <+> ppr black_listed,
 620                                    text "occ info:" <+> ppr occ,
 621                                    text "arg infos" <+> ppr arg_infos,
 622                                    text "interesting continuation" <+> ppr interesting_cont,
 623                                    text "is value:" <+> ppr is_value,
 624                                    text "is cheap:" <+> ppr is_cheap,
 625                                    text "is bottom:" <+> ppr is_bot,
 626                                    text "is top-level:"    <+> ppr is_top,
 627                                    text "guidance" <+> ppr guidance,
 628                                    text "ANSWER =" <+> if yes_or_no then text "YES" else text "NO",
 629                                    if yes_or_no then
 630                                         text "Unfolding =" <+> pprCoreExpr unf_template
 631                                    else empty])
 632                   result
 633     else
 634 #endif
 635     result
 636     }
 637
 638 computeDiscount :: Int -> [Int] -> Int -> [Bool] -> Bool -> Int
 639 computeDiscount n_vals_wanted arg_discounts res_discount arg_infos result_used
 640         -- We multiple the raw discounts (args_discount and result_discount)
 641         -- ty opt_UnfoldingKeenessFactor because the former have to do with
 642         -- *size* whereas the discounts imply that there's some extra
 643         -- *efficiency* to be gained (e.g. beta reductions, case reductions)
 644         -- by inlining.
 645
 646         -- we also discount 1 for each argument passed, because these will
 647         -- reduce with the lambdas in the function (we count 1 for a lambda
 648         -- in size_up).
 649   = 1 +                 -- Discount of 1 because the result replaces the call
 650                         -- so we count 1 for the function itself
 651     length (take n_vals_wanted arg_infos) +
 652                         -- Discount of 1 for each arg supplied, because the
 653                         -- result replaces the call
 654     round (opt_UF_KeenessFactor *
 655            fromInt (arg_discount + result_discount))
 656   where
 657     arg_discount = sum (zipWith mk_arg_discount arg_discounts arg_infos)
 658
 659     mk_arg_discount discount is_evald | is_evald  = discount
 660                                       | otherwise = 0
 661
 662         -- Don't give a result discount unless there are enough args
 663     result_discount | result_used = res_discount        -- Over-applied, or case scrut
 664                     | otherwise   = 0
 665 \end{code}
 666
 667
 668 %************************************************************************
 669 %*                                                                      *
 670 \subsection{Black-listing}
 671 %*                                                                      *
 672 %************************************************************************
 673
 674 Inlining is controlled by the "Inline phase" number, which is set
 675 by the per-simplification-pass '-finline-phase' flag.
 676
 677 For optimisation we use phase 1,2 and nothing (i.e. no -finline-phase flag)
 678 in that order.  The meanings of these are determined by the @blackListed@ function
 679 here.
 680
 681 The final simplification doesn't have a phase number.
 682
 683 Pragmas
 684 ~~~~~~~
 685         Pragma          Black list if
 686
 687 (least black listing, most inlining)
 688         INLINE n foo    phase is Just p *and* p<n *and* foo appears on LHS of rule
 689         INLINE foo      phase is Just p *and*           foo appears on LHS of rule
 690         NOINLINE n foo  phase is Just p *and* (p<n *or* foo appears on LHS of rule)
 691         NOINLINE foo    always
 692 (most black listing, least inlining)
 693
 694 \begin{code}
 695 blackListed :: IdSet            -- Used in transformation rules
 696             -> Maybe Int        -- Inline phase
 697             -> Id -> Bool       -- True <=> blacklisted
 698
 699 -- The blackListed function sees whether a variable should *not* be
 700 -- inlined because of the inline phase we are in.  This is the sole
 701 -- place that the inline phase number is looked at.
 702
 703 blackListed rule_vars Nothing           -- Last phase
 704   = \v -> isNeverInlinePrag (idInlinePragma v)
 705
 706 blackListed rule_vars (Just phase)
 707   = \v -> normal_case rule_vars phase v
 708
 709 normal_case rule_vars phase v
 710   = case idInlinePragma v of
 711         NoInlinePragInfo -> has_rules
 712
 713         IMustNotBeINLINEd from_INLINE Nothing
 714           | from_INLINE -> has_rules    -- Black list until final phase
 715           | otherwise   -> True         -- Always blacklisted
 716
 717         IMustNotBeINLINEd from_INLINE (Just threshold)
 718           | from_INLINE -> (phase < threshold && has_rules)
 719           | otherwise   -> (phase < threshold || has_rules)
 720   where
 721     has_rules =  v `elemVarSet` rule_vars
 722               || not (isEmptyCoreRules (idSpecialisation v))
 723 \end{code}
 724
 725
 726 SLPJ 95/04: Why @runST@ must be inlined very late:
 727 \begin{verbatim}
 728 f x =
 729   runST ( \ s -> let
 730                     (a, s')  = newArray# 100 [] s
 731                     (_, s'') = fill_in_array_or_something a x s'
 732                   in
 733                   freezeArray# a s'' )
 734 \end{verbatim}
 735 If we inline @runST@, we'll get:
 736 \begin{verbatim}
 737 f x = let
 738         (a, s')  = newArray# 100 [] realWorld#{-NB-}
 739         (_, s'') = fill_in_array_or_something a x s'
 740       in
 741       freezeArray# a s''
 742 \end{verbatim}
 743 And now the @newArray#@ binding can be floated to become a CAF, which
 744 is totally and utterly wrong:
 745 \begin{verbatim}
 746 f = let
 747     (a, s')  = newArray# 100 [] realWorld#{-NB-} -- YIKES!!!
 748     in
 749     \ x ->
 750         let (_, s'') = fill_in_array_or_something a x s' in
 751         freezeArray# a s''
 752 \end{verbatim}
 753 All calls to @f@ will share a {\em single} array!
 754
 755 Yet we do want to inline runST sometime, so we can avoid
 756 needless code.  Solution: black list it until the last moment.
 757