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 bOMB_OUT_SIZE expr
 239   = let
 240         (use_binders, ty_binders, val_binders, body) = collectBinders expr
 241     in
 242     case (sizeExpr bOMB_OUT_SIZE val_binders body) of
 243
 244       Nothing                -> UnfoldNever
 245
 246       Just (size, cased_args)
 247         -> let
 248                uf = UnfoldIfGoodArgs
 249                         (length ty_binders)
 250                         (length val_binders)
 251                         (map discount_for val_binders)
 252                         size
 253
 254                discount_for b
 255                  | is_data && b `is_elem` cased_args = tyConFamilySize tycon
 256                  | otherwise = 0
 257                  where
 258                    (is_data, tycon)
 259                      = --trace "CoreUnfold.getAppDataTyConExpandingDicts:1" $
 260                         case (maybeAppDataTyConExpandingDicts (idType b)) of
 261                           Nothing       -> (False, panic "discount")
 262                           Just (tc,_,_) -> (True,  tc)
 263            in
 264            -- pprTrace "calcUnfold:" (ppAbove (ppr PprDebug uf) (ppr PprDebug expr))
 265            uf
 266   where
 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   = size_up expr
 281   where
 282     size_up (Var v)        = sizeOne
 283     size_up (App fun arg)  = size_up fun `addSize` size_up_arg arg
 284     size_up (Lit lit)      = if isNoRepLit lit
 285                              then sizeN uNFOLDING_NOREP_LIT_COST
 286                              else sizeOne
 287
 288 -- I don't understand this hack so I'm removing it!  SLPJ Nov 96
 289 --    size_up (SCC _ (Con _ _)) = Nothing -- **** HACK *****
 290
 291     size_up (SCC lbl body)    = size_up body            -- SCCs cost nothing
 292     size_up (Coerce _ _ body) = size_up body            -- Coercions cost nothing
 293
 294     size_up (Con con args) = -- 1 + # of val args
 295                              sizeN (1 + numValArgs args)
 296     size_up (Prim op args) = sizeN op_cost -- NB: no charge for PrimOp args
 297       where
 298         op_cost = if primOpCanTriggerGC op
 299                   then uNFOLDING_DEAR_OP_COST
 300                         -- these *tend* to be more expensive;
 301                         -- number chosen to avoid unfolding (HACK)
 302                   else uNFOLDING_CHEAP_OP_COST
 303
 304     size_up expr@(Lam _ _)
 305       = let
 306             (uvars, tyvars, args, body) = collectBinders expr
 307         in
 308         size_up body `addSizeN` length args
 309
 310     size_up (Let (NonRec binder rhs) body)
 311       = size_up rhs
 312                 `addSize`
 313         size_up body
 314                 `addSizeN`
 315         1
 316
 317     size_up (Let (Rec pairs) body)
 318       = foldr addSize sizeZero [size_up rhs | (_,rhs) <- pairs]
 319                 `addSize`
 320         size_up body
 321                 `addSizeN`
 322         length pairs
 323
 324     size_up (Case scrut alts)
 325       = size_up_scrut scrut
 326                 `addSize`
 327         size_up_alts (coreExprType scrut) alts
 328             -- We charge for the "case" itself in "size_up_alts"
 329
 330     ------------
 331     size_up_arg arg = if isValArg arg then sizeOne else sizeZero{-it's free-}
 332
 333     ------------
 334     size_up_alts scrut_ty (AlgAlts alts deflt)
 335       = foldr (addSize . size_alg_alt) (size_up_deflt deflt) alts
 336                 `addSizeN` (if is_data then tyConFamilySize tycon else 1{-??-})
 337         -- NB: we charge N for an alg. "case", where N is
 338         -- the number of constructors in the thing being eval'd.
 339         -- (You'll eventually get a "discount" of N if you
 340         -- think the "case" is likely to go away.)
 341       where
 342         size_alg_alt (con,args,rhs) = size_up rhs
 343             -- Don't charge for args, so that wrappers look cheap
 344
 345         (is_data,tycon)
 346           = --trace "CoreUnfold.getAppDataTyConExpandingDicts:2" $
 347             case (maybeAppDataTyConExpandingDicts scrut_ty) of
 348               Nothing       -> (False, panic "size_up_alts")
 349               Just (tc,_,_) -> (True, tc)
 350
 351     size_up_alts _ (PrimAlts alts deflt)
 352       = foldr (addSize . size_prim_alt) (size_up_deflt deflt) alts
 353             -- *no charge* for a primitive "case"!
 354       where
 355         size_prim_alt (lit,rhs) = size_up rhs
 356
 357     ------------
 358     size_up_deflt NoDefault = sizeZero
 359     size_up_deflt (BindDefault binder rhs) = size_up rhs
 360
 361     ------------
 362         -- Scrutinees.  There are two things going on here.
 363         -- First, we want to record if we're case'ing an argument
 364         -- Second, we want to charge nothing for the srutinee if it's just
 365         -- a variable.  That way wrapper-like things look cheap.
 366     size_up_scrut (Var v) | v `is_elem` args = Just (0, [v])
 367                             | otherwise        = Just (0, [])
 368     size_up_scrut other                        = size_up other
 369
 370     is_elem :: Id -> [Id] -> Bool
 371     is_elem = isIn "size_up_scrut"
 372
 373     ------------
 374     sizeZero  = Just (0, [])
 375     sizeOne   = Just (1, [])
 376     sizeN n   = Just (n, [])
 377
 378     addSizeN Nothing _ = Nothing
 379     addSizeN (Just (n, xs)) m
 380       | tot < bOMB_OUT_SIZE = Just (tot, xs)
 381       | otherwise = Nothing
 382       where
 383         tot = n+m
 384
 385     addSize Nothing _ = Nothing
 386     addSize _ Nothing = Nothing
 387     addSize (Just (n, xs)) (Just (m, ys))
 388       | tot < bOMB_OUT_SIZE = Just (tot, xys)
 389       | otherwise  = Nothing
 390       where
 391         tot = n+m
 392         xys = xs ++ ys
 393 \end{code}
 394
 395 %************************************************************************
 396 %*                                                                      *
 397 \subsection[considerUnfolding]{Given all the info, do (not) do the unfolding}
 398 %*                                                                      *
 399 %************************************************************************
 400
 401 We have very limited information about an unfolding expression: (1)~so
 402 many type arguments and so many value arguments expected---for our
 403 purposes here, we assume we've got those.  (2)~A ``size'' or ``cost,''
 404 a single integer.  (3)~An ``argument info'' vector.  For this, what we
 405 have at the moment is a Boolean per argument position that says, ``I
 406 will look with great favour on an explicit constructor in this
 407 position.''
 408
 409 Assuming we have enough type- and value arguments (if not, we give up
 410 immediately), then we see if the ``discounted size'' is below some
 411 (semi-arbitrary) threshold.  It works like this: for every argument
 412 position where we're looking for a constructor AND WE HAVE ONE in our
 413 hands, we get a (again, semi-arbitrary) discount [proportion to the
 414 number of constructors in the type being scrutinized].
 415
 416 \begin{code}
 417 smallEnoughToInline :: [Bool]                   -- Evaluated-ness of value arguments
 418                     -> UnfoldingGuidance
 419                     -> Bool                     -- True => unfold it
 420
 421 smallEnoughToInline _ UnfoldAlways = True
 422 smallEnoughToInline _ UnfoldNever  = False
 423 smallEnoughToInline arg_is_evald_s
 424               (UnfoldIfGoodArgs m_tys_wanted n_vals_wanted discount_vec size)
 425   = enough_args n_vals_wanted arg_is_evald_s &&
 426     discounted_size <= opt_UnfoldingUseThreshold
 427   where
 428     enough_args 0 evals  = True
 429     enough_args n []     = False
 430     enough_args n (e:es) = enough_args (n-1) es
 431         -- NB: don't take the length of arg_is_evald_s because when
 432         -- called from couldBeSmallEnoughToInline it is infinite!
 433
 434     discounted_size = size - sum (zipWith arg_discount discount_vec arg_is_evald_s)
 435
 436     arg_discount no_of_constrs is_evald
 437       | is_evald  = 1 + no_of_constrs * opt_UnfoldingConDiscount
 438       | otherwise = 1
 439 \end{code}
 440
 441 We use this one to avoid exporting inlinings that we ``couldn't possibly
 442 use'' on the other side.  Can be overridden w/ flaggery.
 443 Just the same as smallEnoughToInline, except that it has no actual arguments.
 444
 445 \begin{code}
 446 couldBeSmallEnoughToInline :: UnfoldingGuidance -> Bool
 447 couldBeSmallEnoughToInline guidance = smallEnoughToInline (repeat True) guidance
 448
 449 certainlySmallEnoughToInline :: UnfoldingGuidance -> Bool
 450 certainlySmallEnoughToInline guidance = smallEnoughToInline (repeat False) guidance
 451 \end{code}
 452
 453 Predicates
 454 ~~~~~~~~~~
 455
 456 \begin{code}
 457 okToInline
 458         :: FormSummary  -- What the thing to be inlined is like
 459         -> BinderInfo   -- How the thing to be inlined occurs
 460         -> Bool         -- True => it's small enough to inline
 461         -> Bool         -- True => yes, inline it
 462
 463 -- Always inline bottoms
 464 okToInline BottomForm occ_info small_enough
 465   = True        -- Unless one of the type args is unboxed??
 466                 -- This used to be checked for, but I can't
 467                 -- see why so I've left it out.
 468
 469 -- A WHNF can be inlined if it occurs once, or is small
 470 okToInline form occ_info small_enough
 471  | is_whnf_form form
 472  = small_enough || one_occ
 473  where
 474    one_occ = case occ_info of
 475                 OneOcc _ _ _ n_alts _ -> n_alts <= 1
 476                 other                 -> False
 477
 478    is_whnf_form VarForm   = True
 479    is_whnf_form ValueForm = True
 480    is_whnf_form other     = False
 481
 482 -- A non-WHNF can be inlined if it doesn't occur inside a lambda,
 483 -- and occurs exactly once or
 484 --     occurs once in each branch of a case and is small
 485 okToInline OtherForm (OneOcc _ dup_danger _ n_alts _) small_enough
 486   = not (isDupDanger dup_danger) && (n_alts <= 1 || small_enough)
 487
 488 okToInline form any_occ small_enough = False
 489 \end{code}
 490