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