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