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