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