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