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                 `addSizeN`
 317         1       -- For the allocation
 318
 319     size_up (Let (Rec pairs) body)
 320       = nukeScrutDiscount (foldr addSize sizeZero [size_up rhs | (_,rhs) <- pairs])
 321                 `addSize`
 322         size_up body
 323                 `addSizeN`
 324         length pairs    -- For the allocation
 325
 326     size_up (Case scrut alts)
 327       = nukeScrutDiscount (size_up scrut)
 328                 `addSize`
 329         arg_discount scrut
 330                 `addSize`
 331         size_up_alts (coreExprType scrut) alts
 332             -- We charge for the "case" itself in "size_up_alts"
 333
 334     ------------
 335         -- In an application we charge  0 for type application
 336         --                              1 for most anything else
 337         --                              N for norep_lits
 338     size_up_arg (LitArg lit) | isNoRepLit lit = sizeN uNFOLDING_NOREP_LIT_COST
 339     size_up_arg (TyArg _)                     = sizeZero
 340     size_up_arg other                         = sizeOne
 341
 342     ------------
 343     size_up_alts scrut_ty (AlgAlts alts deflt)
 344       = (foldr (addSize . size_alg_alt) (size_up_deflt deflt) alts)
 345         `addSizeN`
 346         alt_cost
 347       where
 348         size_alg_alt (con,args,rhs) = size_up rhs
 349             -- Don't charge for args, so that wrappers look cheap
 350
 351         -- NB: we charge N for an alg. "case", where N is
 352         -- the number of constructors in the thing being eval'd.
 353         -- (You'll eventually get a "discount" of N if you
 354         -- think the "case" is likely to go away.)
 355         -- It's important to charge for alternatives.  If you don't then you
 356         -- get size 1 for things like:
 357         --              case x of { A -> 1#; B -> 2#; ... lots }
 358
 359         alt_cost :: Int
 360         alt_cost
 361           = case (splitAlgTyConApp_maybe scrut_ty) of
 362               Nothing       -> 1
 363               Just (tc,_,_) -> tyConFamilySize tc
 364
 365     size_up_alts _ (PrimAlts alts deflt)
 366       = foldr (addSize . size_prim_alt) (size_up_deflt deflt) alts
 367             -- *no charge* for a primitive "case"!
 368       where
 369         size_prim_alt (lit,rhs) = size_up rhs
 370
 371     ------------
 372     size_up_deflt NoDefault                = sizeZero
 373     size_up_deflt (BindDefault binder rhs) = size_up rhs
 374
 375     ------------
 376         -- We want to record if we're case'ing an argument
 377     arg_discount (Var v) | v `is_elem` args = scrutArg v
 378     arg_discount other                      = sizeZero
 379
 380     is_elem :: Id -> [Id] -> Bool
 381     is_elem = isIn "size_up_scrut"
 382
 383     ------------
 384         -- These addSize things have to be here because
 385         -- I don't want to give them bOMB_OUT_SIZE as an argument
 386
 387     addSizeN TooBig          _ = TooBig
 388     addSizeN (SizeIs n xs d) (I# m)
 389       | n_tot -# d <# bOMB_OUT_SIZE = SizeIs n_tot xs d
 390       | otherwise                   = TooBig
 391       where
 392         n_tot = n +# m
 393
 394     addSize TooBig _ = TooBig
 395     addSize _ TooBig = TooBig
 396     addSize (SizeIs n1 xs d1) (SizeIs n2 ys d2)
 397       | (n_tot -# d_tot) <# bOMB_OUT_SIZE = SizeIs n_tot xys d_tot
 398       | otherwise                         = TooBig
 399       where
 400         n_tot = n1 +# n2
 401         d_tot = d1 +# d2
 402         xys   = xs ++ ys
 403
 404
 405 \end{code}
 406
 407 Code for manipulating sizes
 408
 409 \begin{code}
 410
 411 data ExprSize = TooBig
 412               | SizeIs Int#     -- Size found
 413                        [Id]     -- Arguments cased herein
 414                        Int#     -- Size to subtract if result is scrutinised
 415                                 -- by a case expression
 416
 417 sizeZero        = SizeIs 0# [] 0#
 418 sizeOne         = SizeIs 1# [] 0#
 419 sizeN (I# n)    = SizeIs n  [] 0#
 420 conSizeN (I# n) = SizeIs n  [] n
 421 scrutArg v      = SizeIs 0# [v] 0#
 422
 423 nukeScrutDiscount (SizeIs n vs d) = SizeIs n vs 0#
 424 nukeScrutDiscount TooBig          = TooBig
 425 \end{code}
 426
 427 %************************************************************************
 428 %*                                                                      *
 429 \subsection[considerUnfolding]{Given all the info, do (not) do the unfolding}
 430 %*                                                                      *
 431 %************************************************************************
 432
 433 We have very limited information about an unfolding expression: (1)~so
 434 many type arguments and so many value arguments expected---for our
 435 purposes here, we assume we've got those.  (2)~A ``size'' or ``cost,''
 436 a single integer.  (3)~An ``argument info'' vector.  For this, what we
 437 have at the moment is a Boolean per argument position that says, ``I
 438 will look with great favour on an explicit constructor in this
 439 position.'' (4)~The ``discount'' to subtract if the expression
 440 is being scrutinised.
 441
 442 Assuming we have enough type- and value arguments (if not, we give up
 443 immediately), then we see if the ``discounted size'' is below some
 444 (semi-arbitrary) threshold.  It works like this: for every argument
 445 position where we're looking for a constructor AND WE HAVE ONE in our
 446 hands, we get a (again, semi-arbitrary) discount [proportion to the
 447 number of constructors in the type being scrutinized].
 448
 449 If we're in the context of a scrutinee ( \tr{(case <expr > of A .. -> ...;.. )})
 450 and the expression in question will evaluate to a constructor, we use
 451 the computed discount size *for the result only* rather than
 452 computing the argument discounts. Since we know the result of
 453 the expression is going to be taken apart, discounting its size
 454 is more accurate (see @sizeExpr@ above for how this discount size
 455 is computed).
 456
 457 \begin{code}
 458 smallEnoughToInline :: Id                       -- The function (for trace msg only)
 459                     -> [Bool]                   -- Evaluated-ness of value arguments
 460                     -> Bool                     -- Result is scrutinised
 461                     -> UnfoldingGuidance
 462                     -> Bool                     -- True => unfold it
 463
 464 smallEnoughToInline _ _ _ UnfoldAlways = True
 465 smallEnoughToInline _ _ _ UnfoldNever  = False
 466 smallEnoughToInline id arg_is_evald_s result_is_scruted
 467               (UnfoldIfGoodArgs m_tys_wanted n_vals_wanted discount_vec size scrut_discount)
 468   = if enough_args n_vals_wanted arg_is_evald_s &&
 469        size - discount <= opt_UnfoldingUseThreshold
 470     then
 471        -- pprTrace "small enough" (ppr id <+> int size <+> int discount)
 472        True
 473     else
 474        False
 475   where
 476
 477     enough_args n [] | n > 0 = False    -- A function with no value args => don't unfold
 478     enough_args _ _          = True     -- Otherwise it's ok to try
 479
 480         -- We multiple the raw discounts (args_discount and result_discount)
 481         -- ty opt_UnfoldingKeenessFactor because the former have to do with
 482         -- *size* whereas the discounts imply that there's some extra *efficiency*
 483         -- to be gained (e.g. beta reductions, case reductions) by inlining.
 484     discount :: Int
 485     discount = round (
 486                       opt_UnfoldingKeenessFactor *
 487                       fromInt (args_discount + result_discount)
 488                      )
 489
 490     args_discount = sum (zipWith arg_discount discount_vec arg_is_evald_s)
 491     result_discount | result_is_scruted = scrut_discount
 492                     | otherwise         = 0
 493
 494     arg_discount no_of_constrs is_evald
 495       | is_evald  = no_of_constrs * opt_UnfoldingConDiscount
 496       | otherwise = 0
 497 \end{code}
 498
 499 We use this one to avoid exporting inlinings that we ``couldn't possibly
 500 use'' on the other side.  Can be overridden w/ flaggery.
 501 Just the same as smallEnoughToInline, except that it has no actual arguments.
 502
 503 \begin{code}
 504 couldBeSmallEnoughToInline :: Id -> UnfoldingGuidance -> Bool
 505 couldBeSmallEnoughToInline id guidance = smallEnoughToInline id (repeat True) True guidance
 506
 507 certainlySmallEnoughToInline :: Id -> UnfoldingGuidance -> Bool
 508 certainlySmallEnoughToInline id guidance = smallEnoughToInline id (repeat False) False guidance
 509 \end{code}
 510
 511 Predicates
 512 ~~~~~~~~~~
 513
 514 @inlineUnconditionally@ decides whether a let-bound thing can
 515 *definitely* be inlined at each of its call sites.  If so, then
 516 we can drop the binding right away.  But remember, you have to be
 517 certain that every use can be inlined.  So, notably, any ArgOccs
 518 rule this out.  Since ManyOcc doesn't record FunOcc/ArgOcc
 519
 520 \begin{code}
 521 inlineUnconditionally :: Bool -> Id -> BinderInfo -> Bool
 522
 523 inlineUnconditionally ok_to_dup id occ_info
 524   |  idMustNotBeINLINEd id = False
 525
 526   |  isOneFunOcc occ_info
 527   && idMustBeINLINEd id = True
 528
 529   |  isOneSafeFunOcc (ok_to_dup || idWantsToBeINLINEd id) occ_info
 530   =  True
 531
 532   |  otherwise
 533   = False
 534 \end{code}