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, 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
  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, panic )
  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 \end{code}
 136
 137 \begin{code}
 138 instance Outputable UnfoldingGuidance where
 139     ppr UnfoldAlways            = ptext SLIT("_ALWAYS_")
 140     ppr (UnfoldIfGoodArgs t v cs size discount)
 141       = hsep [ptext SLIT("_IF_ARGS_"), int t, int v,
 142                if null cs       -- always print *something*
 143                 then char 'X'
 144                 else hcat (map (text . show) cs),
 145                int size,
 146                int discount ]
 147 \end{code}
 148
 149
 150 %************************************************************************
 151 %*                                                                      *
 152 \subsection[calcUnfoldingGuidance]{Calculate ``unfolding guidance'' for an expression}
 153 %*                                                                      *
 154 %************************************************************************
 155
 156 \begin{code}
 157 calcUnfoldingGuidance
 158         :: Int                  -- bomb out if size gets bigger than this
 159         -> CoreExpr             -- expression to look at
 160         -> UnfoldingGuidance
 161 calcUnfoldingGuidance bOMB_OUT_SIZE expr
 162   | exprIsTrivial expr          -- Often trivial expressions are never bound
 163                                 -- to an expression, but it can happen.  For
 164                                 -- example, the Id for a nullary constructor has
 165                                 -- a trivial expression as its unfolding, and
 166                                 -- we want to make sure that we always unfold it.
 167   = UnfoldAlways
 168
 169   | otherwise
 170   = case collectTyAndValBinders expr of { (ty_binders, val_binders, body) ->
 171     case (sizeExpr bOMB_OUT_SIZE val_binders body) of
 172
 173       TooBig -> UnfoldNever
 174
 175       SizeIs size cased_args scrut_discount
 176         -> UnfoldIfGoodArgs
 177                         (length ty_binders)
 178                         (length val_binders)
 179                         (map discount_for val_binders)
 180                         (I# size)
 181                         (I# scrut_discount)
 182         where
 183             discount_for b
 184                 | num_cases == 0 = 0
 185                 | otherwise
 186                 = if is_data
 187                         then tyConFamilySize tycon * num_cases
 188                         else num_cases -- prim cases are pretty cheap
 189
 190                  where
 191                    (is_data, tycon)
 192                      = case (splitAlgTyConApp_maybe (idType b)) of
 193                           Nothing       -> (False, panic "discount")
 194                           Just (tc,_,_) -> (True,  tc)
 195                    num_cases = length (filter (==b) cased_args)
 196         }
 197 \end{code}
 198
 199 \begin{code}
 200 sizeExpr :: Int             -- Bomb out if it gets bigger than this
 201          -> [Id]            -- Arguments; we're interested in which of these
 202                             -- get case'd
 203          -> CoreExpr
 204          -> ExprSize
 205
 206 sizeExpr (I# bOMB_OUT_SIZE) args expr
 207   = size_up expr
 208   where
 209     size_up (Type t)       = sizeZero           -- Types cost nothing
 210     size_up (Note _ body)  = size_up body       -- Notes cost nothing
 211     size_up (Var v)        = sizeOne
 212     size_up (App fun arg)  = size_up fun `addSize` size_up arg
 213
 214     size_up (Con con args) = foldr (addSize . size_up)
 215                                    (size_up_con con (valArgCount args))
 216                                    args
 217
 218     size_up (Lam b e) | isId b    = size_up e `addSizeN` 1
 219                       | otherwise = size_up e
 220
 221     size_up (Let (NonRec binder rhs) body)
 222       = nukeScrutDiscount (size_up rhs)         `addSize`
 223         size_up body                            `addSizeN`
 224         1       -- For the allocation
 225
 226     size_up (Let (Rec pairs) body)
 227       = nukeScrutDiscount rhs_size              `addSize`
 228         size_up body                            `addSizeN`
 229         length pairs            -- For the allocation
 230       where
 231         rhs_size = foldr (addSize . size_up . snd) sizeZero pairs
 232
 233     size_up (Case scrut _ alts)
 234       = nukeScrutDiscount (size_up scrut)               `addSize`
 235         arg_discount scrut                              `addSize`
 236         foldr (addSize . size_up_alt) sizeZero alts     `addSizeN`
 237         case (splitAlgTyConApp_maybe (coreExprType scrut)) of
 238                 Nothing       -> 1
 239                 Just (tc,_,_) -> tyConFamilySize tc
 240
 241     ------------
 242     size_up_alt (con, bndrs, rhs) = size_up rhs
 243             -- Don't charge for args, so that wrappers look cheap
 244
 245     ------------
 246     size_up_con (Literal lit) nv | isNoRepLit lit = sizeN uNFOLDING_NOREP_LIT_COST
 247                                  | otherwise      = sizeOne
 248
 249     size_up_con (DataCon dc) n_val_args = conSizeN n_val_args
 250
 251     size_up_con (PrimOp op) nv = sizeN op_cost
 252       where
 253         op_cost = if primOpOutOfLine op
 254                   then uNFOLDING_DEAR_OP_COST
 255                         -- these *tend* to be more expensive;
 256                         -- number chosen to avoid unfolding (HACK)
 257                   else uNFOLDING_CHEAP_OP_COST
 258
 259     ------------
 260         -- We want to record if we're case'ing an argument
 261     arg_discount (Var v) | v `is_elem` args = scrutArg v
 262     arg_discount other                      = sizeZero
 263
 264     is_elem :: Id -> [Id] -> Bool
 265     is_elem = isIn "size_up_scrut"
 266
 267     ------------
 268         -- These addSize things have to be here because
 269         -- I don't want to give them bOMB_OUT_SIZE as an argument
 270
 271     addSizeN TooBig          _ = TooBig
 272     addSizeN (SizeIs n xs d) (I# m)
 273       | n_tot -# d <# bOMB_OUT_SIZE = SizeIs n_tot xs d
 274       | otherwise                   = TooBig
 275       where
 276         n_tot = n +# m
 277
 278     addSize TooBig _ = TooBig
 279     addSize _ TooBig = TooBig
 280     addSize (SizeIs n1 xs d1) (SizeIs n2 ys d2)
 281       | (n_tot -# d_tot) <# bOMB_OUT_SIZE = SizeIs n_tot xys d_tot
 282       | otherwise                         = TooBig
 283       where
 284         n_tot = n1 +# n2
 285         d_tot = d1 +# d2
 286         xys   = xs ++ ys
 287
 288
 289 \end{code}
 290
 291 Code for manipulating sizes
 292
 293 \begin{code}
 294
 295 data ExprSize = TooBig
 296               | SizeIs Int#     -- Size found
 297                        [Id]     -- Arguments cased herein
 298                        Int#     -- Size to subtract if result is scrutinised
 299                                 -- by a case expression
 300
 301 sizeZero        = SizeIs 0# [] 0#
 302 sizeOne         = SizeIs 1# [] 0#
 303 sizeN (I# n)    = SizeIs n  [] 0#
 304 conSizeN (I# n) = SizeIs 0# [] n   -- We don't count 1 for the constructor because we're
 305                                    -- quite keen to get constructors into the open
 306 scrutArg v      = SizeIs 0# [v] 0#
 307
 308 nukeScrutDiscount (SizeIs n vs d) = SizeIs n vs 0#
 309 nukeScrutDiscount TooBig          = TooBig
 310 \end{code}
 311
 312 %************************************************************************
 313 %*                                                                      *
 314 \subsection[considerUnfolding]{Given all the info, do (not) do the unfolding}
 315 %*                                                                      *
 316 %************************************************************************
 317
 318 We have very limited information about an unfolding expression: (1)~so
 319 many type arguments and so many value arguments expected---for our
 320 purposes here, we assume we've got those.  (2)~A ``size'' or ``cost,''
 321 a single integer.  (3)~An ``argument info'' vector.  For this, what we
 322 have at the moment is a Boolean per argument position that says, ``I
 323 will look with great favour on an explicit constructor in this
 324 position.'' (4)~The ``discount'' to subtract if the expression
 325 is being scrutinised.
 326
 327 Assuming we have enough type- and value arguments (if not, we give up
 328 immediately), then we see if the ``discounted size'' is below some
 329 (semi-arbitrary) threshold.  It works like this: for every argument
 330 position where we're looking for a constructor AND WE HAVE ONE in our
 331 hands, we get a (again, semi-arbitrary) discount [proportion to the
 332 number of constructors in the type being scrutinized].
 333
 334 If we're in the context of a scrutinee ( \tr{(case <expr > of A .. -> ...;.. )})
 335 and the expression in question will evaluate to a constructor, we use
 336 the computed discount size *for the result only* rather than
 337 computing the argument discounts. Since we know the result of
 338 the expression is going to be taken apart, discounting its size
 339 is more accurate (see @sizeExpr@ above for how this discount size
 340 is computed).
 341
 342 \begin{code}
 343 smallEnoughToInline :: Id                       -- The function (trace msg only)
 344                     -> [Bool]                   -- Evaluated-ness of value arguments
 345                     -> Bool                     -- Result is scrutinised
 346                     -> UnfoldingGuidance
 347                     -> Bool                     -- True => unfold it
 348
 349 smallEnoughToInline _ _ _ UnfoldAlways = True
 350 smallEnoughToInline _ _ _ UnfoldNever  = False
 351 smallEnoughToInline id arg_is_evald_s result_is_scruted
 352               (UnfoldIfGoodArgs m_tys_wanted n_vals_wanted discount_vec size scrut_discount)
 353   = if enough_args n_vals_wanted arg_is_evald_s &&
 354        size - discount <= opt_UnfoldingUseThreshold
 355     then
 356        True
 357     else
 358        False
 359   where
 360
 361     enough_args n [] | n > 0 = False    -- A function with no value args => don't unfold
 362     enough_args _ _          = True     -- Otherwise it's ok to try
 363
 364         -- We multiple the raw discounts (args_discount and result_discount)
 365         -- ty opt_UnfoldingKeenessFactor because the former have to do with
 366         -- *size* whereas the discounts imply that there's some extra
 367         -- *efficiency* to be gained (e.g. beta reductions, case reductions)
 368         -- by inlining.
 369
 370         -- we also discount 1 for each argument passed, because these will
 371         -- reduce with the lambdas in the function (we count 1 for a lambda
 372         -- in size_up).
 373
 374     discount :: Int
 375     discount = length (take n_vals_wanted arg_is_evald_s) +
 376                round (
 377                       opt_UnfoldingKeenessFactor *
 378                       fromInt (args_discount + result_discount)
 379                      )
 380
 381     args_discount = sum (zipWith arg_discount discount_vec arg_is_evald_s)
 382     result_discount | result_is_scruted = scrut_discount
 383                     | otherwise         = 0
 384
 385     arg_discount no_of_constrs is_evald
 386       | is_evald  = no_of_constrs * opt_UnfoldingConDiscount
 387       | otherwise = 0
 388 \end{code}
 389
 390 We use this one to avoid exporting inlinings that we ``couldn't possibly
 391 use'' on the other side.  Can be overridden w/ flaggery.
 392 Just the same as smallEnoughToInline, except that it has no actual arguments.
 393
 394 \begin{code}
 395 couldBeSmallEnoughToInline :: Id -> UnfoldingGuidance -> Bool
 396 couldBeSmallEnoughToInline id guidance = smallEnoughToInline id (repeat True) True guidance
 397
 398 certainlySmallEnoughToInline :: Id -> UnfoldingGuidance -> Bool
 399 certainlySmallEnoughToInline id guidance = smallEnoughToInline id (repeat False) False guidance
 400 \end{code}
 401
 402 @okToUnfoldInHifile@ is used when emitting unfolding info into an interface
 403 file to determine whether an unfolding candidate really should be unfolded.
 404 The predicate is needed to prevent @_casm_@s (+ lit-lits) from being emitted
 405 into interface files.
 406
 407 The reason for inlining expressions containing _casm_s into interface files
 408 is that these fragments of C are likely to mention functions/#defines that
 409 will be out-of-scope when inlined into another module. This is not an
 410 unfixable problem for the user (just need to -#include the approp. header
 411 file), but turning it off seems to the simplest thing to do.
 412
 413 \begin{code}
 414 okToUnfoldInHiFile :: CoreExpr -> Bool
 415 okToUnfoldInHiFile e = opt_UnfoldCasms || go e
 416  where
 417     -- Race over an expression looking for CCalls..
 418     go (Var _)                = True
 419     go (Con (Literal lit) _)  = not (isLitLitLit lit)
 420     go (Con (PrimOp op) args) = okToUnfoldPrimOp op && all go args
 421     go (Con con args)         = True -- con args are always atomic
 422     go (App fun arg)          = go fun && go arg
 423     go (Lam _ body)           = go body
 424     go (Let binds body)       = and (map go (body :rhssOfBind binds))
 425     go (Case scrut bndr alts) = and (map go (scrut:rhssOfAlts alts))
 426     go (Note _ body)          = go body
 427     go (Type _)               = True
 428
 429     -- ok to unfold a PrimOp as long as it's not a _casm_
 430     okToUnfoldPrimOp (CCallOp _ is_casm _ _) = not is_casm
 431     okToUnfoldPrimOp _                       = True
 432 \end{code}