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