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