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 #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 import {-# SOURCE #-} Id ( Id )
  43 #endif
  44
  45 import Bag              ( emptyBag, unitBag, unionBags, Bag )
  46
  47 import CmdLineOpts      ( opt_UnfoldingCreationThreshold,
  48                           opt_UnfoldingUseThreshold,
  49                           opt_UnfoldingConDiscount
  50                         )
  51 import Constants        ( uNFOLDING_CHEAP_OP_COST,
  52                           uNFOLDING_DEAR_OP_COST,
  53                           uNFOLDING_NOREP_LIT_COST
  54                         )
  55 import BinderInfo       ( BinderInfo(..), FunOrArg, DuplicationDanger, InsideSCC, isDupDanger )
  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               ( idType, getIdArity,  isBottomingId, isDataCon, isPrimitiveId_maybe,
  65                           SYN_IE(IdSet), GenId{-instances-} )
  66 import PrimOp           ( primOpCanTriggerGC, fragilePrimOp, PrimOp(..) )
  67 import IdInfo           ( ArityInfo(..), bottomIsGuaranteed )
  68 import Literal          ( isNoRepLit, isLitLitLit )
  69 import Pretty
  70 import TyCon            ( tyConFamilySize )
  71 import Type             ( maybeAppDataTyConExpandingDicts )
  72 import Unique           ( Unique )
  73 import UniqSet          ( emptyUniqSet, unitUniqSet, mkUniqSet,
  74                           addOneToUniqSet, unionUniqSets
  75                         )
  76 import Usage            ( SYN_IE(UVar) )
  77 import Maybes           ( maybeToBool )
  78 import Util             ( isIn, panic, assertPanic )
  79 #if __GLASGOW_HASKELL__ >= 202
  80 import Outputable
  81
  82 #endif
  83 \end{code}
  84
  85 %************************************************************************
  86 %*                                                                      *
  87 \subsection{@Unfolding@ and @UnfoldingGuidance@ types}
  88 %*                                                                      *
  89 %************************************************************************
  90
  91 \begin{code}
  92 data Unfolding
  93   = NoUnfolding
  94
  95   | CoreUnfolding SimpleUnfolding
  96
  97   | MagicUnfolding
  98         Unique                          -- Unique of the Id whose magic unfolding this is
  99         MagicUnfoldingFun
 100
 101
 102 data SimpleUnfolding
 103   = SimpleUnfolding                     -- An unfolding with redundant cached information
 104                 FormSummary             -- Tells whether the template is a WHNF or bottom
 105                 UnfoldingGuidance       -- Tells about the *size* of the template.
 106                 SimplifiableCoreExpr    -- Template
 107
 108
 109 noUnfolding = NoUnfolding
 110
 111 mkUnfolding inline_prag expr
 112   = let
 113      -- strictness mangling (depends on there being no CSE)
 114      ufg = calcUnfoldingGuidance inline_prag opt_UnfoldingCreationThreshold expr
 115      occ = occurAnalyseGlobalExpr expr
 116      cuf = CoreUnfolding (SimpleUnfolding (mkFormSummary expr) ufg occ)
 117
 118      cont = case occ of { Var _ -> cuf; _ -> cuf }
 119     in
 120     case ufg of { UnfoldAlways -> cont; _ -> cont }
 121
 122 mkMagicUnfolding :: Unique -> Unfolding
 123 mkMagicUnfolding tag  = MagicUnfolding tag (mkMagicUnfoldingFun tag)
 124
 125 getUnfoldingTemplate :: Unfolding -> CoreExpr
 126 getUnfoldingTemplate (CoreUnfolding (SimpleUnfolding _ _ expr))
 127   = unTagBinders expr
 128 getUnfoldingTemplate other = panic "getUnfoldingTemplate"
 129
 130
 131 data UnfoldingGuidance
 132   = UnfoldNever
 133   | UnfoldAlways                -- There is no "original" definition,
 134                                 -- so you'd better unfold.  Or: something
 135                                 -- so cheap to unfold (e.g., 1#) that
 136                                 -- you should do it absolutely always.
 137
 138   | UnfoldIfGoodArgs    Int     -- if "m" type args
 139                         Int     -- and "n" value args
 140
 141                         [Int]   -- Discount if the argument is evaluated.
 142                                 -- (i.e., a simplification will definitely
 143                                 -- be possible).  One elt of the list per *value* arg.
 144
 145                         Int     -- The "size" of the unfolding; to be elaborated
 146                                 -- later. ToDo
 147
 148                         Int     -- Scrutinee discount: the discount to substract if the thing is in
 149                                 -- a context (case (thing args) of ...),
 150                                 -- (where there are the right number of arguments.)
 151 \end{code}
 152
 153 \begin{code}
 154 instance Outputable UnfoldingGuidance where
 155     ppr sty UnfoldAlways        = ptext SLIT("_ALWAYS_")
 156     ppr sty (UnfoldIfGoodArgs t v cs size discount)
 157       = hsep [ptext SLIT("_IF_ARGS_"), int t, int v,
 158                if null cs       -- always print *something*
 159                 then char 'X'
 160                 else hcat (map (text . show) cs),
 161                int size,
 162                int discount ]
 163 \end{code}
 164
 165
 166 %************************************************************************
 167 %*                                                                      *
 168 \subsection{Figuring out things about expressions}
 169 %*                                                                      *
 170 %************************************************************************
 171
 172 \begin{code}
 173 data FormSummary
 174   = VarForm             -- Expression is a variable (or scc var, etc)
 175   | ValueForm           -- Expression is a value: i.e. a value-lambda,constructor, or literal
 176   | BottomForm          -- Expression is guaranteed to be bottom. We're more gung
 177                         -- ho about inlining such things, because it can't waste work
 178   | OtherForm           -- Anything else
 179
 180 instance Outputable FormSummary where
 181    ppr sty VarForm    = ptext SLIT("Var")
 182    ppr sty ValueForm  = ptext SLIT("Value")
 183    ppr sty BottomForm = ptext SLIT("Bot")
 184    ppr sty OtherForm  = ptext SLIT("Other")
 185
 186 mkFormSummary ::GenCoreExpr bndr Id tyvar uvar -> FormSummary
 187
 188 mkFormSummary expr
 189   = go (0::Int) expr            -- The "n" is the number of (value) arguments so far
 190   where
 191     go n (Lit _)        = ASSERT(n==0) ValueForm
 192     go n (Con _ _)      = ASSERT(n==0) ValueForm
 193     go n (Prim _ _)     = OtherForm
 194     go n (SCC _ e)      = go n e
 195     go n (Coerce _ _ e) = go n e
 196
 197     go n (Let (NonRec b r) e) | exprIsTrivial r = go n e        -- let f = f' alpha in (f,g)
 198                                                                 -- should be treated as a value
 199     go n (Let _ e)      = OtherForm
 200     go n (Case _ _)     = OtherForm
 201
 202     go 0 (Lam (ValBinder x) e) = ValueForm      -- NB: \x.bottom /= bottom!
 203     go n (Lam (ValBinder x) e) = go (n-1) e     -- Applied lambda
 204     go n (Lam other_binder e)  = go n e
 205
 206     go n (App fun arg) | isValArg arg = go (n+1) fun
 207     go n (App fun other_arg)          = go n fun
 208
 209     go n (Var f) | isBottomingId f = BottomForm
 210                  | isDataCon f     = ValueForm          -- Can happen inside imported unfoldings
 211     go 0 (Var f)                   = VarForm
 212     go n (Var f)                   = case getIdArity f of
 213                                           ArityExactly a | n < a -> ValueForm
 214                                           ArityAtLeast a | n < a -> ValueForm
 215                                           other                  -> OtherForm
 216
 217 whnfOrBottom :: GenCoreExpr bndr Id tyvar uvar -> Bool
 218 whnfOrBottom e = case mkFormSummary e of
 219                         VarForm    -> True
 220                         ValueForm  -> True
 221                         BottomForm -> True
 222                         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 {-      OLD: require saturated args
 492     enough_args 0 evals  = True
 493     enough_args n []     = False
 494     enough_args n (e:es) = enough_args (n-1) es
 495         -- NB: don't take the length of arg_is_evald_s because when
 496         -- called from couldBeSmallEnoughToInline it is infinite!
 497 -}
 498
 499     discounted_size = size - args_discount - result_discount
 500
 501     args_discount = sum (zipWith arg_discount discount_vec arg_is_evald_s)
 502     result_discount | result_is_scruted = scrut_discount
 503                     | otherwise         = 0
 504
 505     arg_discount no_of_constrs is_evald
 506       | is_evald  = 1 + no_of_constrs * opt_UnfoldingConDiscount
 507       | otherwise = 1
 508 \end{code}
 509
 510 We use this one to avoid exporting inlinings that we ``couldn't possibly
 511 use'' on the other side.  Can be overridden w/ flaggery.
 512 Just the same as smallEnoughToInline, except that it has no actual arguments.
 513
 514 \begin{code}
 515 --UNUSED?
 516 couldBeSmallEnoughToInline :: UnfoldingGuidance -> Bool
 517 couldBeSmallEnoughToInline guidance = smallEnoughToInline (repeat True) True guidance
 518
 519 certainlySmallEnoughToInline :: UnfoldingGuidance -> Bool
 520 certainlySmallEnoughToInline guidance = smallEnoughToInline (repeat False) False guidance
 521 \end{code}
 522
 523 Predicates
 524 ~~~~~~~~~~
 525
 526 \begin{code}
 527 okToInline
 528         :: FormSummary  -- What the thing to be inlined is like
 529         -> BinderInfo   -- How the thing to be inlined occurs
 530         -> Bool         -- True => it's small enough to inline
 531         -> Bool         -- True => yes, inline it
 532
 533 -- If there's no danger of duplicating work, we can inline if it occurs once, or is small
 534 okToInline form occ_info small_enough
 535  | no_dup_danger form
 536  = small_enough || one_occ
 537  where
 538    one_occ = case occ_info of
 539                 OneOcc _ _ _ n_alts _ -> n_alts <= 1
 540                 other                 -> False
 541
 542    no_dup_danger VarForm    = True
 543    no_dup_danger ValueForm  = True
 544    no_dup_danger BottomForm = True
 545    no_dup_danger other      = False
 546
 547 -- A non-WHNF can be inlined if it doesn't occur inside a lambda,
 548 -- and occurs exactly once or
 549 --     occurs once in each branch of a case and is small
 550 okToInline OtherForm (OneOcc _ dup_danger _ n_alts _) small_enough
 551   = not (isDupDanger dup_danger) && (n_alts <= 1 || small_enough)
 552
 553 okToInline form any_occ small_enough = False
 554 \end{code}
 555