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