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 @CoreUnfolding@ unfolding, you will
  13 find, unsurprisingly, a Core expression.
  14
  15 \begin{code}
  16 module CoreUnfold (
  17         Unfolding(..), UnfoldingGuidance(..), -- types
  18
  19         FormSummary(..), mkFormSummary, whnfOrBottom, exprSmallEnoughToDup,
  20         exprIsTrivial,
  21
  22         noUnfolding, mkMagicUnfolding, mkUnfolding, getUnfoldingTemplate,
  23
  24         smallEnoughToInline, couldBeSmallEnoughToInline,
  25         certainlySmallEnoughToInline, inlineUnconditionally, okToInline,
  26
  27         calcUnfoldingGuidance
  28     ) where
  29
  30 #include "HsVersions.h"
  31
  32 import {-# SOURCE #-} MagicUFs  ( MagicUnfoldingFun, mkMagicUnfoldingFun )
  33
  34 import CmdLineOpts      ( opt_UnfoldingCreationThreshold,
  35                           opt_UnfoldingUseThreshold,
  36                           opt_UnfoldingConDiscount,
  37                           opt_UnfoldingKeenessFactor
  38                         )
  39 import Constants        ( uNFOLDING_CHEAP_OP_COST,
  40                           uNFOLDING_DEAR_OP_COST,
  41                           uNFOLDING_NOREP_LIT_COST
  42                         )
  43 import BinderInfo       ( BinderInfo, isOneSameSCCFunOcc, isDeadOcc,
  44                           isInlinableOcc, isOneSafeFunOcc
  45                         )
  46 import CoreSyn
  47 import Literal          ( Literal )
  48 import CoreUtils        ( unTagBinders )
  49 import OccurAnal        ( occurAnalyseGlobalExpr )
  50 import CoreUtils        ( coreExprType )
  51 import Id               ( Id, idType, getIdArity,  isBottomingId, isDataCon,
  52                           idWantsToBeINLINEd, idMustBeINLINEd, idMustNotBeINLINEd,
  53                           IdSet )
  54 import PrimOp           ( fragilePrimOp, primOpCanTriggerGC )
  55 import IdInfo           ( ArityInfo(..), InlinePragInfo(..) )
  56 import Name             ( isExported )
  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   | OtherLit [Literal]          -- It ain't one of these
  76   | OtherCon [Id]               -- It ain't one of these
  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                 SimplifiableCoreExpr    -- Template
  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      cuf = CoreUnfolding (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 _ _ 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 (Note _ e)     = go n e
 175
 176     go n (Let (NonRec b r) e) | exprIsTrivial r = go n e        -- let f = f' alpha in (f,g)
 177                                                                 -- should be treated as a value
 178     go n (Let _ e)      = OtherForm
 179     go n (Case _ _)     = OtherForm
 180
 181     go 0 (Lam (ValBinder x) e) = ValueForm      -- NB: \x.bottom /= bottom!
 182     go n (Lam (ValBinder x) e) = go (n-1) e     -- Applied lambda
 183     go n (Lam other_binder e)  = go n e
 184
 185     go n (App fun arg) | isValArg arg = go (n+1) fun
 186     go n (App fun other_arg)          = go n fun
 187
 188     go n (Var f) | isBottomingId f = BottomForm
 189                  | isDataCon f     = ValueForm          -- Can happen inside imported unfoldings
 190     go 0 (Var f)                   = VarForm
 191     go n (Var f)                   = case getIdArity f of
 192                                           ArityExactly a | n < a -> ValueForm
 193                                           ArityAtLeast a | n < a -> ValueForm
 194                                           other                  -> OtherForm
 195
 196 whnfOrBottom :: FormSummary -> Bool
 197 whnfOrBottom VarForm    = True
 198 whnfOrBottom ValueForm  = True
 199 whnfOrBottom BottomForm = True
 200 whnfOrBottom OtherForm  = False
 201 \end{code}
 202
 203 @exprIsTrivial@ is true of expressions we are unconditionally happy to duplicate;
 204 simple variables and constants, and type applications.
 205
 206 \begin{code}
 207 exprIsTrivial (Var v)           = True
 208 exprIsTrivial (Lit lit)         = not (isNoRepLit lit)
 209 exprIsTrivial (App e (TyArg _)) = exprIsTrivial e
 210 exprIsTrivial (Note _ e)        = exprIsTrivial e
 211 exprIsTrivial other             = False
 212 \end{code}
 213
 214 \begin{code}
 215 exprSmallEnoughToDup (Con _ _)      = True      -- Could check # of args
 216 exprSmallEnoughToDup (Prim op _)    = not (fragilePrimOp op) -- Could check # of args
 217 exprSmallEnoughToDup (Lit lit)      = not (isNoRepLit lit)
 218 exprSmallEnoughToDup (Note _ e)     = exprSmallEnoughToDup e
 219 exprSmallEnoughToDup expr
 220   = case (collectArgs expr) of { (fun, _, vargs) ->
 221     case fun of
 222       Var v | length vargs <= 4 -> True
 223       _                         -> False
 224     }
 225
 226 \end{code}
 227
 228
 229 %************************************************************************
 230 %*                                                                      *
 231 \subsection[calcUnfoldingGuidance]{Calculate ``unfolding guidance'' for an expression}
 232 %*                                                                      *
 233 %************************************************************************
 234
 235 \begin{code}
 236 calcUnfoldingGuidance
 237         :: Int                  -- bomb out if size gets bigger than this
 238         -> CoreExpr             -- expression to look at
 239         -> UnfoldingGuidance
 240
 241 calcUnfoldingGuidance bOMB_OUT_SIZE expr
 242   = case collectBinders expr of { (ty_binders, val_binders, body) ->
 243     case (sizeExpr bOMB_OUT_SIZE val_binders body) of
 244
 245       TooBig -> UnfoldNever
 246
 247       SizeIs size cased_args scrut_discount
 248         -> UnfoldIfGoodArgs
 249                         (length ty_binders)
 250                         (length val_binders)
 251                         (map discount_for val_binders)
 252                         (I# size)
 253                         (I# scrut_discount)
 254         where
 255             discount_for b
 256                  | is_data && b `is_elem` cased_args = tyConFamilySize tycon
 257                  | otherwise = 0
 258                  where
 259                    (is_data, tycon)
 260                      = case (splitAlgTyConApp_maybe (idType b)) of
 261                           Nothing       -> (False, panic "discount")
 262                           Just (tc,_,_) -> (True,  tc)
 263
 264             is_elem = isIn "calcUnfoldingGuidance" }
 265 \end{code}
 266
 267 \begin{code}
 268 sizeExpr :: Int             -- Bomb out if it gets bigger than this
 269          -> [Id]            -- Arguments; we're interested in which of these
 270                             -- get case'd
 271          -> CoreExpr
 272          -> ExprSize
 273
 274 sizeExpr (I# bOMB_OUT_SIZE) args expr
 275   = size_up expr
 276   where
 277     size_up (Var v)                    = sizeZero
 278     size_up (Lit lit) | isNoRepLit lit = sizeN uNFOLDING_NOREP_LIT_COST
 279                       | otherwise      = sizeZero
 280
 281     size_up (Note _ body)  = size_up body               -- Notes cost nothing
 282
 283     size_up (App fun arg)  = size_up fun `addSize` size_up_arg arg
 284                                 -- NB Zero cost for for type applications;
 285                                 -- others cost 1 or more
 286
 287     size_up (Con con args) = conSizeN (numValArgs args)
 288                              -- We don't count 1 for the constructor because we're
 289                              -- quite keen to get constructors into the open
 290
 291     size_up (Prim op args) = sizeN op_cost -- NB: no charge for PrimOp args
 292       where
 293         op_cost = if primOpCanTriggerGC op
 294                   then uNFOLDING_DEAR_OP_COST
 295                         -- these *tend* to be more expensive;
 296                         -- number chosen to avoid unfolding (HACK)
 297                   else uNFOLDING_CHEAP_OP_COST
 298
 299     size_up expr@(Lam _ _)
 300       = let
 301             (tyvars, args, body) = collectBinders expr
 302         in
 303         size_up body `addSizeN` length args
 304
 305     size_up (Let (NonRec binder rhs) body)
 306       = nukeScrutDiscount (size_up rhs)
 307                 `addSize`
 308         size_up body
 309                 `addSizeN`
 310         1       -- For the allocation
 311
 312     size_up (Let (Rec pairs) body)
 313       = nukeScrutDiscount (foldr addSize sizeZero [size_up rhs | (_,rhs) <- pairs])
 314                 `addSize`
 315         size_up body
 316                 `addSizeN`
 317         length pairs    -- For the allocation
 318
 319     size_up (Case scrut alts)
 320       = nukeScrutDiscount (size_up scrut)
 321                 `addSize`
 322         arg_discount scrut
 323                 `addSize`
 324         size_up_alts (coreExprType scrut) alts
 325             -- We charge for the "case" itself in "size_up_alts"
 326
 327     ------------
 328         -- In an application we charge  0 for type application
 329         --                              1 for most anything else
 330         --                              N for norep_lits
 331     size_up_arg (LitArg lit) | isNoRepLit lit = sizeN uNFOLDING_NOREP_LIT_COST
 332     size_up_arg (TyArg _)                     = sizeZero
 333     size_up_arg other                         = sizeOne
 334
 335     ------------
 336     size_up_alts scrut_ty (AlgAlts alts deflt)
 337       = (foldr (addSize . size_alg_alt) (size_up_deflt deflt) alts)
 338         `addSizeN`
 339         alt_cost
 340       where
 341         size_alg_alt (con,args,rhs) = size_up rhs
 342             -- Don't charge for args, so that wrappers look cheap
 343
 344         -- NB: we charge N for an alg. "case", where N is
 345         -- the number of constructors in the thing being eval'd.
 346         -- (You'll eventually get a "discount" of N if you
 347         -- think the "case" is likely to go away.)
 348         -- It's important to charge for alternatives.  If you don't then you
 349         -- get size 1 for things like:
 350         --              case x of { A -> 1#; B -> 2#; ... lots }
 351
 352         alt_cost :: Int
 353         alt_cost
 354           = case (splitAlgTyConApp_maybe scrut_ty) of
 355               Nothing       -> 1
 356               Just (tc,_,_) -> tyConFamilySize tc
 357
 358     size_up_alts _ (PrimAlts alts deflt)
 359       = foldr (addSize . size_prim_alt) (size_up_deflt deflt) alts
 360             -- *no charge* for a primitive "case"!
 361       where
 362         size_prim_alt (lit,rhs) = size_up rhs
 363
 364     ------------
 365     size_up_deflt NoDefault                = sizeZero
 366     size_up_deflt (BindDefault binder rhs) = size_up rhs
 367
 368     ------------
 369         -- We want to record if we're case'ing an argument
 370     arg_discount (Var v) | v `is_elem` args = scrutArg v
 371     arg_discount other                      = sizeZero
 372
 373     is_elem :: Id -> [Id] -> Bool
 374     is_elem = isIn "size_up_scrut"
 375
 376     ------------
 377         -- These addSize things have to be here because
 378         -- I don't want to give them bOMB_OUT_SIZE as an argument
 379
 380     addSizeN TooBig          _ = TooBig
 381     addSizeN (SizeIs n xs d) (I# m)
 382       | n_tot -# d <# bOMB_OUT_SIZE = SizeIs n_tot xs d
 383       | otherwise                   = TooBig
 384       where
 385         n_tot = n +# m
 386
 387     addSize TooBig _ = TooBig
 388     addSize _ TooBig = TooBig
 389     addSize (SizeIs n1 xs d1) (SizeIs n2 ys d2)
 390       | (n_tot -# d_tot) <# bOMB_OUT_SIZE = SizeIs n_tot xys d_tot
 391       | otherwise                         = TooBig
 392       where
 393         n_tot = n1 +# n2
 394         d_tot = d1 +# d2
 395         xys   = xs ++ ys
 396
 397
 398 \end{code}
 399
 400 Code for manipulating sizes
 401
 402 \begin{code}
 403
 404 data ExprSize = TooBig
 405               | SizeIs Int#     -- Size found
 406                        [Id]     -- Arguments cased herein
 407                        Int#     -- Size to subtract if result is scrutinised
 408                                 -- by a case expression
 409
 410 sizeZero        = SizeIs 0# [] 0#
 411 sizeOne         = SizeIs 1# [] 0#
 412 sizeN (I# n)    = SizeIs n  [] 0#
 413 conSizeN (I# n) = SizeIs n  [] n
 414 scrutArg v      = SizeIs 0# [v] 0#
 415
 416 nukeScrutDiscount (SizeIs n vs d) = SizeIs n vs 0#
 417 nukeScrutDiscount TooBig          = TooBig
 418 \end{code}
 419
 420 %************************************************************************
 421 %*                                                                      *
 422 \subsection[considerUnfolding]{Given all the info, do (not) do the unfolding}
 423 %*                                                                      *
 424 %************************************************************************
 425
 426 We have very limited information about an unfolding expression: (1)~so
 427 many type arguments and so many value arguments expected---for our
 428 purposes here, we assume we've got those.  (2)~A ``size'' or ``cost,''
 429 a single integer.  (3)~An ``argument info'' vector.  For this, what we
 430 have at the moment is a Boolean per argument position that says, ``I
 431 will look with great favour on an explicit constructor in this
 432 position.'' (4)~The ``discount'' to subtract if the expression
 433 is being scrutinised.
 434
 435 Assuming we have enough type- and value arguments (if not, we give up
 436 immediately), then we see if the ``discounted size'' is below some
 437 (semi-arbitrary) threshold.  It works like this: for every argument
 438 position where we're looking for a constructor AND WE HAVE ONE in our
 439 hands, we get a (again, semi-arbitrary) discount [proportion to the
 440 number of constructors in the type being scrutinized].
 441
 442 If we're in the context of a scrutinee ( \tr{(case <expr > of A .. -> ...;.. )})
 443 and the expression in question will evaluate to a constructor, we use
 444 the computed discount size *for the result only* rather than
 445 computing the argument discounts. Since we know the result of
 446 the expression is going to be taken apart, discounting its size
 447 is more accurate (see @sizeExpr@ above for how this discount size
 448 is computed).
 449
 450 \begin{code}
 451 smallEnoughToInline :: Id                       -- The function (trace msg only)
 452                     -> [Bool]                   -- Evaluated-ness of value arguments
 453                     -> Bool                     -- Result is scrutinised
 454                     -> UnfoldingGuidance
 455                     -> Bool                     -- True => unfold it
 456
 457 smallEnoughToInline _ _ _ UnfoldAlways = True
 458 smallEnoughToInline _ _ _ UnfoldNever  = False
 459 smallEnoughToInline id arg_is_evald_s result_is_scruted
 460               (UnfoldIfGoodArgs m_tys_wanted n_vals_wanted discount_vec size scrut_discount)
 461   = if enough_args n_vals_wanted arg_is_evald_s &&
 462        size - discount <= opt_UnfoldingUseThreshold
 463     then
 464        -- pprTrace "small enough" (ppr id <+> int size <+> int discount)
 465        True
 466     else
 467        False
 468   where
 469
 470     enough_args n [] | n > 0 = False    -- A function with no value args => don't unfold
 471     enough_args _ _          = True     -- Otherwise it's ok to try
 472
 473         -- We multiple the raw discounts (args_discount and result_discount)
 474         -- ty opt_UnfoldingKeenessFactor because the former have to do with
 475         -- *size* whereas the discounts imply that there's some extra *efficiency*
 476         -- to be gained (e.g. beta reductions, case reductions) by inlining.
 477     discount :: Int
 478     discount = round (
 479                       opt_UnfoldingKeenessFactor *
 480                       fromInt (args_discount + result_discount)
 481                      )
 482
 483     args_discount = sum (zipWith arg_discount discount_vec arg_is_evald_s)
 484     result_discount | result_is_scruted = scrut_discount
 485                     | otherwise         = 0
 486
 487     arg_discount no_of_constrs is_evald
 488       | is_evald  = no_of_constrs * opt_UnfoldingConDiscount
 489       | otherwise = 0
 490 \end{code}
 491
 492 We use this one to avoid exporting inlinings that we ``couldn't possibly
 493 use'' on the other side.  Can be overridden w/ flaggery.
 494 Just the same as smallEnoughToInline, except that it has no actual arguments.
 495
 496 \begin{code}
 497 couldBeSmallEnoughToInline :: Id -> UnfoldingGuidance -> Bool
 498 couldBeSmallEnoughToInline id guidance = smallEnoughToInline id (repeat True) True guidance
 499
 500 certainlySmallEnoughToInline :: Id -> UnfoldingGuidance -> Bool
 501 certainlySmallEnoughToInline id guidance = smallEnoughToInline id (repeat False) False guidance
 502 \end{code}
 503
 504 Predicates
 505 ~~~~~~~~~~
 506
 507 @inlineUnconditionally@ decides whether a let-bound thing can
 508 *definitely* be inlined at each of its call sites.  If so, then
 509 we can drop the binding right away.  But remember, you have to be
 510 certain that every use can be inlined.  So, notably, any ArgOccs
 511 rule this out.  Since ManyOcc doesn't record FunOcc/ArgOcc
 512
 513 \begin{code}
 514 inlineUnconditionally :: (Id,BinderInfo) -> Bool
 515
 516 inlineUnconditionally (id, occ_info)
 517   |  idMustNotBeINLINEd id
 518   || isExported id
 519   =  False
 520
 521   |  isOneSameSCCFunOcc occ_info
 522   && idWantsToBeINLINEd id = True
 523
 524   |  isOneSafeFunOcc occ_info
 525   =  True
 526
 527   |  otherwise
 528   = False
 529 \end{code}
 530
 531 okToInline is used at call sites, so it is a bit more generous
 532
 533 \begin{code}
 534 okToInline :: Id                -- The Id
 535            -> Bool              -- The thing is WHNF or bottom;
 536            -> Bool              -- It's small enough to duplicate the code
 537            -> BinderInfo
 538            -> Bool              -- True <=> inline it
 539
 540 okToInline id _ _ _             -- Check the Id first
 541   | idWantsToBeINLINEd id = True
 542   | idMustNotBeINLINEd id = False
 543
 544 okToInline id whnf small binder_info
 545 #ifdef DEBUG
 546   | isDeadOcc binder_info
 547   = pprTrace "okToInline: dead" (ppr id) False
 548   | otherwise
 549 #endif
 550   = isInlinableOcc whnf small binder_info
 551 \end{code}