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