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, mkMagicUnfolding, mkUnfolding, getUnfoldingTemplate,
  20         isEvaldUnfolding, hasUnfolding,
  21
  22         smallEnoughToInline, unfoldAlways, couldBeSmallEnoughToInline,
  23         certainlySmallEnoughToInline,
  24         okToUnfoldInHiFile,
  25
  26         calcUnfoldingGuidance
  27     ) where
  28
  29 #include "HsVersions.h"
  30
  31 import {-# SOURCE #-} MagicUFs  ( MagicUnfoldingFun, mkMagicUnfoldingFun )
  32
  33 import CmdLineOpts      ( opt_UnfoldingCreationThreshold,
  34                           opt_UnfoldingUseThreshold,
  35                           opt_UnfoldingConDiscount,
  36                           opt_UnfoldingKeenessFactor,
  37                           opt_UnfoldCasms, opt_PprStyle_Debug
  38                         )
  39 import Constants        ( uNFOLDING_CHEAP_OP_COST,
  40                           uNFOLDING_DEAR_OP_COST,
  41                           uNFOLDING_NOREP_LIT_COST
  42                         )
  43 import CoreSyn
  44 import OccurAnal        ( occurAnalyseGlobalExpr )
  45 import CoreUtils        ( coreExprType, exprIsTrivial, mkFormSummary,
  46                           FormSummary(..) )
  47 import Id               ( Id, idType, isId )
  48 import Const            ( Con(..), isLitLitLit )
  49 import PrimOp           ( PrimOp(..), primOpOutOfLine )
  50 import IdInfo           ( ArityInfo(..), InlinePragInfo(..) )
  51 import TyCon            ( tyConFamilySize )
  52 import Type             ( splitAlgTyConApp_maybe )
  53 import Const            ( isNoRepLit )
  54 import Unique           ( Unique )
  55 import Util             ( isIn )
  56 import Outputable
  57 \end{code}
  58
  59 %************************************************************************
  60 %*                                                                      *
  61 \subsection{@Unfolding@ and @UnfoldingGuidance@ types}
  62 %*                                                                      *
  63 %************************************************************************
  64
  65 \begin{code}
  66 data Unfolding
  67   = NoUnfolding
  68
  69   | OtherCon [Con]              -- It ain't one of these
  70                                 -- (OtherCon xs) also indicates that something has been evaluated
  71                                 -- and hence there's no point in re-evaluating it.
  72                                 -- OtherCon [] is used even for non-data-type values
  73                                 -- to indicated evaluated-ness.  Notably:
  74                                 --      data C = C !(Int -> Int)
  75                                 --      case x of { C f -> ... }
  76                                 -- Here, f gets an OtherCon [] unfolding.
  77
  78   | CoreUnfolding                       -- An unfolding with redundant cached information
  79                 FormSummary             -- Tells whether the template is a WHNF or bottom
  80                 UnfoldingGuidance       -- Tells about the *size* of the template.
  81                 CoreExpr                -- Template; binder-info is correct
  82
  83   | MagicUnfolding
  84         Unique                          -- Unique of the Id whose magic unfolding this is
  85         MagicUnfoldingFun
  86 \end{code}
  87
  88 \begin{code}
  89 noUnfolding = NoUnfolding
  90
  91 mkUnfolding expr
  92   = let
  93      -- strictness mangling (depends on there being no CSE)
  94      ufg = calcUnfoldingGuidance opt_UnfoldingCreationThreshold expr
  95      occ = occurAnalyseGlobalExpr expr
  96     in
  97     CoreUnfolding (mkFormSummary expr) ufg occ
  98
  99 mkMagicUnfolding :: Unique -> Unfolding
 100 mkMagicUnfolding tag  = MagicUnfolding tag (mkMagicUnfoldingFun tag)
 101
 102 getUnfoldingTemplate :: Unfolding -> CoreExpr
 103 getUnfoldingTemplate (CoreUnfolding _ _ expr) = expr
 104 getUnfoldingTemplate other = panic "getUnfoldingTemplate"
 105
 106 isEvaldUnfolding :: Unfolding -> Bool
 107 isEvaldUnfolding (OtherCon _)                     = True
 108 isEvaldUnfolding (CoreUnfolding ValueForm _ expr) = True
 109 isEvaldUnfolding other                            = False
 110
 111 hasUnfolding :: Unfolding -> Bool
 112 hasUnfolding NoUnfolding = False
 113 hasUnfolding other       = True
 114
 115 data UnfoldingGuidance
 116   = UnfoldNever
 117   | UnfoldAlways                -- There is no "original" definition,
 118                                 -- so you'd better unfold.  Or: something
 119                                 -- so cheap to unfold (e.g., 1#) that
 120                                 -- you should do it absolutely always.
 121
 122   | UnfoldIfGoodArgs    Int     -- if "m" type args
 123                         Int     -- and "n" value args
 124
 125                         [Int]   -- Discount if the argument is evaluated.
 126                                 -- (i.e., a simplification will definitely
 127                                 -- be possible).  One elt of the list per *value* arg.
 128
 129                         Int     -- The "size" of the unfolding; to be elaborated
 130                                 -- later. ToDo
 131
 132                         Int     -- Scrutinee discount: the discount to substract if the thing is in
 133                                 -- a context (case (thing args) of ...),
 134                                 -- (where there are the right number of arguments.)
 135
 136 unfoldAlways :: UnfoldingGuidance -> Bool
 137 unfoldAlways UnfoldAlways = True
 138 unfoldAlways other        = False
 139 \end{code}
 140
 141 \begin{code}
 142 instance Outputable UnfoldingGuidance where
 143     ppr UnfoldAlways            = ptext SLIT("_ALWAYS_")
 144     ppr (UnfoldIfGoodArgs t v cs size discount)
 145       = hsep [ptext SLIT("_IF_ARGS_"), int t, int v,
 146                if null cs       -- always print *something*
 147                 then char 'X'
 148                 else hcat (map (text . show) cs),
 149                int size,
 150                int discount ]
 151 \end{code}
 152
 153
 154 %************************************************************************
 155 %*                                                                      *
 156 \subsection[calcUnfoldingGuidance]{Calculate ``unfolding guidance'' for an expression}
 157 %*                                                                      *
 158 %************************************************************************
 159
 160 \begin{code}
 161 calcUnfoldingGuidance
 162         :: Int                  -- bomb out if size gets bigger than this
 163         -> CoreExpr             -- expression to look at
 164         -> UnfoldingGuidance
 165 calcUnfoldingGuidance bOMB_OUT_SIZE expr
 166   | exprIsTrivial expr          -- Often trivial expressions are never bound
 167                                 -- to an expression, but it can happen.  For
 168                                 -- example, the Id for a nullary constructor has
 169                                 -- a trivial expression as its unfolding, and
 170                                 -- we want to make sure that we always unfold it.
 171   = UnfoldAlways
 172
 173   | otherwise
 174   = case collectTyAndValBinders expr of { (ty_binders, val_binders, body) ->
 175     case (sizeExpr bOMB_OUT_SIZE val_binders body) of
 176
 177       TooBig -> UnfoldNever
 178
 179       SizeIs size cased_args scrut_discount
 180         -> UnfoldIfGoodArgs
 181                         (length ty_binders)
 182                         (length val_binders)
 183                         (map discount_for val_binders)
 184                         (I# size)
 185                         (I# scrut_discount)
 186         where
 187             discount_for b
 188                 | num_cases == 0 = 0
 189                 | otherwise
 190                 = if is_data
 191                         then tyConFamilySize tycon * num_cases
 192                         else num_cases -- prim cases are pretty cheap
 193
 194                  where
 195                    (is_data, tycon)
 196                      = case (splitAlgTyConApp_maybe (idType b)) of
 197                           Nothing       -> (False, panic "discount")
 198                           Just (tc,_,_) -> (True,  tc)
 199                    num_cases = length (filter (==b) cased_args)
 200         }
 201 \end{code}
 202
 203 \begin{code}
 204 sizeExpr :: Int             -- Bomb out if it gets bigger than this
 205          -> [Id]            -- Arguments; we're interested in which of these
 206                             -- get case'd
 207          -> CoreExpr
 208          -> ExprSize
 209
 210 sizeExpr (I# bOMB_OUT_SIZE) args expr
 211   = size_up expr
 212   where
 213     size_up (Type t)       = sizeZero           -- Types cost nothing
 214     size_up (Note _ body)  = size_up body       -- Notes cost nothing
 215     size_up (Var v)        = sizeOne
 216     size_up (App fun arg)  = size_up fun `addSize` size_up arg
 217
 218     size_up (Con con args) = foldr (addSize . size_up)
 219                                    (size_up_con con (valArgCount args))
 220                                    args
 221
 222     size_up (Lam b e) | isId b    = size_up e `addSizeN` 1
 223                       | otherwise = size_up e
 224
 225     size_up (Let (NonRec binder rhs) body)
 226       = nukeScrutDiscount (size_up rhs)         `addSize`
 227         size_up body                            `addSizeN`
 228         1       -- For the allocation
 229
 230     size_up (Let (Rec pairs) body)
 231       = nukeScrutDiscount rhs_size              `addSize`
 232         size_up body                            `addSizeN`
 233         length pairs            -- For the allocation
 234       where
 235         rhs_size = foldr (addSize . size_up . snd) sizeZero pairs
 236
 237     size_up (Case scrut _ alts)
 238       = nukeScrutDiscount (size_up scrut)               `addSize`
 239         arg_discount scrut                              `addSize`
 240         foldr (addSize . size_up_alt) sizeZero alts     `addSizeN`
 241         case (splitAlgTyConApp_maybe (coreExprType scrut)) of
 242                 Nothing       -> 1
 243                 Just (tc,_,_) -> tyConFamilySize tc
 244
 245     ------------
 246     size_up_alt (con, bndrs, rhs) = size_up rhs
 247             -- Don't charge for args, so that wrappers look cheap
 248
 249     ------------
 250     size_up_con (Literal lit) nv | isNoRepLit lit = sizeN uNFOLDING_NOREP_LIT_COST
 251                                  | otherwise      = sizeOne
 252
 253     size_up_con (DataCon dc) n_val_args = conSizeN n_val_args
 254
 255     size_up_con (PrimOp op) nv = sizeN op_cost
 256       where
 257         op_cost = if primOpOutOfLine op
 258                   then uNFOLDING_DEAR_OP_COST
 259                         -- these *tend* to be more expensive;
 260                         -- number chosen to avoid unfolding (HACK)
 261                   else uNFOLDING_CHEAP_OP_COST
 262
 263     ------------
 264         -- We want to record if we're case'ing an argument
 265     arg_discount (Var v) | v `is_elem` args = scrutArg v
 266     arg_discount other                      = sizeZero
 267
 268     is_elem :: Id -> [Id] -> Bool
 269     is_elem = isIn "size_up_scrut"
 270
 271     ------------
 272         -- These addSize things have to be here because
 273         -- I don't want to give them bOMB_OUT_SIZE as an argument
 274
 275     addSizeN TooBig          _ = TooBig
 276     addSizeN (SizeIs n xs d) (I# m)
 277       | n_tot -# d <# bOMB_OUT_SIZE = SizeIs n_tot xs d
 278       | otherwise                   = TooBig
 279       where
 280         n_tot = n +# m
 281
 282     addSize TooBig _ = TooBig
 283     addSize _ TooBig = TooBig
 284     addSize (SizeIs n1 xs d1) (SizeIs n2 ys d2)
 285       | (n_tot -# d_tot) <# bOMB_OUT_SIZE = SizeIs n_tot xys d_tot
 286       | otherwise                         = TooBig
 287       where
 288         n_tot = n1 +# n2
 289         d_tot = d1 +# d2
 290         xys   = xs ++ ys
 291
 292
 293 \end{code}
 294
 295 Code for manipulating sizes
 296
 297 \begin{code}
 298
 299 data ExprSize = TooBig
 300               | SizeIs Int#     -- Size found
 301                        [Id]     -- Arguments cased herein
 302                        Int#     -- Size to subtract if result is scrutinised
 303                                 -- by a case expression
 304
 305 sizeZero        = SizeIs 0# [] 0#
 306 sizeOne         = SizeIs 1# [] 0#
 307 sizeN (I# n)    = SizeIs n  [] 0#
 308 conSizeN (I# n) = SizeIs 0# [] n   -- We don't count 1 for the constructor because we're
 309                                    -- quite keen to get constructors into the open
 310 scrutArg v      = SizeIs 0# [v] 0#
 311
 312 nukeScrutDiscount (SizeIs n vs d) = SizeIs n vs 0#
 313 nukeScrutDiscount TooBig          = TooBig
 314 \end{code}
 315
 316 %************************************************************************
 317 %*                                                                      *
 318 \subsection[considerUnfolding]{Given all the info, do (not) do the unfolding}
 319 %*                                                                      *
 320 %************************************************************************
 321
 322 We have very limited information about an unfolding expression: (1)~so
 323 many type arguments and so many value arguments expected---for our
 324 purposes here, we assume we've got those.  (2)~A ``size'' or ``cost,''
 325 a single integer.  (3)~An ``argument info'' vector.  For this, what we
 326 have at the moment is a Boolean per argument position that says, ``I
 327 will look with great favour on an explicit constructor in this
 328 position.'' (4)~The ``discount'' to subtract if the expression
 329 is being scrutinised.
 330
 331 Assuming we have enough type- and value arguments (if not, we give up
 332 immediately), then we see if the ``discounted size'' is below some
 333 (semi-arbitrary) threshold.  It works like this: for every argument
 334 position where we're looking for a constructor AND WE HAVE ONE in our
 335 hands, we get a (again, semi-arbitrary) discount [proportion to the
 336 number of constructors in the type being scrutinized].
 337
 338 If we're in the context of a scrutinee ( \tr{(case <expr > of A .. -> ...;.. )})
 339 and the expression in question will evaluate to a constructor, we use
 340 the computed discount size *for the result only* rather than
 341 computing the argument discounts. Since we know the result of
 342 the expression is going to be taken apart, discounting its size
 343 is more accurate (see @sizeExpr@ above for how this discount size
 344 is computed).
 345
 346 \begin{code}
 347 smallEnoughToInline :: Id                       -- The function (trace msg only)
 348                     -> [Bool]                   -- Evaluated-ness of value arguments
 349                                                 -- ** May be infinite in don't care cases **
 350                                                 --    see couldBeSmallEnoughToInline etc
 351                     -> Bool                     -- Result is scrutinised
 352                     -> UnfoldingGuidance
 353                     -> Bool                     -- True => unfold it
 354
 355 smallEnoughToInline _ _ _ UnfoldAlways = True
 356 smallEnoughToInline _ _ _ UnfoldNever  = False
 357 smallEnoughToInline id arg_evals result_is_scruted
 358                     (UnfoldIfGoodArgs m_tys_wanted n_vals_wanted discount_vec size scrut_discount)
 359   | fun_with_no_args
 360   = False
 361
 362   | (size - discount) > opt_UnfoldingUseThreshold
 363   = if opt_PprStyle_Debug then
 364         pprTrace " too big:" stuff False
 365     else
 366         False
 367
 368   | otherwise           -- All right!
 369   = if opt_PprStyle_Debug then
 370         pprTrace " small enough:" stuff True
 371     else
 372         True
 373
 374   where
 375     stuff = braces (ppr id <+> ppr (take 10 arg_evals) <+> ppr result_is_scruted <+>
 376                     ppr size <+> ppr discount)
 377
 378     fun_with_no_args = n_vals_wanted > 0 && null arg_evals
 379                 -- A *function* with *no* value args => don't unfold
 380                 -- Otherwise it's ok to try
 381
 382         -- We multiple the raw discounts (args_discount and result_discount)
 383         -- ty opt_UnfoldingKeenessFactor because the former have to do with
 384         -- *size* whereas the discounts imply that there's some extra
 385         -- *efficiency* to be gained (e.g. beta reductions, case reductions)
 386         -- by inlining.
 387
 388         -- we also discount 1 for each argument passed, because these will
 389         -- reduce with the lambdas in the function (we count 1 for a lambda
 390         -- in size_up).
 391
 392         -- NB: we never take the length of arg_evals because it might be infinite
 393     discount :: Int
 394     discount = length (take n_vals_wanted arg_evals) +
 395                round (opt_UnfoldingKeenessFactor *
 396                       fromInt (arg_discount + result_discount))
 397
 398     arg_discount    = sum (zipWith mk_arg_discount discount_vec arg_evals)
 399     result_discount = mk_result_discount (drop n_vals_wanted arg_evals)
 400
 401     mk_arg_discount no_of_constrs is_evald
 402       | is_evald  = no_of_constrs * opt_UnfoldingConDiscount
 403       | otherwise = 0
 404
 405     mk_result_discount extra_args
 406         | not (null extra_args) || result_is_scruted = scrut_discount   -- Over-applied, or case scrut
 407         | otherwise                                  = 0
 408 \end{code}
 409
 410 We use this one to avoid exporting inlinings that we ``couldn't possibly
 411 use'' on the other side.  Can be overridden w/ flaggery.
 412 Just the same as smallEnoughToInline, except that it has no actual arguments.
 413
 414 \begin{code}
 415 couldBeSmallEnoughToInline :: Id -> UnfoldingGuidance -> Bool
 416 couldBeSmallEnoughToInline id guidance = smallEnoughToInline id (repeat True) True guidance
 417
 418 certainlySmallEnoughToInline :: Id -> UnfoldingGuidance -> Bool
 419 certainlySmallEnoughToInline id guidance = smallEnoughToInline id (repeat False) False guidance
 420 \end{code}
 421
 422 @okToUnfoldInHifile@ is used when emitting unfolding info into an interface
 423 file to determine whether an unfolding candidate really should be unfolded.
 424 The predicate is needed to prevent @_casm_@s (+ lit-lits) from being emitted
 425 into interface files.
 426
 427 The reason for inlining expressions containing _casm_s into interface files
 428 is that these fragments of C are likely to mention functions/#defines that
 429 will be out-of-scope when inlined into another module. This is not an
 430 unfixable problem for the user (just need to -#include the approp. header
 431 file), but turning it off seems to the simplest thing to do.
 432
 433 \begin{code}
 434 okToUnfoldInHiFile :: CoreExpr -> Bool
 435 okToUnfoldInHiFile e = opt_UnfoldCasms || go e
 436  where
 437     -- Race over an expression looking for CCalls..
 438     go (Var _)                = True
 439     go (Con (Literal lit) _)  = not (isLitLitLit lit)
 440     go (Con (PrimOp op) args) = okToUnfoldPrimOp op && all go args
 441     go (Con con args)         = True -- con args are always atomic
 442     go (App fun arg)          = go fun && go arg
 443     go (Lam _ body)           = go body
 444     go (Let binds body)       = and (map go (body :rhssOfBind binds))
 445     go (Case scrut bndr alts) = and (map go (scrut:rhssOfAlts alts))
 446     go (Note _ body)          = go body
 447     go (Type _)               = True
 448
 449     -- ok to unfold a PrimOp as long as it's not a _casm_
 450     okToUnfoldPrimOp (CCallOp _ is_casm _ _) = not is_casm
 451     okToUnfoldPrimOp _                       = True
 452 \end{code}