ghc/compiler/coreSyn/CoreUnfold.lhs

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