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