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