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