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