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