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