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