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