ghc/compiler/coreSyn/CoreUnfold.lhs

   1 %
   2 % (c) The AQUA Project, Glasgow University, 1994-1996
   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 @SimpleUnfolding@ unfolding, you will
  13 find, unsurprisingly, a Core expression.
  14
  15 \begin{code}
  16 module CoreUnfold (
  17         SimpleUnfolding(..), Unfolding(..), UnfoldingGuidance(..), -- types
  18
  19         FormSummary(..), mkFormSummary, whnfOrBottom, exprSmallEnoughToDup,
  20         exprIsTrivial,
  21
  22         noUnfolding, mkMagicUnfolding, mkUnfolding, getUnfoldingTemplate,
  23
  24         smallEnoughToInline, couldBeSmallEnoughToInline,
  25         certainlySmallEnoughToInline, inlineUnconditionally,
  26
  27         calcUnfoldingGuidance,
  28
  29         PragmaInfo(..)          -- Re-export
  30     ) where
  31
  32 #include "HsVersions.h"
  33
  34 import {-# SOURCE #-} MagicUFs  ( MagicUnfoldingFun, mkMagicUnfoldingFun )
  35
  36 import CmdLineOpts      ( opt_UnfoldingCreationThreshold,
  37                           opt_UnfoldingUseThreshold,
  38                           opt_UnfoldingConDiscount,
  39                           opt_UnfoldingKeenessFactor
  40                         )
  41 import Constants        ( uNFOLDING_CHEAP_OP_COST,
  42                           uNFOLDING_DEAR_OP_COST,
  43                           uNFOLDING_NOREP_LIT_COST
  44                         )
  45 import BinderInfo       ( BinderInfo, isOneFunOcc, isOneSafeFunOcc
  46                         )
  47 import PragmaInfo       ( PragmaInfo(..) )
  48 import CoreSyn
  49 import CoreUtils        ( unTagBinders )
  50 import OccurAnal        ( occurAnalyseGlobalExpr )
  51 import CoreUtils        ( coreExprType )
  52 import Id               ( Id, idType, getIdArity,  isBottomingId, isDataCon,
  53                           idWantsToBeINLINEd, idMustBeINLINEd, idMustNotBeINLINEd,
  54                           IdSet, GenId{-instances-} )
  55 import PrimOp           ( fragilePrimOp, primOpCanTriggerGC )
  56 import IdInfo           ( ArityInfo(..) )
  57 import Literal          ( isNoRepLit )
  58 import TyCon            ( tyConFamilySize )
  59 import Type             ( splitAlgTyConApp_maybe )
  60 import Unique           ( Unique )
  61 import Util             ( isIn, panic, assertPanic )
  62 import Outputable
  63 \end{code}
  64
  65 %************************************************************************
  66 %*                                                                      *
  67 \subsection{@Unfolding@ and @UnfoldingGuidance@ types}
  68 %*                                                                      *
  69 %************************************************************************
  70
  71 \begin{code}
  72 data Unfolding
  73   = NoUnfolding
  74
  75   | CoreUnfolding SimpleUnfolding
  76
  77   | MagicUnfolding
  78         Unique                          -- Unique of the Id whose magic unfolding this is
  79         MagicUnfoldingFun
  80
  81
  82 data SimpleUnfolding
  83   = SimpleUnfolding                     -- An unfolding with redundant cached information
  84                 FormSummary             -- Tells whether the template is a WHNF or bottom
  85                 UnfoldingGuidance       -- Tells about the *size* of the template.
  86                 SimplifiableCoreExpr    -- Template
  87
  88
  89 noUnfolding = NoUnfolding
  90
  91 mkUnfolding inline_prag expr
  92   = let
  93      -- strictness mangling (depends on there being no CSE)
  94      ufg = calcUnfoldingGuidance inline_prag opt_UnfoldingCreationThreshold expr
  95      occ = occurAnalyseGlobalExpr expr
  96      cuf = CoreUnfolding (SimpleUnfolding (mkFormSummary expr) ufg occ)
  97
  98      cont = case occ of { Var _ -> cuf; _ -> cuf }
  99     in
 100     case ufg of { UnfoldAlways -> cont; _ -> cont }
 101
 102 mkMagicUnfolding :: Unique -> Unfolding
 103 mkMagicUnfolding tag  = MagicUnfolding tag (mkMagicUnfoldingFun tag)
 104
 105 getUnfoldingTemplate :: Unfolding -> CoreExpr
 106 getUnfoldingTemplate (CoreUnfolding (SimpleUnfolding _ _ expr))
 107   = unTagBinders expr
 108 getUnfoldingTemplate other = panic "getUnfoldingTemplate"
 109
 110
 111 data UnfoldingGuidance
 112   = UnfoldNever
 113   | UnfoldAlways                -- There is no "original" definition,
 114                                 -- so you'd better unfold.  Or: something
 115                                 -- so cheap to unfold (e.g., 1#) that
 116                                 -- you should do it absolutely always.
 117
 118   | UnfoldIfGoodArgs    Int     -- if "m" type args
 119                         Int     -- and "n" value args
 120
 121                         [Int]   -- Discount if the argument is evaluated.
 122                                 -- (i.e., a simplification will definitely
 123                                 -- be possible).  One elt of the list per *value* arg.
 124
 125                         Int     -- The "size" of the unfolding; to be elaborated
 126                                 -- later. ToDo
 127
 128                         Int     -- Scrutinee discount: the discount to substract if the thing is in
 129                                 -- a context (case (thing args) of ...),
 130                                 -- (where there are the right number of arguments.)
 131 \end{code}
 132
 133 \begin{code}
 134 instance Outputable UnfoldingGuidance where
 135     ppr UnfoldAlways            = ptext SLIT("_ALWAYS_")
 136     ppr (UnfoldIfGoodArgs t v cs size discount)
 137       = hsep [ptext SLIT("_IF_ARGS_"), int t, int v,
 138                if null cs       -- always print *something*
 139                 then char 'X'
 140                 else hcat (map (text . show) cs),
 141                int size,
 142                int discount ]
 143 \end{code}
 144
 145
 146 %************************************************************************
 147 %*                                                                      *
 148 \subsection{Figuring out things about expressions}
 149 %*                                                                      *
 150 %************************************************************************
 151
 152 \begin{code}
 153 data FormSummary
 154   = VarForm             -- Expression is a variable (or scc var, etc)
 155   | ValueForm           -- Expression is a value: i.e. a value-lambda,constructor, or literal
 156   | BottomForm          -- Expression is guaranteed to be bottom. We're more gung
 157                         -- ho about inlining such things, because it can't waste work
 158   | OtherForm           -- Anything else
 159
 160 instance Outputable FormSummary where
 161    ppr VarForm    = ptext SLIT("Var")
 162    ppr ValueForm  = ptext SLIT("Value")
 163    ppr BottomForm = ptext SLIT("Bot")
 164    ppr OtherForm  = ptext SLIT("Other")
 165
 166 mkFormSummary ::GenCoreExpr bndr Id flexi -> FormSummary
 167
 168 mkFormSummary expr
 169   = go (0::Int) expr            -- The "n" is the number of (value) arguments so far
 170   where
 171     go n (Lit _)        = ASSERT(n==0) ValueForm
 172     go n (Con _ _)      = ASSERT(n==0) ValueForm
 173     go n (Prim _ _)     = OtherForm
 174     go n (SCC _ e)      = go n e
 175     go n (Coerce _ _ e) = go n e
 176
 177     go n (Let (NonRec b r) e) | exprIsTrivial r = go n e        -- let f = f' alpha in (f,g)
 178                                                                 -- should be treated as a value
 179     go n (Let _ e)      = OtherForm
 180     go n (Case _ _)     = OtherForm
 181
 182     go 0 (Lam (ValBinder x) e) = ValueForm      -- NB: \x.bottom /= bottom!
 183     go n (Lam (ValBinder x) e) = go (n-1) e     -- Applied lambda
 184     go n (Lam other_binder e)  = go n e
 185
 186     go n (App fun arg) | isValArg arg = go (n+1) fun
 187     go n (App fun other_arg)          = go n fun
 188
 189     go n (Var f) | isBottomingId f = BottomForm
 190                  | isDataCon f     = ValueForm          -- Can happen inside imported unfoldings
 191     go 0 (Var f)                   = VarForm
 192     go n (Var f)                   = case getIdArity f of
 193                                           ArityExactly a | n < a -> ValueForm
 194                                           ArityAtLeast a | n < a -> ValueForm
 195                                           other                  -> OtherForm
 196
 197 whnfOrBottom :: FormSummary -> Bool
 198 whnfOrBottom VarForm    = True
 199 whnfOrBottom ValueForm  = True
 200 whnfOrBottom BottomForm = True
 201 whnfOrBottom OtherForm  = False
 202 \end{code}
 203
 204 @exprIsTrivial@ is true of expressions we are unconditionally happy to duplicate;
 205 simple variables and constants, and type applications.
 206
 207 \begin{code}
 208 exprIsTrivial (Var v)           = True
 209 exprIsTrivial (Lit lit)         = not (isNoRepLit lit)
 210 exprIsTrivial (App e (TyArg _)) = exprIsTrivial e
 211 exprIsTrivial (Coerce _ _ e)    = exprIsTrivial e
 212 exprIsTrivial other             = False
 213 \end{code}
 214
 215 \begin{code}
 216 exprSmallEnoughToDup (Con _ _)      = True      -- Could check # of args
 217 exprSmallEnoughToDup (Prim op _)    = not (fragilePrimOp op) -- Could check # of args
 218 exprSmallEnoughToDup (Lit lit)      = not (isNoRepLit lit)
 219 exprSmallEnoughToDup (Coerce _ _ e) = exprSmallEnoughToDup e
 220 exprSmallEnoughToDup expr
 221   = case (collectArgs expr) of { (fun, _, vargs) ->
 222     case fun of
 223       Var v | length vargs <= 4 -> True
 224       _                         -> False
 225     }
 226
 227 \end{code}
 228
 229
 230 %************************************************************************
 231 %*                                                                      *
 232 \subsection[calcUnfoldingGuidance]{Calculate ``unfolding guidance'' for an expression}
 233 %*                                                                      *
 234 %************************************************************************
 235
 236 \begin{code}
 237 calcUnfoldingGuidance
 238         :: PragmaInfo           -- INLINE pragma stuff
 239         -> Int                  -- bomb out if size gets bigger than this
 240         -> CoreExpr             -- expression to look at
 241         -> UnfoldingGuidance
 242
 243 calcUnfoldingGuidance IMustBeINLINEd    bOMB_OUT_SIZE expr = UnfoldAlways       -- Always inline if the INLINE pragma says so
 244 calcUnfoldingGuidance IWantToBeINLINEd  bOMB_OUT_SIZE expr = UnfoldAlways       -- Always inline if the INLINE pragma says so
 245 calcUnfoldingGuidance IMustNotBeINLINEd bOMB_OUT_SIZE expr = UnfoldNever        -- ...and vice versa...
 246
 247 calcUnfoldingGuidance NoPragmaInfo bOMB_OUT_SIZE expr
 248   = case collectBinders expr of { (ty_binders, val_binders, body) ->
 249     case (sizeExpr bOMB_OUT_SIZE val_binders body) of
 250
 251       TooBig -> UnfoldNever
 252
 253       SizeIs size cased_args scrut_discount
 254         -> UnfoldIfGoodArgs
 255                         (length ty_binders)
 256                         (length val_binders)
 257                         (map discount_for val_binders)
 258                         (I# size)
 259                         (I# scrut_discount)
 260         where
 261             discount_for b
 262                  | is_data && b `is_elem` cased_args = tyConFamilySize tycon
 263                  | otherwise = 0
 264                  where
 265                    (is_data, tycon)
 266                      = case (splitAlgTyConApp_maybe (idType b)) of
 267                           Nothing       -> (False, panic "discount")
 268                           Just (tc,_,_) -> (True,  tc)
 269
 270             is_elem = isIn "calcUnfoldingGuidance" }
 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 (Var v)                    = sizeZero
 284     size_up (Lit lit) | isNoRepLit lit = sizeN uNFOLDING_NOREP_LIT_COST
 285                       | otherwise      = sizeZero
 286
 287     size_up (SCC lbl body)    = size_up body            -- SCCs cost nothing
 288     size_up (Coerce _ _ body) = size_up body            -- Coercions cost nothing
 289
 290     size_up (App fun arg)  = size_up fun `addSize` size_up_arg arg
 291                                 -- NB Zero cost for for type applications;
 292                                 -- others cost 1 or more
 293
 294     size_up (Con con args) = conSizeN (numValArgs args)
 295                              -- We don't count 1 for the constructor because we're
 296                              -- quite keen to get constructors into the open
 297
 298     size_up (Prim op args) = sizeN op_cost -- NB: no charge for PrimOp args
 299       where
 300         op_cost = if primOpCanTriggerGC op
 301                   then uNFOLDING_DEAR_OP_COST
 302                         -- these *tend* to be more expensive;
 303                         -- number chosen to avoid unfolding (HACK)
 304                   else uNFOLDING_CHEAP_OP_COST
 305
 306     size_up expr@(Lam _ _)
 307       = let
 308             (tyvars, args, body) = collectBinders expr
 309         in
 310         size_up body `addSizeN` length args
 311
 312     size_up (Let (NonRec binder rhs) body)
 313       = nukeScrutDiscount (size_up rhs)
 314                 `addSize`
 315         size_up body
 316
 317     size_up (Let (Rec pairs) body)
 318       = nukeScrutDiscount (foldr addSize sizeZero [size_up rhs | (_,rhs) <- pairs])
 319                 `addSize`
 320         size_up body
 321
 322     size_up (Case scrut alts)
 323       = nukeScrutDiscount (size_up scrut)
 324                 `addSize`
 325         arg_discount scrut
 326                 `addSize`
 327         size_up_alts (coreExprType scrut) alts
 328             -- We charge for the "case" itself in "size_up_alts"
 329
 330     ------------
 331         -- In an application we charge  0 for type application
 332         --                              1 for most anything else
 333         --                              N for norep_lits
 334     size_up_arg (LitArg lit) | isNoRepLit lit = sizeN uNFOLDING_NOREP_LIT_COST
 335     size_up_arg (TyArg _)                     = sizeZero
 336     size_up_arg other                         = sizeOne
 337
 338     ------------
 339     size_up_alts scrut_ty (AlgAlts alts deflt)
 340       = (foldr (addSize . size_alg_alt) (size_up_deflt deflt) alts)
 341         `addSizeN`
 342         alt_cost
 343       where
 344         size_alg_alt (con,args,rhs) = size_up rhs
 345             -- Don't charge for args, so that wrappers look cheap
 346
 347         -- NB: we charge N for an alg. "case", where N is
 348         -- the number of constructors in the thing being eval'd.
 349         -- (You'll eventually get a "discount" of N if you
 350         -- think the "case" is likely to go away.)
 351         -- It's important to charge for alternatives.  If you don't then you
 352         -- get size 1 for things like:
 353         --              case x of { A -> 1#; B -> 2#; ... lots }
 354
 355         alt_cost :: Int
 356         alt_cost
 357           = case (splitAlgTyConApp_maybe scrut_ty) of
 358               Nothing       -> 1
 359               Just (tc,_,_) -> tyConFamilySize tc
 360
 361     size_up_alts _ (PrimAlts alts deflt)
 362       = foldr (addSize . size_prim_alt) (size_up_deflt deflt) alts
 363             -- *no charge* for a primitive "case"!
 364       where
 365         size_prim_alt (lit,rhs) = size_up rhs
 366
 367     ------------
 368     size_up_deflt NoDefault                = sizeZero
 369     size_up_deflt (BindDefault binder rhs) = size_up rhs
 370
 371     ------------
 372         -- We want to record if we're case'ing an argument
 373     arg_discount (Var v) | v `is_elem` args = scrutArg v
 374     arg_discount other                      = sizeZero
 375
 376     is_elem :: Id -> [Id] -> Bool
 377     is_elem = isIn "size_up_scrut"
 378
 379     ------------
 380         -- These addSize things have to be here because
 381         -- I don't want to give them bOMB_OUT_SIZE as an argument
 382
 383     addSizeN TooBig          _ = TooBig
 384     addSizeN (SizeIs n xs d) (I# m)
 385       | n_tot -# d <# bOMB_OUT_SIZE = SizeIs n_tot xs d
 386       | otherwise                   = TooBig
 387       where
 388         n_tot = n +# m
 389
 390     addSize TooBig _ = TooBig
 391     addSize _ TooBig = TooBig
 392     addSize (SizeIs n1 xs d1) (SizeIs n2 ys d2)
 393       | (n_tot -# d_tot) <# bOMB_OUT_SIZE = SizeIs n_tot xys d_tot
 394       | otherwise                         = TooBig
 395       where
 396         n_tot = n1 +# n2
 397         d_tot = d1 +# d2
 398         xys   = xs ++ ys
 399
 400
 401 \end{code}
 402
 403 Code for manipulating sizes
 404
 405 \begin{code}
 406
 407 data ExprSize = TooBig
 408               | SizeIs Int#     -- Size found
 409                        [Id]     -- Arguments cased herein
 410                        Int#     -- Size to subtract if result is scrutinised
 411                                 -- by a case expression
 412
 413 sizeZero        = SizeIs 0# [] 0#
 414 sizeOne         = SizeIs 1# [] 0#
 415 sizeN (I# n)    = SizeIs n  [] 0#
 416 conSizeN (I# n) = SizeIs n  [] n
 417 scrutArg v      = SizeIs 0# [v] 0#
 418
 419 nukeScrutDiscount (SizeIs n vs d) = SizeIs n vs 0#
 420 nukeScrutDiscount TooBig          = TooBig
 421 \end{code}
 422
 423 %************************************************************************
 424 %*                                                                      *
 425 \subsection[considerUnfolding]{Given all the info, do (not) do the unfolding}
 426 %*                                                                      *
 427 %************************************************************************
 428
 429 We have very limited information about an unfolding expression: (1)~so
 430 many type arguments and so many value arguments expected---for our
 431 purposes here, we assume we've got those.  (2)~A ``size'' or ``cost,''
 432 a single integer.  (3)~An ``argument info'' vector.  For this, what we
 433 have at the moment is a Boolean per argument position that says, ``I
 434 will look with great favour on an explicit constructor in this
 435 position.'' (4)~The ``discount'' to subtract if the expression
 436 is being scrutinised.
 437
 438 Assuming we have enough type- and value arguments (if not, we give up
 439 immediately), then we see if the ``discounted size'' is below some
 440 (semi-arbitrary) threshold.  It works like this: for every argument
 441 position where we're looking for a constructor AND WE HAVE ONE in our
 442 hands, we get a (again, semi-arbitrary) discount [proportion to the
 443 number of constructors in the type being scrutinized].
 444
 445 If we're in the context of a scrutinee ( \tr{(case <expr > of A .. -> ...;.. )})
 446 and the expression in question will evaluate to a constructor, we use
 447 the computed discount size *for the result only* rather than
 448 computing the argument discounts. Since we know the result of
 449 the expression is going to be taken apart, discounting its size
 450 is more accurate (see @sizeExpr@ above for how this discount size
 451 is computed).
 452
 453 \begin{code}
 454 smallEnoughToInline :: [Bool]                   -- Evaluated-ness of value arguments
 455                     -> Bool                     -- Result is scrutinised
 456                     -> UnfoldingGuidance
 457                     -> Bool                     -- True => unfold it
 458
 459 smallEnoughToInline _ _ UnfoldAlways = True
 460 smallEnoughToInline _ _ UnfoldNever  = False
 461 smallEnoughToInline arg_is_evald_s result_is_scruted
 462               (UnfoldIfGoodArgs m_tys_wanted n_vals_wanted discount_vec size scrut_discount)
 463   = if enough_args n_vals_wanted arg_is_evald_s &&
 464        size - discount <= opt_UnfoldingUseThreshold
 465     then
 466        pprTrace "small enough" (int size <+> int discount) True
 467     else
 468        False
 469   where
 470
 471     enough_args n [] | n > 0 = False    -- A function with no value args => don't unfold
 472     enough_args _ _          = True     -- Otherwise it's ok to try
 473
 474         -- We multiple the raw discounts (args_discount and result_discount)
 475         -- ty opt_UnfoldingKeenessFactor because the former have to do with
 476         -- *size* whereas the discounts imply that there's some extra *efficiency*
 477         -- to be gained (e.g. beta reductions, case reductions) by inlining.
 478     discount :: Int
 479     discount = round (
 480                       opt_UnfoldingKeenessFactor *
 481                       fromInt (args_discount + result_discount)
 482                      )
 483
 484     args_discount = sum (zipWith arg_discount discount_vec arg_is_evald_s)
 485     result_discount | result_is_scruted = scrut_discount
 486                     | otherwise         = 0
 487
 488     arg_discount no_of_constrs is_evald
 489       | is_evald  = 1 + no_of_constrs * opt_UnfoldingConDiscount
 490       | otherwise = 1
 491 \end{code}
 492
 493 We use this one to avoid exporting inlinings that we ``couldn't possibly
 494 use'' on the other side.  Can be overridden w/ flaggery.
 495 Just the same as smallEnoughToInline, except that it has no actual arguments.
 496
 497 \begin{code}
 498 --UNUSED?
 499 couldBeSmallEnoughToInline :: UnfoldingGuidance -> Bool
 500 couldBeSmallEnoughToInline guidance = smallEnoughToInline (repeat True) True guidance
 501
 502 certainlySmallEnoughToInline :: UnfoldingGuidance -> Bool
 503 certainlySmallEnoughToInline guidance = smallEnoughToInline (repeat False) False guidance
 504 \end{code}
 505
 506 Predicates
 507 ~~~~~~~~~~
 508
 509 @inlineUnconditionally@ decides whether a let-bound thing can
 510 *definitely* be inlined at each of its call sites.  If so, then
 511 we can drop the binding right away.  But remember, you have to be
 512 certain that every use can be inlined.  So, notably, any ArgOccs
 513 rule this out.  Since ManyOcc doesn't record FunOcc/ArgOcc
 514
 515 \begin{code}
 516 inlineUnconditionally :: Bool -> Id -> BinderInfo -> Bool
 517
 518 inlineUnconditionally ok_to_dup id occ_info
 519   |  idMustNotBeINLINEd id = False
 520
 521   |  isOneFunOcc occ_info
 522   && idMustBeINLINEd id = True
 523
 524   |  isOneSafeFunOcc (ok_to_dup || idWantsToBeINLINEd id) occ_info
 525   =  True
 526
 527   |  otherwise
 528   = False
 529 \end{code}