compiler/coreSyn/CoreUnfold.lhs

   1 %
   2 % (c) The University of Glasgow 2006
   3 % (c) The AQUA Project, Glasgow University, 1994-1998
   4 %
   5
   6 Core-syntax unfoldings
   7
   8 Unfoldings (which can travel across module boundaries) are in Core
   9 syntax (namely @CoreExpr@s).
  10
  11 The type @Unfolding@ sits ``above'' simply-Core-expressions
  12 unfoldings, capturing ``higher-level'' things we know about a binding,
  13 usually things that the simplifier found out (e.g., ``it's a
  14 literal'').  In the corner of a @CoreUnfolding@ unfolding, you will
  15 find, unsurprisingly, a Core expression.
  16
  17 \begin{code}
  18 module CoreUnfold (
  19         Unfolding, UnfoldingGuidance,   -- Abstract types
  20
  21         noUnfolding, mkImplicitUnfolding,
  22         mkTopUnfolding, mkUnfolding, mkCoreUnfolding,
  23         mkInlineRule, mkWwInlineRule,
  24         mkCompulsoryUnfolding, mkDFunUnfolding,
  25
  26         interestingArg, ArgSummary(..),
  27
  28         couldBeSmallEnoughToInline,
  29         certainlyWillInline, smallEnoughToInline,
  30
  31         callSiteInline, CallCtxt(..),
  32
  33         exprIsConApp_maybe
  34
  35     ) where
  36
  37 #include "HsVersions.h"
  38
  39 import StaticFlags
  40 import DynFlags
  41 import CoreSyn
  42 import PprCore          ()      -- Instances
  43 import OccurAnal
  44 import CoreSubst hiding( substTy )
  45 import CoreFVs         ( exprFreeVars )
  46 import CoreUtils
  47 import Id
  48 import DataCon
  49 import TyCon
  50 import Literal
  51 import PrimOp
  52 import IdInfo
  53 import BasicTypes       ( Arity )
  54 import TcType           ( tcSplitDFunTy )
  55 import Type
  56 import Coercion
  57 import PrelNames
  58 import VarEnv           ( mkInScopeSet )
  59 import Bag
  60 import Util
  61 import FastTypes
  62 import FastString
  63 import Outputable
  64
  65 \end{code}
  66
  67
  68 %************************************************************************
  69 %*                                                                      *
  70 \subsection{Making unfoldings}
  71 %*                                                                      *
  72 %************************************************************************
  73
  74 \begin{code}
  75 mkTopUnfolding :: CoreExpr -> Unfolding
  76 mkTopUnfolding expr = mkUnfolding True {- Top level -} expr
  77
  78 mkImplicitUnfolding :: CoreExpr -> Unfolding
  79 -- For implicit Ids, do a tiny bit of optimising first
  80 mkImplicitUnfolding expr = mkTopUnfolding (simpleOptExpr expr)
  81
  82 mkWwInlineRule :: Id -> CoreExpr -> Arity -> Unfolding
  83 mkWwInlineRule id = mkInlineRule (InlWrapper id)
  84
  85 mkInlineRule :: InlineRuleInfo -> CoreExpr -> Arity -> Unfolding
  86 mkInlineRule inl_info expr arity
  87   = mkCoreUnfolding True         -- Note [Top-level flag on inline rules]
  88                     expr' arity
  89                     (InlineRule { ug_ir_info = inl_info, ug_small = small })
  90   where
  91     expr' = simpleOptExpr expr
  92     small = case calcUnfoldingGuidance (arity+1) expr' of
  93               (arity_e, UnfoldIfGoodArgs { ug_size = size_e })
  94                    -> uncondInline arity_e size_e
  95               _other {- actually UnfoldNever -} -> False
  96
  97 -- Note [Top-level flag on inline rules]
  98 -- ~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~
  99 -- Slight hack: note that mk_inline_rules conservatively sets the
 100 -- top-level flag to True.  It gets set more accurately by the simplifier
 101 -- Simplify.simplUnfolding.
 102
 103 mkUnfolding :: Bool -> CoreExpr -> Unfolding
 104 mkUnfolding top_lvl expr
 105   = mkCoreUnfolding top_lvl expr arity guidance
 106   where
 107     (arity, guidance) = calcUnfoldingGuidance opt_UF_CreationThreshold expr
 108         -- Sometimes during simplification, there's a large let-bound thing
 109         -- which has been substituted, and so is now dead; so 'expr' contains
 110         -- two copies of the thing while the occurrence-analysed expression doesn't
 111         -- Nevertheless, we don't occ-analyse before computing the size because the
 112         -- size computation bales out after a while, whereas occurrence analysis does not.
 113         --
 114         -- This can occasionally mean that the guidance is very pessimistic;
 115         -- it gets fixed up next round
 116
 117 mkCoreUnfolding :: Bool -> CoreExpr -> Arity -> UnfoldingGuidance -> Unfolding
 118 -- Occurrence-analyses the expression before capturing it
 119 mkCoreUnfolding top_lvl expr arity guidance
 120   = CoreUnfolding { uf_tmpl       = occurAnalyseExpr expr,
 121                     uf_arity      = arity,
 122                     uf_is_top     = top_lvl,
 123                     uf_is_value   = exprIsHNF        expr,
 124                     uf_is_conlike = exprIsConLike    expr,
 125                     uf_is_cheap   = exprIsCheap      expr,
 126                     uf_expandable = exprIsExpandable expr,
 127                     uf_guidance   = guidance }
 128
 129 mkDFunUnfolding :: DataCon -> [Id] -> Unfolding
 130 mkDFunUnfolding con ops = DFunUnfolding con (map Var ops)
 131
 132 mkCompulsoryUnfolding :: CoreExpr -> Unfolding
 133 mkCompulsoryUnfolding expr      -- Used for things that absolutely must be unfolded
 134   = mkCoreUnfolding True expr 0 UnfoldAlways       -- Arity of unfolding doesn't matter
 135 \end{code}
 136
 137
 138 %************************************************************************
 139 %*                                                                      *
 140 \subsection{The UnfoldingGuidance type}
 141 %*                                                                      *
 142 %************************************************************************
 143
 144 \begin{code}
 145 calcUnfoldingGuidance
 146         :: Int                  -- bomb out if size gets bigger than this
 147         -> CoreExpr             -- expression to look at
 148         -> (Arity, UnfoldingGuidance)
 149 calcUnfoldingGuidance bOMB_OUT_SIZE expr
 150   = case collectBinders expr of { (binders, body) ->
 151     let
 152         val_binders = filter isId binders
 153         n_val_binders = length val_binders
 154     in
 155     case (sizeExpr (iUnbox bOMB_OUT_SIZE) val_binders body) of
 156       TooBig -> (n_val_binders, UnfoldNever)
 157       SizeIs size cased_args scrut_discount
 158         -> (n_val_binders, UnfoldIfGoodArgs { ug_args  = map discount_for val_binders
 159                                             , ug_size  = iBox size
 160                                             , ug_res   = iBox scrut_discount })
 161         where
 162             discount_for b = foldlBag (\acc (b',n) -> if b==b' then acc+n else acc)
 163                                       0 cased_args
 164     }
 165 \end{code}
 166
 167 Note [Computing the size of an expression]
 168 ~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~
 169 The basic idea of sizeExpr is obvious enough: count nodes.  But getting the
 170 heuristics right has taken a long time.  Here's the basic strategy:
 171
 172     * Variables, literals: 0
 173       (Exception for string literals, see litSize.)
 174
 175     * Function applications (f e1 .. en): 1 + #value args
 176
 177     * Constructor applications: 1, regardless of #args
 178
 179     * Let(rec): 1 + size of components
 180
 181     * Note, cast: 0
 182
 183 Examples
 184
 185   Size  Term
 186   --------------
 187     0     42#
 188     0     x
 189     2     f x
 190     1     Just x
 191     4     f (g x)
 192
 193 Notice that 'x' counts 0, while (f x) counts 2.  That's deliberate: there's
 194 a function call to account for.  Notice also that constructor applications
 195 are very cheap, because exposing them to a caller is so valuable.
 196
 197 Note [Unconditional inlining]
 198 ~~~~~~~~~~~~~~~~~~~~~~~~~~~~~
 199 We inline *unconditionally* if inlined thing is smaller (using sizeExpr)
 200 than the thing it's replacing.  Notice that
 201       (f x) --> (g 3)             -- YES, unconditionally
 202       (f x) --> x : []            -- YES, *even though* there are two
 203                                   --      arguments to the cons
 204       x     --> g 3               -- NO
 205       x     --> Just v            -- NO
 206
 207 It's very important not to unconditionally replace a variable by
 208 a non-atomic term.
 209
 210 \begin{code}
 211 uncondInline :: Arity -> Int -> Bool
 212 -- Inline unconditionally if there no size increase
 213 -- Size of call is arity (+1 for the function)
 214 -- See Note [Unconditional inlining]
 215 uncondInline arity size
 216   | arity == 0 = size == 0
 217   | otherwise  = size <= arity + 1
 218 \end{code}
 219
 220
 221 \begin{code}
 222 sizeExpr :: FastInt         -- Bomb out if it gets bigger than this
 223          -> [Id]            -- Arguments; we're interested in which of these
 224                             -- get case'd
 225          -> CoreExpr
 226          -> ExprSize
 227
 228 -- Note [Computing the size of an expression]
 229
 230 sizeExpr bOMB_OUT_SIZE top_args expr
 231   = size_up expr
 232   where
 233     size_up (Cast e _) = size_up e
 234     size_up (Note _ e) = size_up e
 235     size_up (Type _)   = sizeZero           -- Types cost nothing
 236     size_up (Lit lit)  = sizeN (litSize lit)
 237     size_up (Var f)    = size_up_call f []  -- Make sure we get constructor
 238                                             -- discounts even on nullary constructors
 239
 240     size_up (App fun (Type _)) = size_up fun
 241     size_up (App fun arg)      = size_up_app fun [arg]
 242                                   `addSize` nukeScrutDiscount (size_up arg)
 243
 244     size_up (Lam b e) | isId b    = lamScrutDiscount (size_up e `addSizeN` 1)
 245                       | otherwise = size_up e
 246
 247     size_up (Let (NonRec binder rhs) body)
 248       = nukeScrutDiscount (size_up rhs)         `addSize`
 249         size_up body                            `addSizeN`
 250         (if isUnLiftedType (idType binder) then 0 else 1)
 251                 -- For the allocation
 252                 -- If the binder has an unlifted type there is no allocation
 253
 254     size_up (Let (Rec pairs) body)
 255       = nukeScrutDiscount rhs_size              `addSize`
 256         size_up body                            `addSizeN`
 257         length pairs            -- For the allocation
 258       where
 259         rhs_size = foldr (addSize . size_up . snd) sizeZero pairs
 260
 261     size_up (Case (Var v) _ _ alts)
 262         | v `elem` top_args             -- We are scrutinising an argument variable
 263         = alts_size (foldr addSize sizeOne alt_sizes)   -- The 1 is for the case itself
 264                     (foldr1 maxSize alt_sizes)
 265                 -- Good to inline if an arg is scrutinised, because
 266                 -- that may eliminate allocation in the caller
 267                 -- And it eliminates the case itself
 268         where
 269           alt_sizes = map size_up_alt alts
 270
 271                 -- alts_size tries to compute a good discount for
 272                 -- the case when we are scrutinising an argument variable
 273           alts_size (SizeIs tot tot_disc _tot_scrut)           -- Size of all alternatives
 274                     (SizeIs max _max_disc  max_scrut)           -- Size of biggest alternative
 275                 = SizeIs tot (unitBag (v, iBox (_ILIT(1) +# tot -# max)) `unionBags` tot_disc) max_scrut
 276                         -- If the variable is known, we produce a discount that
 277                         -- will take us back to 'max', the size of the largest alternative
 278                         -- The 1+ is a little discount for reduced allocation in the caller
 279                         --
 280                         -- Notice though, that we return tot_disc, the total discount from
 281                         -- all branches.  I think that's right.
 282
 283           alts_size tot_size _ = tot_size
 284
 285     size_up (Case e _ _ alts) = foldr (addSize . size_up_alt)
 286                                       (nukeScrutDiscount (size_up e))
 287                                       alts
 288                                 `addSizeN` 1    -- Add 1 for the case itself
 289                 -- We don't charge for the case itself
 290                 -- It's a strict thing, and the price of the call
 291                 -- is paid by scrut.  Also consider
 292                 --      case f x of DEFAULT -> e
 293                 -- This is just ';'!  Don't charge for it.
 294
 295     ------------
 296     -- size_up_app is used when there's ONE OR MORE value args
 297     size_up_app (App fun arg) args
 298         | isTypeArg arg            = size_up_app fun args
 299         | otherwise                = size_up_app fun (arg:args)
 300                                      `addSize` nukeScrutDiscount (size_up arg)
 301     size_up_app (Var fun)     args = size_up_call fun args
 302     size_up_app other         args = size_up other `addSizeN` length args
 303
 304     ------------
 305     size_up_call :: Id -> [CoreExpr] -> ExprSize
 306     size_up_call fun val_args
 307        = case idDetails fun of
 308            FCallId _        -> sizeN opt_UF_DearOp
 309            DataConWorkId dc -> conSize    dc (length val_args)
 310            PrimOpId op      -> primOpSize op (length val_args)
 311            ClassOpId _      -> classOpSize top_args val_args
 312            _                -> funSize top_args fun (length val_args)
 313
 314     ------------
 315     size_up_alt (_con, _bndrs, rhs) = size_up rhs
 316         -- Don't charge for args, so that wrappers look cheap
 317         -- (See comments about wrappers with Case)
 318
 319     ------------
 320         -- These addSize things have to be here because
 321         -- I don't want to give them bOMB_OUT_SIZE as an argument
 322     addSizeN TooBig          _  = TooBig
 323     addSizeN (SizeIs n xs d) m  = mkSizeIs bOMB_OUT_SIZE (n +# iUnbox m) xs d
 324
 325     addSize TooBig            _                 = TooBig
 326     addSize _                 TooBig            = TooBig
 327     addSize (SizeIs n1 xs d1) (SizeIs n2 ys d2)
 328         = mkSizeIs bOMB_OUT_SIZE (n1 +# n2) (xs `unionBags` ys) (d1 +# d2)
 329 \end{code}
 330
 331 \begin{code}
 332 -- | Finds a nominal size of a string literal.
 333 litSize :: Literal -> Int
 334 -- Used by CoreUnfold.sizeExpr
 335 litSize (MachStr str) = 1 + ((lengthFS str + 3) `div` 4)
 336         -- If size could be 0 then @f "x"@ might be too small
 337         -- [Sept03: make literal strings a bit bigger to avoid fruitless
 338         --  duplication of little strings]
 339 litSize _other = 0    -- Must match size of nullary constructors
 340                       -- Key point: if  x |-> 4, then x must inline unconditionally
 341                       --            (eg via case binding)
 342
 343 classOpSize :: [Id] -> [CoreExpr] -> ExprSize
 344 -- See Note [Conlike is interesting]
 345 classOpSize _ []
 346   = sizeZero
 347 classOpSize top_args (arg1 : other_args)
 348   = SizeIs (iUnbox size) arg_discount (_ILIT(0))
 349   where
 350     size = 2 + length other_args
 351     -- If the class op is scrutinising a lambda bound dictionary then
 352     -- give it a discount, to encourage the inlining of this function
 353     -- The actual discount is rather arbitrarily chosen
 354     arg_discount = case arg1 of
 355                      Var dict | dict `elem` top_args
 356                               -> unitBag (dict, opt_UF_DictDiscount)
 357                      _other   -> emptyBag
 358
 359 funSize :: [Id] -> Id -> Int -> ExprSize
 360 -- Size for functions that are not constructors or primops
 361 -- Note [Function applications]
 362 funSize top_args fun n_val_args
 363   | fun `hasKey` buildIdKey   = buildSize
 364   | fun `hasKey` augmentIdKey = augmentSize
 365   | otherwise = SizeIs (iUnbox size) arg_discount (iUnbox res_discount)
 366   where
 367     some_val_args = n_val_args > 0
 368
 369     arg_discount | some_val_args && fun `elem` top_args
 370                  = unitBag (fun, opt_UF_FunAppDiscount)
 371                  | otherwise = emptyBag
 372         -- If the function is an argument and is applied
 373         -- to some values, give it an arg-discount
 374
 375     res_discount | idArity fun > n_val_args = opt_UF_FunAppDiscount
 376                  | otherwise                = 0
 377         -- If the function is partially applied, show a result discount
 378
 379     size | some_val_args = 1 + n_val_args
 380          | otherwise     = 0
 381         -- The 1+ is for the function itself
 382         -- Add 1 for each non-trivial arg;
 383         -- the allocation cost, as in let(rec)
 384
 385
 386 conSize :: DataCon -> Int -> ExprSize
 387 conSize dc n_val_args
 388   | n_val_args == 0      = SizeIs (_ILIT(0)) emptyBag (_ILIT(1))
 389   | isUnboxedTupleCon dc = SizeIs (_ILIT(0)) emptyBag (iUnbox n_val_args +# _ILIT(1))
 390   | otherwise            = SizeIs (_ILIT(1)) emptyBag (iUnbox n_val_args +# _ILIT(1))
 391         -- Treat a constructors application as size 1, regardless of how
 392         -- many arguments it has; we are keen to expose them
 393         -- (and we charge separately for their args).  We can't treat
 394         -- them as size zero, else we find that (Just x) has size 0,
 395         -- which is the same as a lone variable; and hence 'v' will
 396         -- always be replaced by (Just x), where v is bound to Just x.
 397         --
 398         -- However, unboxed tuples count as size zero
 399         -- I found occasions where we had
 400         --      f x y z = case op# x y z of { s -> (# s, () #) }
 401         -- and f wasn't getting inlined
 402
 403 primOpSize :: PrimOp -> Int -> ExprSize
 404 primOpSize op n_val_args
 405  | not (primOpIsDupable op) = sizeN opt_UF_DearOp
 406  | not (primOpOutOfLine op) = sizeN 1
 407         -- Be very keen to inline simple primops.
 408         -- We give a discount of 1 for each arg so that (op# x y z) costs 2.
 409         -- We can't make it cost 1, else we'll inline let v = (op# x y z)
 410         -- at every use of v, which is excessive.
 411         --
 412         -- A good example is:
 413         --      let x = +# p q in C {x}
 414         -- Even though x get's an occurrence of 'many', its RHS looks cheap,
 415         -- and there's a good chance it'll get inlined back into C's RHS. Urgh!
 416
 417  | otherwise = sizeN n_val_args
 418
 419
 420 buildSize :: ExprSize
 421 buildSize = SizeIs (_ILIT(0)) emptyBag (_ILIT(4))
 422         -- We really want to inline applications of build
 423         -- build t (\cn -> e) should cost only the cost of e (because build will be inlined later)
 424         -- Indeed, we should add a result_discount becuause build is
 425         -- very like a constructor.  We don't bother to check that the
 426         -- build is saturated (it usually is).  The "-2" discounts for the \c n,
 427         -- The "4" is rather arbitrary.
 428
 429 augmentSize :: ExprSize
 430 augmentSize = SizeIs (_ILIT(0)) emptyBag (_ILIT(4))
 431         -- Ditto (augment t (\cn -> e) ys) should cost only the cost of
 432         -- e plus ys. The -2 accounts for the \cn
 433
 434 nukeScrutDiscount :: ExprSize -> ExprSize
 435 nukeScrutDiscount (SizeIs n vs _) = SizeIs n vs (_ILIT(0))
 436 nukeScrutDiscount TooBig          = TooBig
 437
 438 -- When we return a lambda, give a discount if it's used (applied)
 439 lamScrutDiscount :: ExprSize -> ExprSize
 440 lamScrutDiscount (SizeIs n vs _) = SizeIs n vs (iUnbox opt_UF_FunAppDiscount)
 441 lamScrutDiscount TooBig          = TooBig
 442 \end{code}
 443
 444 Note [Discounts and thresholds]
 445 ~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~
 446 Constants for discounts and thesholds are defined in main/StaticFlags,
 447 all of form opt_UF_xxxx.   They are:
 448
 449 opt_UF_CreationThreshold (45)
 450      At a definition site, if the unfolding is bigger than this, we
 451      may discard it altogether
 452
 453 opt_UF_UseThreshold (6)
 454      At a call site, if the unfolding, less discounts, is smaller than
 455      this, then it's small enough inline
 456
 457 opt_UF_KeennessFactor (1.5)
 458      Factor by which the discounts are multiplied before
 459      subtracting from size
 460
 461 opt_UF_DictDiscount (1)
 462      The discount for each occurrence of a dictionary argument
 463      as an argument of a class method.  Should be pretty small
 464      else big functions may get inlined
 465
 466 opt_UF_FunAppDiscount (6)
 467      Discount for a function argument that is applied.  Quite
 468      large, because if we inline we avoid the higher-order call.
 469
 470 opt_UF_DearOp (4)
 471      The size of a foreign call or not-dupable PrimOp
 472
 473
 474 Note [Function applications]
 475 ~~~~~~~~~~~~~~~~~~~~~~~~~~~~
 476 In a function application (f a b)
 477
 478   - If 'f' is an argument to the function being analysed,
 479     and there's at least one value arg, record a FunAppDiscount for f
 480
 481   - If the application if a PAP (arity > 2 in this example)
 482     record a *result* discount (because inlining
 483     with "extra" args in the call may mean that we now
 484     get a saturated application)
 485
 486 Code for manipulating sizes
 487
 488 \begin{code}
 489 data ExprSize = TooBig
 490               | SizeIs FastInt          -- Size found
 491                        (Bag (Id,Int))   -- Arguments cased herein, and discount for each such
 492                        FastInt          -- Size to subtract if result is scrutinised
 493                                         -- by a case expression
 494
 495 instance Outputable ExprSize where
 496   ppr TooBig         = ptext (sLit "TooBig")
 497   ppr (SizeIs a _ c) = brackets (int (iBox a) <+> int (iBox c))
 498
 499 -- subtract the discount before deciding whether to bale out. eg. we
 500 -- want to inline a large constructor application into a selector:
 501 --      tup = (a_1, ..., a_99)
 502 --      x = case tup of ...
 503 --
 504 mkSizeIs :: FastInt -> FastInt -> Bag (Id, Int) -> FastInt -> ExprSize
 505 mkSizeIs max n xs d | (n -# d) ># max = TooBig
 506                     | otherwise       = SizeIs n xs d
 507
 508 maxSize :: ExprSize -> ExprSize -> ExprSize
 509 maxSize TooBig         _                                  = TooBig
 510 maxSize _              TooBig                             = TooBig
 511 maxSize s1@(SizeIs n1 _ _) s2@(SizeIs n2 _ _) | n1 ># n2  = s1
 512                                               | otherwise = s2
 513
 514 sizeZero, sizeOne :: ExprSize
 515 sizeN :: Int -> ExprSize
 516
 517 sizeZero = SizeIs (_ILIT(0))  emptyBag (_ILIT(0))
 518 sizeOne  = SizeIs (_ILIT(1))  emptyBag (_ILIT(0))
 519 sizeN n  = SizeIs (iUnbox n) emptyBag (_ILIT(0))
 520 \end{code}
 521
 522
 523
 524
 525 %************************************************************************
 526 %*                                                                      *
 527 \subsection[considerUnfolding]{Given all the info, do (not) do the unfolding}
 528 %*                                                                      *
 529 %************************************************************************
 530
 531 We use 'couldBeSmallEnoughToInline' to avoid exporting inlinings that
 532 we ``couldn't possibly use'' on the other side.  Can be overridden w/
 533 flaggery.  Just the same as smallEnoughToInline, except that it has no
 534 actual arguments.
 535
 536 \begin{code}
 537 couldBeSmallEnoughToInline :: Int -> CoreExpr -> Bool
 538 couldBeSmallEnoughToInline threshold rhs
 539   = case calcUnfoldingGuidance threshold rhs of
 540        (_, UnfoldNever) -> False
 541        _                -> True
 542
 543 ----------------
 544 smallEnoughToInline :: Unfolding -> Bool
 545 smallEnoughToInline (CoreUnfolding {uf_guidance = UnfoldIfGoodArgs {ug_size = size}})
 546   = size <= opt_UF_UseThreshold
 547 smallEnoughToInline _
 548   = False
 549
 550 ----------------
 551 certainlyWillInline :: Unfolding -> Bool
 552   -- Sees if the unfolding is pretty certain to inline
 553 certainlyWillInline (CoreUnfolding { uf_is_cheap = is_cheap, uf_arity = n_vals, uf_guidance = guidance })
 554   = case guidance of
 555       UnfoldAlways {} -> True
 556       UnfoldNever     -> False
 557       InlineRule {}   -> True
 558       UnfoldIfGoodArgs { ug_size = size}
 559                     -> is_cheap && size - (n_vals +1) <= opt_UF_UseThreshold
 560
 561 certainlyWillInline _
 562   = False
 563 \end{code}
 564
 565 %************************************************************************
 566 %*                                                                      *
 567 \subsection{callSiteInline}
 568 %*                                                                      *
 569 %************************************************************************
 570
 571 This is the key function.  It decides whether to inline a variable at a call site
 572
 573 callSiteInline is used at call sites, so it is a bit more generous.
 574 It's a very important function that embodies lots of heuristics.
 575 A non-WHNF can be inlined if it doesn't occur inside a lambda,
 576 and occurs exactly once or
 577     occurs once in each branch of a case and is small
 578
 579 If the thing is in WHNF, there's no danger of duplicating work,
 580 so we can inline if it occurs once, or is small
 581
 582 NOTE: we don't want to inline top-level functions that always diverge.
 583 It just makes the code bigger.  Tt turns out that the convenient way to prevent
 584 them inlining is to give them a NOINLINE pragma, which we do in
 585 StrictAnal.addStrictnessInfoToTopId
 586
 587 \begin{code}
 588 callSiteInline :: DynFlags
 589                -> Bool                  -- True <=> the Id can be inlined
 590                -> Id                    -- The Id
 591                -> Bool                  -- True if there are are no arguments at all (incl type args)
 592                -> [ArgSummary]          -- One for each value arg; True if it is interesting
 593                -> CallCtxt              -- True <=> continuation is interesting
 594                -> Maybe CoreExpr        -- Unfolding, if any
 595
 596
 597 instance Outputable ArgSummary where
 598   ppr TrivArg    = ptext (sLit "TrivArg")
 599   ppr NonTrivArg = ptext (sLit "NonTrivArg")
 600   ppr ValueArg   = ptext (sLit "ValueArg")
 601
 602 data CallCtxt = BoringCtxt
 603
 604               | ArgCtxt Bool    -- We're somewhere in the RHS of function with rules
 605                                 --      => be keener to inline
 606                         Int     -- We *are* the argument of a function with this arg discount
 607                                 --      => be keener to inline
 608                 -- INVARIANT: ArgCtxt False 0 ==> BoringCtxt
 609
 610               | ValAppCtxt      -- We're applied to at least one value arg
 611                                 -- This arises when we have ((f x |> co) y)
 612                                 -- Then the (f x) has argument 'x' but in a ValAppCtxt
 613
 614               | CaseCtxt        -- We're the scrutinee of a case
 615                                 -- that decomposes its scrutinee
 616
 617 instance Outputable CallCtxt where
 618   ppr BoringCtxt    = ptext (sLit "BoringCtxt")
 619   ppr (ArgCtxt rules disc) = ptext (sLit "ArgCtxt") <> ppr (rules,disc)
 620   ppr CaseCtxt      = ptext (sLit "CaseCtxt")
 621   ppr ValAppCtxt    = ptext (sLit "ValAppCtxt")
 622
 623 callSiteInline dflags active_inline id lone_variable arg_infos cont_info
 624   = let
 625         n_val_args  = length arg_infos
 626     in
 627     case idUnfolding id of {
 628         NoUnfolding      -> Nothing ;
 629         OtherCon _       -> Nothing ;
 630         DFunUnfolding {} -> Nothing ;   -- Never unfold a DFun
 631         CoreUnfolding { uf_tmpl = unf_template, uf_is_top = is_top, uf_is_value = is_value,
 632                         uf_is_cheap = is_cheap, uf_arity = uf_arity, uf_guidance = guidance } ->
 633                         -- uf_arity will typically be equal to (idArity id),
 634                         -- but may be less for InlineRules
 635     let
 636         result | yes_or_no = Just unf_template
 637                | otherwise = Nothing
 638
 639         interesting_args = any nonTriv arg_infos
 640                 -- NB: (any nonTriv arg_infos) looks at the
 641                 -- over-saturated args too which is "wrong";
 642                 -- but if over-saturated we inline anyway.
 643
 644                -- some_benefit is used when the RHS is small enough
 645                -- and the call has enough (or too many) value
 646                -- arguments (ie n_val_args >= arity). But there must
 647                -- be *something* interesting about some argument, or the
 648                -- result context, to make it worth inlining
 649         some_benefit =  interesting_args
 650                      || n_val_args > uf_arity       -- Over-saturated
 651                      || interesting_saturated_call  -- Exactly saturated
 652
 653         interesting_saturated_call
 654           = case cont_info of
 655               BoringCtxt -> not is_top && uf_arity > 0          -- Note [Nested functions]
 656               CaseCtxt   -> not (lone_variable && is_value)     -- Note [Lone variables]
 657               ArgCtxt {} -> uf_arity > 0                        -- Note [Inlining in ArgCtxt]
 658               ValAppCtxt -> True                                -- Note [Cast then apply]
 659
 660         yes_or_no
 661           = case guidance of
 662               UnfoldNever  -> False
 663
 664               UnfoldAlways -> True
 665                 -- UnfoldAlways => there is no top-level binding for
 666                 -- these things, so we must inline it.  Only a few
 667                 -- primop-like things have compulsory unfoldings (see
 668                 -- MkId.lhs).  Ignore is_active because we want to
 669                 -- inline even if SimplGently is on.
 670
 671               InlineRule { ug_ir_info = inl_info, ug_small = uncond_inline }
 672                  | not active_inline     -> False
 673                  | n_val_args < uf_arity -> yes_unsat    -- Not enough value args
 674                  | uncond_inline         -> True         -- Note [INLINE for small functions]
 675                  | otherwise             -> some_benefit -- Saturated or over-saturated
 676                  where
 677                    -- See Note [Inlining an InlineRule]
 678                    yes_unsat = case inl_info of
 679                                   InlSat -> False
 680                                   _other -> interesting_args
 681
 682               UnfoldIfGoodArgs { ug_args = arg_discounts, ug_res = res_discount, ug_size = size }
 683                  | not active_inline          -> False
 684                  | not is_cheap               -> False
 685                  | n_val_args < uf_arity      -> interesting_args && small_enough
 686                                                         -- Note [Unsaturated applications]
 687                  | uncondInline uf_arity size -> True
 688                  | otherwise                  -> some_benefit && small_enough
 689
 690                  where
 691                    small_enough = (size - discount) <= opt_UF_UseThreshold
 692                    discount = computeDiscount uf_arity arg_discounts
 693                                               res_discount arg_infos cont_info
 694
 695     in
 696     if dopt Opt_D_dump_inlinings dflags then
 697         pprTrace ("Considering inlining: " ++ showSDoc (ppr id))
 698                  (vcat [text "active:" <+> ppr active_inline,
 699                         text "arg infos" <+> ppr arg_infos,
 700                         text "interesting continuation" <+> ppr cont_info,
 701                         text "is value:" <+> ppr is_value,
 702                         text "is cheap:" <+> ppr is_cheap,
 703                         text "guidance" <+> ppr guidance,
 704                         text "ANSWER =" <+> if yes_or_no then text "YES" else text "NO"])
 705                   result
 706     else
 707     result
 708     }
 709 \end{code}
 710
 711 Note [Unsaturated applications]
 712 ~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~
 713 When a call is not saturated, we *still* inline if one of the
 714 arguments has interesting structure.  That's sometimes very important.
 715 A good example is the Ord instance for Bool in Base:
 716
 717  Rec {
 718     $fOrdBool =GHC.Classes.D:Ord
 719                  @ Bool
 720                  ...
 721                  $cmin_ajX
 722
 723     $cmin_ajX [Occ=LoopBreaker] :: Bool -> Bool -> Bool
 724     $cmin_ajX = GHC.Classes.$dmmin @ Bool $fOrdBool
 725   }
 726
 727 But the defn of GHC.Classes.$dmmin is:
 728
 729   $dmmin :: forall a. GHC.Classes.Ord a => a -> a -> a
 730     {- Arity: 3, HasNoCafRefs, Strictness: SLL,
 731        Unfolding: (\ @ a $dOrd :: GHC.Classes.Ord a x :: a y :: a ->
 732                    case @ a GHC.Classes.<= @ a $dOrd x y of wild {
 733                      GHC.Bool.False -> y GHC.Bool.True -> x }) -}
 734
 735 We *really* want to inline $dmmin, even though it has arity 3, in
 736 order to unravel the recursion.
 737
 738
 739 Note [INLINE for small functions]
 740 ~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~
 741 Consider        {-# INLINE f #-}
 742                 f x = Just x
 743                 g y = f y
 744 Then f's RHS is no larger than its LHS, so we should inline it
 745 into even the most boring context.  (We do so if there is no INLINE
 746 pragma!)  That's the reason for the 'inl_small' flag on an InlineRule.
 747
 748
 749 Note [Things to watch]
 750 ~~~~~~~~~~~~~~~~~~~~~~
 751 *   { y = I# 3; x = y `cast` co; ...case (x `cast` co) of ... }
 752     Assume x is exported, so not inlined unconditionally.
 753     Then we want x to inline unconditionally; no reason for it
 754     not to, and doing so avoids an indirection.
 755
 756 *   { x = I# 3; ....f x.... }
 757     Make sure that x does not inline unconditionally!
 758     Lest we get extra allocation.
 759
 760 Note [Inlining an InlineRule]
 761 ~~~~~~~~~~~~~~~~~~~~~~~~~~~~~
 762 An InlineRules is used for
 763   (a) pogrammer INLINE pragmas
 764   (b) inlinings from worker/wrapper
 765
 766 For (a) the RHS may be large, and our contract is that we *only* inline
 767 when the function is applied to all the arguments on the LHS of the
 768 source-code defn.  (The uf_arity in the rule.)
 769
 770 However for worker/wrapper it may be worth inlining even if the
 771 arity is not satisfied (as we do in the CoreUnfolding case) so we don't
 772 require saturation.
 773
 774
 775 Note [Nested functions]
 776 ~~~~~~~~~~~~~~~~~~~~~~~
 777 If a function has a nested defn we also record some-benefit, on the
 778 grounds that we are often able to eliminate the binding, and hence the
 779 allocation, for the function altogether; this is good for join points.
 780 But this only makes sense for *functions*; inlining a constructor
 781 doesn't help allocation unless the result is scrutinised.  UNLESS the
 782 constructor occurs just once, albeit possibly in multiple case
 783 branches.  Then inlining it doesn't increase allocation, but it does
 784 increase the chance that the constructor won't be allocated at all in
 785 the branches that don't use it.
 786
 787 Note [Cast then apply]
 788 ~~~~~~~~~~~~~~~~~~~~~~
 789 Consider
 790    myIndex = __inline_me ( (/\a. <blah>) |> co )
 791    co :: (forall a. a -> a) ~ (forall a. T a)
 792      ... /\a.\x. case ((myIndex a) |> sym co) x of { ... } ...
 793
 794 We need to inline myIndex to unravel this; but the actual call (myIndex a) has
 795 no value arguments.  The ValAppCtxt gives it enough incentive to inline.
 796
 797 Note [Inlining in ArgCtxt]
 798 ~~~~~~~~~~~~~~~~~~~~~~~~~~
 799 The condition (arity > 0) here is very important, because otherwise
 800 we end up inlining top-level stuff into useless places; eg
 801    x = I# 3#
 802    f = \y.  g x
 803 This can make a very big difference: it adds 16% to nofib 'integer' allocs,
 804 and 20% to 'power'.
 805
 806 At one stage I replaced this condition by 'True' (leading to the above
 807 slow-down).  The motivation was test eyeball/inline1.hs; but that seems
 808 to work ok now.
 809
 810 Note [Lone variables]
 811 ~~~~~~~~~~~~~~~~~~~~~
 812 The "lone-variable" case is important.  I spent ages messing about
 813 with unsatisfactory varaints, but this is nice.  The idea is that if a
 814 variable appears all alone
 815
 816         as an arg of lazy fn, or rhs    BoringCtxt
 817         as scrutinee of a case          CaseCtxt
 818         as arg of a fn                  ArgCtxt
 819 AND
 820         it is bound to a value
 821
 822 then we should not inline it (unless there is some other reason,
 823 e.g. is is the sole occurrence).  That is what is happening at
 824 the use of 'lone_variable' in 'interesting_saturated_call'.
 825
 826 Why?  At least in the case-scrutinee situation, turning
 827         let x = (a,b) in case x of y -> ...
 828 into
 829         let x = (a,b) in case (a,b) of y -> ...
 830 and thence to
 831         let x = (a,b) in let y = (a,b) in ...
 832 is bad if the binding for x will remain.
 833
 834 Another example: I discovered that strings
 835 were getting inlined straight back into applications of 'error'
 836 because the latter is strict.
 837         s = "foo"
 838         f = \x -> ...(error s)...
 839
 840 Fundamentally such contexts should not encourage inlining because the
 841 context can ``see'' the unfolding of the variable (e.g. case or a
 842 RULE) so there's no gain.  If the thing is bound to a value.
 843
 844 However, watch out:
 845
 846  * Consider this:
 847         foo = _inline_ (\n. [n])
 848         bar = _inline_ (foo 20)
 849         baz = \n. case bar of { (m:_) -> m + n }
 850    Here we really want to inline 'bar' so that we can inline 'foo'
 851    and the whole thing unravels as it should obviously do.  This is
 852    important: in the NDP project, 'bar' generates a closure data
 853    structure rather than a list.
 854
 855    So the non-inlining of lone_variables should only apply if the
 856    unfolding is regarded as cheap; because that is when exprIsConApp_maybe
 857    looks through the unfolding.  Hence the "&& is_cheap" in the
 858    InlineRule branch.
 859
 860  * Even a type application or coercion isn't a lone variable.
 861    Consider
 862         case $fMonadST @ RealWorld of { :DMonad a b c -> c }
 863    We had better inline that sucker!  The case won't see through it.
 864
 865    For now, I'm treating treating a variable applied to types
 866    in a *lazy* context "lone". The motivating example was
 867         f = /\a. \x. BIG
 868         g = /\a. \y.  h (f a)
 869    There's no advantage in inlining f here, and perhaps
 870    a significant disadvantage.  Hence some_val_args in the Stop case
 871
 872 \begin{code}
 873 computeDiscount :: Int -> [Int] -> Int -> [ArgSummary] -> CallCtxt -> Int
 874 computeDiscount n_vals_wanted arg_discounts res_discount arg_infos cont_info
 875         -- We multiple the raw discounts (args_discount and result_discount)
 876         -- ty opt_UnfoldingKeenessFactor because the former have to do with
 877         --  *size* whereas the discounts imply that there's some extra
 878         --  *efficiency* to be gained (e.g. beta reductions, case reductions)
 879         -- by inlining.
 880
 881   = 1           -- Discount of 1 because the result replaces the call
 882                 -- so we count 1 for the function itself
 883
 884     + length (take n_vals_wanted arg_infos)
 885                -- Discount of (un-scaled) 1 for each arg supplied,
 886                -- because the result replaces the call
 887
 888     + round (opt_UF_KeenessFactor *
 889              fromIntegral (arg_discount + res_discount'))
 890   where
 891     arg_discount = sum (zipWith mk_arg_discount arg_discounts arg_infos)
 892
 893     mk_arg_discount _        TrivArg    = 0
 894     mk_arg_discount _        NonTrivArg = 1
 895     mk_arg_discount discount ValueArg   = discount
 896
 897     res_discount' = case cont_info of
 898                         BoringCtxt  -> 0
 899                         CaseCtxt    -> res_discount
 900                         _other      -> 4 `min` res_discount
 901                 -- res_discount can be very large when a function returns
 902                 -- construtors; but we only want to invoke that large discount
 903                 -- when there's a case continuation.
 904                 -- Otherwise we, rather arbitrarily, threshold it.  Yuk.
 905                 -- But we want to aovid inlining large functions that return
 906                 -- constructors into contexts that are simply "interesting"
 907 \end{code}
 908
 909 %************************************************************************
 910 %*                                                                      *
 911         Interesting arguments
 912 %*                                                                      *
 913 %************************************************************************
 914
 915 Note [Interesting arguments]
 916 ~~~~~~~~~~~~~~~~~~~~~~~~~~~~
 917 An argument is interesting if it deserves a discount for unfoldings
 918 with a discount in that argument position.  The idea is to avoid
 919 unfolding a function that is applied only to variables that have no
 920 unfolding (i.e. they are probably lambda bound): f x y z There is
 921 little point in inlining f here.
 922
 923 Generally, *values* (like (C a b) and (\x.e)) deserve discounts.  But
 924 we must look through lets, eg (let x = e in C a b), because the let will
 925 float, exposing the value, if we inline.  That makes it different to
 926 exprIsHNF.
 927
 928 Before 2009 we said it was interesting if the argument had *any* structure
 929 at all; i.e. (hasSomeUnfolding v).  But does too much inlining; see Trac #3016.
 930
 931 But we don't regard (f x y) as interesting, unless f is unsaturated.
 932 If it's saturated and f hasn't inlined, then it's probably not going
 933 to now!
 934
 935 Note [Conlike is interesting]
 936 ~~~~~~~~~~~~~~~~~~~~~~~~~~~~~
 937 Consider
 938         f d = ...((*) d x y)...
 939         ... f (df d')...
 940 where df is con-like. Then we'd really like to inline 'f' so that the
 941 rule for (*) (df d) can fire.  To do this
 942   a) we give a discount for being an argument of a class-op (eg (*) d)
 943   b) we say that a con-like argument (eg (df d)) is interesting
 944
 945 \begin{code}
 946 data ArgSummary = TrivArg       -- Nothing interesting
 947                 | NonTrivArg    -- Arg has structure
 948                 | ValueArg      -- Arg is a con-app or PAP
 949                                 -- ..or con-like. Note [Conlike is interesting]
 950
 951 interestingArg :: CoreExpr -> ArgSummary
 952 -- See Note [Interesting arguments]
 953 interestingArg e = go e 0
 954   where
 955     -- n is # value args to which the expression is applied
 956     go (Lit {}) _          = ValueArg
 957     go (Var v)  n
 958        | isConLikeId v     = ValueArg   -- Experimenting with 'conlike' rather that
 959                                         --    data constructors here
 960        | idArity v > n     = ValueArg   -- Catches (eg) primops with arity but no unfolding
 961        | n > 0             = NonTrivArg -- Saturated or unknown call
 962        | conlike_unfolding = ValueArg   -- n==0; look for an interesting unfolding
 963                                         -- See Note [Conlike is interesting]
 964        | otherwise         = TrivArg    -- n==0, no useful unfolding
 965        where
 966          conlike_unfolding = isConLikeUnfolding (idUnfolding v)
 967
 968     go (Type _)          _ = TrivArg
 969     go (App fn (Type _)) n = go fn n
 970     go (App fn _)        n = go fn (n+1)
 971     go (Note _ a)        n = go a n
 972     go (Cast e _)        n = go e n
 973     go (Lam v e)         n
 974        | isTyVar v         = go e n
 975        | n>0               = go e (n-1)
 976        | otherwise         = ValueArg
 977     go (Let _ e)         n = case go e n of { ValueArg -> ValueArg; _ -> NonTrivArg }
 978     go (Case {})         _ = NonTrivArg
 979
 980 nonTriv ::  ArgSummary -> Bool
 981 nonTriv TrivArg = False
 982 nonTriv _       = True
 983 \end{code}
 984
 985 %************************************************************************
 986 %*                                                                      *
 987          exprIsConApp_maybe
 988 %*                                                                      *
 989 %************************************************************************
 990
 991 Note [exprIsConApp_maybe]
 992 ~~~~~~~~~~~~~~~~~~~~~~~~~
 993 exprIsConApp_maybe is a very important function.  There are two principal
 994 uses:
 995   * case e of { .... }
 996   * cls_op e, where cls_op is a class operation
 997
 998 In both cases you want to know if e is of form (C e1..en) where C is
 999 a data constructor.
1000
1001 However e might not *look* as if
1002
1003 \begin{code}
1004 -- | Returns @Just (dc, [t1..tk], [x1..xn])@ if the argument expression is
1005 -- a *saturated* constructor application of the form @dc t1..tk x1 .. xn@,
1006 -- where t1..tk are the *universally-qantified* type args of 'dc'
1007 exprIsConApp_maybe :: CoreExpr -> Maybe (DataCon, [Type], [CoreExpr])
1008
1009 exprIsConApp_maybe (Note _ expr)
1010   = exprIsConApp_maybe expr
1011         -- We ignore all notes.  For example,
1012         --      case _scc_ "foo" (C a b) of
1013         --                      C a b -> e
1014         -- should be optimised away, but it will be only if we look
1015         -- through the SCC note.
1016
1017 exprIsConApp_maybe (Cast expr co)
1018   =     -- Here we do the KPush reduction rule as described in the FC paper
1019         -- The transformation applies iff we have
1020         --      (C e1 ... en) `cast` co
1021         -- where co :: (T t1 .. tn) ~ to_ty
1022         -- The left-hand one must be a T, because exprIsConApp returned True
1023         -- but the right-hand one might not be.  (Though it usually will.)
1024
1025     case exprIsConApp_maybe expr of {
1026         Nothing                          -> Nothing ;
1027         Just (dc, _dc_univ_args, dc_args) ->
1028
1029     let (_from_ty, to_ty) = coercionKind co
1030         dc_tc = dataConTyCon dc
1031     in
1032     case splitTyConApp_maybe to_ty of {
1033         Nothing -> Nothing ;
1034         Just (to_tc, to_tc_arg_tys)
1035                 | dc_tc /= to_tc -> Nothing
1036                 -- These two Nothing cases are possible; we might see
1037                 --      (C x y) `cast` (g :: T a ~ S [a]),
1038                 -- where S is a type function.  In fact, exprIsConApp
1039                 -- will probably not be called in such circumstances,
1040                 -- but there't nothing wrong with it
1041
1042                 | otherwise  ->
1043     let
1044         tc_arity       = tyConArity dc_tc
1045         dc_univ_tyvars = dataConUnivTyVars dc
1046         dc_ex_tyvars   = dataConExTyVars dc
1047         arg_tys        = dataConRepArgTys dc
1048
1049         dc_eqs :: [(Type,Type)]   -- All equalities from the DataCon
1050         dc_eqs = [(mkTyVarTy tv, ty)   | (tv,ty) <- dataConEqSpec dc] ++
1051                  [getEqPredTys eq_pred | eq_pred <- dataConEqTheta dc]
1052
1053         (ex_args, rest1)    = splitAtList dc_ex_tyvars dc_args
1054         (co_args, val_args) = splitAtList dc_eqs rest1
1055
1056         -- Make the "theta" from Fig 3 of the paper
1057         gammas = decomposeCo tc_arity co
1058         theta  = zipOpenTvSubst (dc_univ_tyvars ++ dc_ex_tyvars)
1059                                 (gammas         ++ stripTypeArgs ex_args)
1060
1061           -- Cast the existential coercion arguments
1062         cast_co (ty1, ty2) (Type co)
1063           = Type $ mkSymCoercion (substTy theta ty1)
1064                    `mkTransCoercion` co
1065                    `mkTransCoercion` (substTy theta ty2)
1066         cast_co _ other_arg = pprPanic "cast_co" (ppr other_arg)
1067         new_co_args = zipWith cast_co dc_eqs co_args
1068
1069           -- Cast the value arguments (which include dictionaries)
1070         new_val_args = zipWith cast_arg arg_tys val_args
1071         cast_arg arg_ty arg = mkCoerce (substTy theta arg_ty) arg
1072     in
1073 #ifdef DEBUG
1074     let dump_doc = vcat [ppr dc,      ppr dc_univ_tyvars, ppr dc_ex_tyvars,
1075                          ppr arg_tys, ppr dc_args,        ppr _dc_univ_args,
1076                          ppr ex_args, ppr val_args]
1077     in
1078     ASSERT2( coreEqType _from_ty (mkTyConApp dc_tc _dc_univ_args), dump_doc )
1079     ASSERT2( all isTypeArg (ex_args ++ co_args), dump_doc )
1080     ASSERT2( equalLength val_args arg_tys, dump_doc )
1081 #endif
1082
1083     Just (dc, to_tc_arg_tys, ex_args ++ new_co_args ++ new_val_args)
1084     }}
1085
1086 exprIsConApp_maybe expr
1087   = analyse expr []
1088   where
1089     analyse (App fun arg) args = analyse fun (arg:args)
1090     analyse fun@(Lam {})  args = beta fun [] args
1091
1092     analyse (Var fun) args
1093         | Just con <- isDataConWorkId_maybe fun
1094         , is_saturated
1095         , let (univ_ty_args, rest_args) = splitAtList (dataConUnivTyVars con) args
1096         = Just (con, stripTypeArgs univ_ty_args, rest_args)
1097
1098         -- Look through dictionary functions; see Note [Unfolding DFuns]
1099         | DFunUnfolding con ops <- unfolding
1100         , is_saturated
1101         , let (dfun_tvs, _cls, dfun_res_tys) = tcSplitDFunTy (idType fun)
1102               subst = zipOpenTvSubst dfun_tvs (stripTypeArgs (takeList dfun_tvs args))
1103         = Just (con, substTys subst dfun_res_tys,
1104                      [mkApps op args | op <- ops])
1105
1106         -- Look through unfoldings, but only cheap ones, because
1107         -- we are effectively duplicating the unfolding
1108         | CoreUnfolding { uf_expandable = expand_me, uf_tmpl = rhs } <- unfolding
1109         , expand_me = -- pprTrace "expanding" (ppr fun $$ ppr rhs) $
1110                       analyse rhs args
1111         where
1112           is_saturated = count isValArg args == idArity fun
1113           unfolding = idUnfolding fun
1114
1115     analyse _ _ = Nothing
1116
1117     -----------
1118     in_scope = mkInScopeSet (exprFreeVars expr)
1119
1120     -----------
1121     beta (Lam v body) pairs (arg : args)
1122         | isTypeArg arg
1123         = beta body ((v,arg):pairs) args
1124
1125     beta (Lam {}) _ _    -- Un-saturated, or not a type lambda
1126         = Nothing
1127
1128     beta fun pairs args
1129         = case analyse (substExpr subst fun) args of
1130             Nothing  -> -- pprTrace "Bale out! exprIsConApp_maybe" doc $
1131                         Nothing
1132             Just ans -> -- pprTrace "Woo-hoo! exprIsConApp_maybe" doc $
1133                         Just ans
1134         where
1135           subst = mkOpenSubst in_scope pairs
1136           -- doc = vcat [ppr fun, ppr expr, ppr pairs, ppr args]
1137
1138
1139 stripTypeArgs :: [CoreExpr] -> [Type]
1140 stripTypeArgs args = ASSERT2( all isTypeArg args, ppr args )
1141                      [ty | Type ty <- args]
1142 \end{code}
1143
1144 Note [Unfolding DFuns]
1145 ~~~~~~~~~~~~~~~~~~~~~~
1146 DFuns look like
1147
1148   df :: forall a b. (Eq a, Eq b) -> Eq (a,b)
1149   df a b d_a d_b = MkEqD (a,b) ($c1 a b d_a d_b)
1150                                ($c2 a b d_a d_b)
1151
1152 So to split it up we just need to apply the ops $c1, $c2 etc
1153 to the very same args as the dfun.  It takes a little more work
1154 to compute the type arguments to the dictionary constructor.
1155