Some typos in comments
[ghc.git] / compiler / simplCore / SimplUtils.lhs
1 %
2 % (c) The AQUA Project, Glasgow University, 1993-1998
3 %
4 \section[SimplUtils]{The simplifier utilities}
5
6 \begin{code}
7 module SimplUtils (
8         -- Rebuilding
9         mkLam, mkCase, prepareAlts, tryEtaExpandRhs,
10
11         -- Inlining,
12         preInlineUnconditionally, postInlineUnconditionally,
13         activeUnfolding, activeRule,
14         getUnfoldingInRuleMatch,
15         simplEnvForGHCi, updModeForInlineRules,
16
17         -- The continuation type
18         SimplCont(..), DupFlag(..), 
19         isSimplified,
20         contIsDupable, contResultType, contInputType,
21         contIsTrivial, contArgs, dropArgs,
22         pushSimplifiedArgs, countValArgs, countArgs, 
23         mkBoringStop, mkRhsStop, mkLazyArgStop, contIsRhsOrArg,
24         interestingCallContext, interestingArg, 
25
26         -- ArgInfo
27         ArgInfo(..), ArgSpec(..), mkArgInfo, addArgTo, addCastTo, 
28         argInfoExpr, argInfoValArgs,
29
30         abstractFloats
31     ) where
32
33 #include "HsVersions.h"
34
35 import SimplEnv
36 import CoreMonad        ( SimplifierMode(..), Tick(..) )
37 import MkCore           ( sortQuantVars )
38 import DynFlags
39 import CoreSyn
40 import qualified CoreSubst
41 import PprCore
42 import CoreFVs
43 import CoreUtils
44 import CoreArity
45 import CoreUnfold
46 import Name
47 import Id
48 import Var
49 import Demand
50 import SimplMonad
51 import Type     hiding( substTy )
52 import Coercion hiding( substCo, substTy )
53 import DataCon          ( dataConWorkId )
54 import VarSet
55 import BasicTypes
56 import Util
57 import MonadUtils
58 import Outputable
59 import FastString
60 import Pair
61
62 import Control.Monad    ( when )
63 \end{code}
64
65
66 %************************************************************************
67 %*                                                                      *
68                 The SimplCont type
69 %*                                                                      *
70 %************************************************************************
71
72 A SimplCont allows the simplifier to traverse the expression in a
73 zipper-like fashion.  The SimplCont represents the rest of the expression,
74 "above" the point of interest.
75
76 You can also think of a SimplCont as an "evaluation context", using
77 that term in the way it is used for operational semantics. This is the
78 way I usually think of it, For example you'll often see a syntax for
79 evaluation context looking like
80         C ::= []  |  C e   |  case C of alts  |  C `cast` co
81 That's the kind of thing we are doing here, and I use that syntax in
82 the comments.
83
84
85 Key points:
86   * A SimplCont describes a *strict* context (just like
87     evaluation contexts do).  E.g. Just [] is not a SimplCont
88
89   * A SimplCont describes a context that *does not* bind
90     any variables.  E.g. \x. [] is not a SimplCont
91
92 \begin{code}
93 data SimplCont
94   = Stop                -- An empty context, or <hole>
95         OutType         -- Type of the <hole>
96         CallCtxt        -- Tells if there is something interesting about
97                         --          the context, and hence the inliner
98                         --          should be a bit keener (see interestingCallContext)
99                         -- Specifically:
100                         --     This is an argument of a function that has RULES
101                         --     Inlining the call might allow the rule to fire
102                         -- Never ValAppCxt (use ApplyTo instead)
103                         -- or CaseCtxt (use Select instead)
104
105   | CoerceIt            -- <hole> `cast` co
106         OutCoercion             -- The coercion simplified
107                                 -- Invariant: never an identity coercion
108         SimplCont
109
110   | ApplyTo             -- <hole> arg
111         DupFlag                 -- See Note [DupFlag invariants]
112         InExpr StaticEnv        -- The argument and its static env
113         SimplCont
114
115   | Select              -- case <hole> of alts
116         DupFlag                 -- See Note [DupFlag invariants]
117         InId [InAlt] StaticEnv  -- The case binder, alts type, alts, and subst-env
118         SimplCont
119
120   -- The two strict forms have no DupFlag, because we never duplicate them
121   | StrictBind                  -- (\x* \xs. e) <hole>
122         InId [InBndr]           -- let x* = <hole> in e
123         InExpr StaticEnv        --      is a special case
124         SimplCont
125
126   | StrictArg           -- f e1 ..en <hole>
127         ArgInfo         -- Specifies f, e1..en, Whether f has rules, etc
128                         --     plus strictness flags for *further* args
129         CallCtxt        -- Whether *this* argument position is interesting
130         SimplCont
131
132   | TickIt
133         (Tickish Id)    -- Tick tickish <hole>
134         SimplCont
135
136 data ArgInfo
137   = ArgInfo {
138         ai_fun   :: OutId,      -- The function
139         ai_args  :: [ArgSpec],  -- ...applied to these args (which are in *reverse* order)
140         ai_type  :: OutType,    -- Type of (f a1 ... an)
141
142         ai_rules :: [CoreRule], -- Rules for this function
143
144         ai_encl :: Bool,        -- Flag saying whether this function
145                                 -- or an enclosing one has rules (recursively)
146                                 --      True => be keener to inline in all args
147
148         ai_strs :: [Bool],      -- Strictness of remaining arguments
149                                 --   Usually infinite, but if it is finite it guarantees
150                                 --   that the function diverges after being given
151                                 --   that number of args
152         ai_discs :: [Int]       -- Discounts for remaining arguments; non-zero => be keener to inline
153                                 --   Always infinite
154     }
155
156 data ArgSpec = ValArg OutExpr       -- Apply to this
157              | CastBy OutCoercion   -- Cast by this
158
159 instance Outputable ArgSpec where
160   ppr (ValArg e) = ptext (sLit "ValArg") <+> ppr e
161   ppr (CastBy c) = ptext (sLit "CastBy") <+> ppr c
162
163 addArgTo :: ArgInfo -> OutExpr -> ArgInfo
164 addArgTo ai arg = ai { ai_args = ValArg arg : ai_args ai
165                      , ai_type = applyTypeToArg (ai_type ai) arg  }
166
167 addCastTo :: ArgInfo -> OutCoercion -> ArgInfo
168 addCastTo ai co = ai { ai_args = CastBy co : ai_args ai
169                      , ai_type = pSnd (coercionKind co) }
170
171 argInfoValArgs :: SimplEnv -> [ArgSpec] -> SimplCont -> ([OutExpr], SimplCont)
172 argInfoValArgs env args cont
173   = go args [] cont
174   where
175     go :: [ArgSpec] -> [OutExpr] -> SimplCont -> ([OutExpr], SimplCont)
176     go (ValArg e  : as) acc cont = go as (e:acc) cont
177     go (CastBy co : as) acc cont = go as [] (CoerceIt co (pushSimplifiedArgs env acc cont))
178     go []               acc cont = (acc, cont)
179
180 argInfoExpr :: OutId -> [ArgSpec] -> OutExpr
181 argInfoExpr fun args
182   = go args
183   where
184     go []               = Var fun
185     go (ValArg a : as)  = go as `App` a
186     go (CastBy co : as) = mkCast (go as) co
187
188 instance Outputable SimplCont where
189   ppr (Stop ty interesting)          = ptext (sLit "Stop") <> brackets (ppr interesting) <+> ppr ty
190   ppr (ApplyTo dup arg _ cont)       = ((ptext (sLit "ApplyTo") <+> ppr dup <+> pprParendExpr arg)
191                                           {-  $$ nest 2 (pprSimplEnv se) -}) $$ ppr cont
192   ppr (StrictBind b _ _ _ cont)      = (ptext (sLit "StrictBind") <+> ppr b) $$ ppr cont
193   ppr (StrictArg ai _ cont)          = (ptext (sLit "StrictArg") <+> ppr (ai_fun ai)) $$ ppr cont
194   ppr (Select dup bndr alts se cont) = (ptext (sLit "Select") <+> ppr dup <+> ppr bndr) $$
195                                          (nest 2 $ vcat [ppr (seTvSubst se), ppr alts]) $$ ppr cont
196   ppr (CoerceIt co cont)             = (ptext (sLit "CoerceIt") <+> ppr co) $$ ppr cont
197   ppr (TickIt t cont)                = (ptext (sLit "TickIt") <+> ppr t) $$ ppr cont
198
199 data DupFlag = NoDup       -- Unsimplified, might be big
200              | Simplified  -- Simplified
201              | OkToDup     -- Simplified and small
202
203 isSimplified :: DupFlag -> Bool
204 isSimplified NoDup = False
205 isSimplified _     = True       -- Invariant: the subst-env is empty
206
207 instance Outputable DupFlag where
208   ppr OkToDup    = ptext (sLit "ok")
209   ppr NoDup      = ptext (sLit "nodup")
210   ppr Simplified = ptext (sLit "simpl")
211 \end{code}
212
213 Note [DupFlag invariants]
214 ~~~~~~~~~~~~~~~~~~~~~~~~~
215 In both (ApplyTo dup _ env k)
216    and  (Select dup _ _ env k)
217 the following invariants hold
218
219   (a) if dup = OkToDup, then continuation k is also ok-to-dup
220   (b) if dup = OkToDup or Simplified, the subst-env is empty
221       (and and hence no need to re-simplify)
222
223 \begin{code}
224 -------------------
225 mkBoringStop :: OutType -> SimplCont
226 mkBoringStop ty = Stop ty BoringCtxt
227
228 mkRhsStop :: OutType -> SimplCont       -- See Note [RHS of lets] in CoreUnfold
229 mkRhsStop ty = Stop ty RhsCtxt
230
231 mkLazyArgStop :: OutType -> CallCtxt -> SimplCont
232 mkLazyArgStop ty cci = Stop ty cci
233
234 -------------------
235 contIsRhsOrArg :: SimplCont -> Bool
236 contIsRhsOrArg (Stop {})       = True
237 contIsRhsOrArg (StrictBind {}) = True
238 contIsRhsOrArg (StrictArg {})  = True
239 contIsRhsOrArg _               = False
240
241 contIsRhs :: SimplCont -> Bool
242 contIsRhs (Stop _ RhsCtxt) = True
243 contIsRhs _                = False
244
245 -------------------
246 contIsDupable :: SimplCont -> Bool
247 contIsDupable (Stop {})                  = True
248 contIsDupable (ApplyTo  OkToDup _ _ _)   = True -- See Note [DupFlag invariants]
249 contIsDupable (Select   OkToDup _ _ _ _) = True -- ...ditto...
250 contIsDupable (CoerceIt _ cont)          = contIsDupable cont
251 contIsDupable _                          = False
252
253 -------------------
254 contIsTrivial :: SimplCont -> Bool
255 contIsTrivial (Stop {})                   = True
256 contIsTrivial (ApplyTo _ (Type _) _ cont) = contIsTrivial cont
257 contIsTrivial (ApplyTo _ (Coercion _) _ cont) = contIsTrivial cont
258 contIsTrivial (CoerceIt _ cont)           = contIsTrivial cont
259 contIsTrivial _                           = False
260
261 -------------------
262 contResultType :: SimplCont -> OutType
263 contResultType (Stop ty _)            = ty
264 contResultType (CoerceIt _ k)         = contResultType k
265 contResultType (StrictBind _ _ _ _ k) = contResultType k
266 contResultType (StrictArg _ _ k)      = contResultType k
267 contResultType (Select _ _ _ _ k)     = contResultType k
268 contResultType (ApplyTo _ _ _ k)      = contResultType k
269 contResultType (TickIt _ k)           = contResultType k
270
271 contInputType :: SimplCont -> OutType
272 contInputType (Stop ty _)             = ty
273 contInputType (CoerceIt co _)         = pFst (coercionKind co)
274 contInputType (Select d b _ se _)     = perhapsSubstTy d se (idType b)
275 contInputType (StrictBind b _ _ se _) = substTy se (idType b)
276 contInputType (StrictArg ai _ _)      = funArgTy (ai_type ai)
277 contInputType (ApplyTo d e se k)      = mkFunTy (perhapsSubstTy d se (exprType e)) (contInputType k)
278 contInputType (TickIt _ k)            = contInputType k
279
280 perhapsSubstTy :: DupFlag -> SimplEnv -> InType -> OutType
281 perhapsSubstTy dup_flag se ty
282   | isSimplified dup_flag = ty
283   | otherwise             = substTy se ty
284
285 -------------------
286 countValArgs :: SimplCont -> Int
287 countValArgs (ApplyTo _ (Type _) _ cont) = countValArgs cont
288 countValArgs (ApplyTo _ (Coercion _) _ cont) = countValArgs cont
289 countValArgs (ApplyTo _ _        _ cont) = 1 + countValArgs cont
290 countValArgs _                           = 0
291
292 countArgs :: SimplCont -> Int
293 countArgs (ApplyTo _ _ _ cont) = 1 + countArgs cont
294 countArgs _                    = 0
295
296 contArgs :: SimplCont -> (Bool, [ArgSummary], SimplCont)
297 -- Summarises value args, discards type args and coercions
298 -- The returned continuation of the call is only used to 
299 -- answer questions like "are you interesting?"
300 contArgs cont
301   | lone cont = (True, [], cont)
302   | otherwise = go [] cont
303   where
304     lone (ApplyTo {})  = False  -- See Note [Lone variables] in CoreUnfold
305     lone (CoerceIt {}) = False
306     lone _             = True
307
308     go args (ApplyTo _ arg se cont)
309       | isTypeArg arg         = go args                           cont
310       | otherwise             = go (is_interesting arg se : args) cont
311     go args (CoerceIt _ cont) = go args cont
312     go args cont              = (False, reverse args, cont)
313
314     is_interesting arg se = interestingArg (substExpr (text "contArgs") se arg)
315                    -- Do *not* use short-cutting substitution here
316                    -- because we want to get as much IdInfo as possible
317
318 pushSimplifiedArgs :: SimplEnv -> [CoreExpr] -> SimplCont -> SimplCont
319 pushSimplifiedArgs _env []         cont = cont
320 pushSimplifiedArgs env  (arg:args) cont = ApplyTo Simplified arg env (pushSimplifiedArgs env args cont)
321                    -- The env has an empty SubstEnv
322
323 dropArgs :: Int -> SimplCont -> SimplCont
324 dropArgs 0 cont = cont
325 dropArgs n (ApplyTo _ _ _ cont) = dropArgs (n-1) cont
326 dropArgs n other                = pprPanic "dropArgs" (ppr n <+> ppr other)
327 \end{code}
328
329
330 Note [Interesting call context]
331 ~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~
332 We want to avoid inlining an expression where there can't possibly be
333 any gain, such as in an argument position.  Hence, if the continuation
334 is interesting (eg. a case scrutinee, application etc.) then we
335 inline, otherwise we don't.
336
337 Previously some_benefit used to return True only if the variable was
338 applied to some value arguments.  This didn't work:
339
340         let x = _coerce_ (T Int) Int (I# 3) in
341         case _coerce_ Int (T Int) x of
342                 I# y -> ....
343
344 we want to inline x, but can't see that it's a constructor in a case
345 scrutinee position, and some_benefit is False.
346
347 Another example:
348
349 dMonadST = _/\_ t -> :Monad (g1 _@_ t, g2 _@_ t, g3 _@_ t)
350
351 ....  case dMonadST _@_ x0 of (a,b,c) -> ....
352
353 we'd really like to inline dMonadST here, but we *don't* want to
354 inline if the case expression is just
355
356         case x of y { DEFAULT -> ... }
357
358 since we can just eliminate this case instead (x is in WHNF).  Similar
359 applies when x is bound to a lambda expression.  Hence
360 contIsInteresting looks for case expressions with just a single
361 default case.
362
363
364 \begin{code}
365 interestingCallContext :: SimplCont -> CallCtxt
366 -- See Note [Interesting call context]
367 interestingCallContext cont
368   = interesting cont
369   where
370     interesting (Select _ _bndr _ _ _) = CaseCtxt
371
372     interesting (ApplyTo _ arg _ cont)
373         | isTypeArg arg = interesting cont
374         | otherwise     = ValAppCtxt    -- Can happen if we have (f Int |> co) y
375                                         -- If f has an INLINE prag we need to give it some
376                                         -- motivation to inline. See Note [Cast then apply]
377                                         -- in CoreUnfold
378
379     interesting (StrictArg _ cci _) = cci
380     interesting (StrictBind {})     = BoringCtxt
381     interesting (Stop _ cci)        = cci
382     interesting (TickIt _ cci)      = interesting cci
383     interesting (CoerceIt _ cont)   = interesting cont
384         -- If this call is the arg of a strict function, the context
385         -- is a bit interesting.  If we inline here, we may get useful
386         -- evaluation information to avoid repeated evals: e.g.
387         --      x + (y * z)
388         -- Here the contIsInteresting makes the '*' keener to inline,
389         -- which in turn exposes a constructor which makes the '+' inline.
390         -- Assuming that +,* aren't small enough to inline regardless.
391         --
392         -- It's also very important to inline in a strict context for things
393         -- like
394         --              foldr k z (f x)
395         -- Here, the context of (f x) is strict, and if f's unfolding is
396         -- a build it's *great* to inline it here.  So we must ensure that
397         -- the context for (f x) is not totally uninteresting.
398
399
400 -------------------
401 mkArgInfo :: Id
402           -> [CoreRule] -- Rules for function
403           -> Int        -- Number of value args
404           -> SimplCont  -- Context of the call
405           -> ArgInfo
406
407 mkArgInfo fun rules n_val_args call_cont
408   | n_val_args < idArity fun            -- Note [Unsaturated functions]
409   = ArgInfo { ai_fun = fun, ai_args = [], ai_type = fun_ty
410             , ai_rules = rules, ai_encl = False
411             , ai_strs = vanilla_stricts
412             , ai_discs = vanilla_discounts }
413   | otherwise
414   = ArgInfo { ai_fun = fun, ai_args = [], ai_type = fun_ty
415             , ai_rules = rules
416             , ai_encl = interestingArgContext rules call_cont
417             , ai_strs  = add_type_str fun_ty arg_stricts
418             , ai_discs = arg_discounts }
419   where
420     fun_ty = idType fun
421
422     vanilla_discounts, arg_discounts :: [Int]
423     vanilla_discounts = repeat 0
424     arg_discounts = case idUnfolding fun of
425                         CoreUnfolding {uf_guidance = UnfIfGoodArgs {ug_args = discounts}}
426                               -> discounts ++ vanilla_discounts
427                         _     -> vanilla_discounts
428
429     vanilla_stricts, arg_stricts :: [Bool]
430     vanilla_stricts  = repeat False
431
432     arg_stricts
433       = case splitStrictSig (idStrictness fun) of
434           (demands, result_info)
435                 | not (demands `lengthExceeds` n_val_args)
436                 ->      -- Enough args, use the strictness given.
437                         -- For bottoming functions we used to pretend that the arg
438                         -- is lazy, so that we don't treat the arg as an
439                         -- interesting context.  This avoids substituting
440                         -- top-level bindings for (say) strings into
441                         -- calls to error.  But now we are more careful about
442                         -- inlining lone variables, so its ok (see SimplUtils.analyseCont)
443                    if isBotRes result_info then
444                         map isStrictDmd demands         -- Finite => result is bottom
445                    else
446                         map isStrictDmd demands ++ vanilla_stricts
447                | otherwise
448                -> WARN( True, text "More demands than arity" <+> ppr fun <+> ppr (idArity fun)
449                                 <+> ppr n_val_args <+> ppr demands )
450                    vanilla_stricts      -- Not enough args, or no strictness
451
452     add_type_str :: Type -> [Bool] -> [Bool]
453     -- If the function arg types are strict, record that in the 'strictness bits'
454     -- No need to instantiate because unboxed types (which dominate the strict
455     -- types) can't instantiate type variables.
456     -- add_type_str is done repeatedly (for each call); might be better
457     -- once-for-all in the function
458     -- But beware primops/datacons with no strictness
459     add_type_str _ [] = []
460     add_type_str fun_ty strs            -- Look through foralls
461         | Just (_, fun_ty') <- splitForAllTy_maybe fun_ty       -- Includes coercions
462         = add_type_str fun_ty' strs
463     add_type_str fun_ty (str:strs)      -- Add strict-type info
464         | Just (arg_ty, fun_ty') <- splitFunTy_maybe fun_ty
465         = (str || isStrictType arg_ty) : add_type_str fun_ty' strs
466     add_type_str _ strs
467         = strs
468
469 {- Note [Unsaturated functions]
470   ~~~~~~~~~~~~~~~~~~~~~~~~~~~~~
471 Consider (test eyeball/inline4)
472         x = a:as
473         y = f x
474 where f has arity 2.  Then we do not want to inline 'x', because
475 it'll just be floated out again.  Even if f has lots of discounts
476 on its first argument -- it must be saturated for these to kick in
477 -}
478
479 interestingArgContext :: [CoreRule] -> SimplCont -> Bool
480 -- If the argument has form (f x y), where x,y are boring,
481 -- and f is marked INLINE, then we don't want to inline f.
482 -- But if the context of the argument is
483 --      g (f x y)
484 -- where g has rules, then we *do* want to inline f, in case it
485 -- exposes a rule that might fire.  Similarly, if the context is
486 --      h (g (f x x))
487 -- where h has rules, then we do want to inline f; hence the
488 -- call_cont argument to interestingArgContext
489 --
490 -- The ai-rules flag makes this happen; if it's
491 -- set, the inliner gets just enough keener to inline f
492 -- regardless of how boring f's arguments are, if it's marked INLINE
493 --
494 -- The alternative would be to *always* inline an INLINE function,
495 -- regardless of how boring its context is; but that seems overkill
496 -- For example, it'd mean that wrapper functions were always inlined
497 interestingArgContext rules call_cont
498   = notNull rules || enclosing_fn_has_rules
499   where
500     enclosing_fn_has_rules = go call_cont
501
502     go (Select {})         = False
503     go (ApplyTo {})        = False
504     go (StrictArg _ cci _) = interesting cci
505     go (StrictBind {})     = False      -- ??
506     go (CoerceIt _ c)      = go c
507     go (Stop _ cci)        = interesting cci
508     go (TickIt _ c)        = go c
509
510     interesting RuleArgCtxt = True
511     interesting _           = False
512 \end{code}
513
514
515 %************************************************************************
516 %*                                                                      *
517                   SimplifierMode
518 %*                                                                      *
519 %************************************************************************
520
521 The SimplifierMode controls several switches; see its definition in
522 CoreMonad
523         sm_rules      :: Bool     -- Whether RULES are enabled
524         sm_inline     :: Bool     -- Whether inlining is enabled
525         sm_case_case  :: Bool     -- Whether case-of-case is enabled
526         sm_eta_expand :: Bool     -- Whether eta-expansion is enabled
527
528 \begin{code}
529 simplEnvForGHCi :: DynFlags -> SimplEnv
530 simplEnvForGHCi dflags
531   = mkSimplEnv $ SimplMode { sm_names = ["GHCi"]
532                            , sm_phase = InitialPhase
533                            , sm_rules = rules_on
534                            , sm_inline = False
535                            , sm_eta_expand = eta_expand_on
536                            , sm_case_case = True }
537   where
538     rules_on      = gopt Opt_EnableRewriteRules   dflags
539     eta_expand_on = gopt Opt_DoLambdaEtaExpansion dflags
540    -- Do not do any inlining, in case we expose some unboxed
541    -- tuple stuff that confuses the bytecode interpreter
542
543 updModeForInlineRules :: Activation -> SimplifierMode -> SimplifierMode
544 -- See Note [Simplifying inside InlineRules]
545 updModeForInlineRules inline_rule_act current_mode
546   = current_mode { sm_phase = phaseFromActivation inline_rule_act
547                  , sm_inline = True
548                  , sm_eta_expand = False }
549                  -- For sm_rules, just inherit; sm_rules might be "off"
550                  -- because of -fno-enable-rewrite-rules
551   where
552     phaseFromActivation (ActiveAfter n) = Phase n
553     phaseFromActivation _               = InitialPhase
554 \end{code}
555
556 Note [Inlining in gentle mode]
557 ~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~
558 Something is inlined if
559    (i)   the sm_inline flag is on, AND
560    (ii)  the thing has an INLINE pragma, AND
561    (iii) the thing is inlinable in the earliest phase.
562
563 Example of why (iii) is important:
564   {-# INLINE [~1] g #-}
565   g = ...
566
567   {-# INLINE f #-}
568   f x = g (g x)
569
570 If we were to inline g into f's inlining, then an importing module would
571 never be able to do
572         f e --> g (g e) ---> RULE fires
573 because the InlineRule for f has had g inlined into it.
574
575 On the other hand, it is bad not to do ANY inlining into an
576 InlineRule, because then recursive knots in instance declarations
577 don't get unravelled.
578
579 However, *sometimes* SimplGently must do no call-site inlining at all
580 (hence sm_inline = False).  Before full laziness we must be careful
581 not to inline wrappers, because doing so inhibits floating
582     e.g. ...(case f x of ...)...
583     ==> ...(case (case x of I# x# -> fw x#) of ...)...
584     ==> ...(case x of I# x# -> case fw x# of ...)...
585 and now the redex (f x) isn't floatable any more.
586
587 The no-inlining thing is also important for Template Haskell.  You might be
588 compiling in one-shot mode with -O2; but when TH compiles a splice before
589 running it, we don't want to use -O2.  Indeed, we don't want to inline
590 anything, because the byte-code interpreter might get confused about
591 unboxed tuples and suchlike.
592
593 Note [Simplifying inside InlineRules]
594 ~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~
595 We must take care with simplification inside InlineRules (which come from
596 INLINE pragmas).
597
598 First, consider the following example
599         let f = \pq -> BIG
600         in
601         let g = \y -> f y y
602             {-# INLINE g #-}
603         in ...g...g...g...g...g...
604 Now, if that's the ONLY occurrence of f, it might be inlined inside g,
605 and thence copied multiple times when g is inlined. HENCE we treat
606 any occurrence in an InlineRule as a multiple occurrence, not a single
607 one; see OccurAnal.addRuleUsage.
608
609 Second, we do want *do* to some modest rules/inlining stuff in InlineRules,
610 partly to eliminate senseless crap, and partly to break the recursive knots
611 generated by instance declarations.
612
613 However, suppose we have
614         {-# INLINE <act> f #-}
615         f = <rhs>
616 meaning "inline f in phases p where activation <act>(p) holds".
617 Then what inlinings/rules can we apply to the copy of <rhs> captured in
618 f's InlineRule?  Our model is that literally <rhs> is substituted for
619 f when it is inlined.  So our conservative plan (implemented by
620 updModeForInlineRules) is this:
621
622   -------------------------------------------------------------
623   When simplifying the RHS of an InlineRule, set the phase to the
624   phase in which the InlineRule first becomes active
625   -------------------------------------------------------------
626
627 That ensures that
628
629   a) Rules/inlinings that *cease* being active before p will
630      not apply to the InlineRule rhs, consistent with it being
631      inlined in its *original* form in phase p.
632
633   b) Rules/inlinings that only become active *after* p will
634      not apply to the InlineRule rhs, again to be consistent with
635      inlining the *original* rhs in phase p.
636
637 For example,
638         {-# INLINE f #-}
639         f x = ...g...
640
641         {-# NOINLINE [1] g #-}
642         g y = ...
643
644         {-# RULE h g = ... #-}
645 Here we must not inline g into f's RHS, even when we get to phase 0,
646 because when f is later inlined into some other module we want the
647 rule for h to fire.
648
649 Similarly, consider
650         {-# INLINE f #-}
651         f x = ...g...
652
653         g y = ...
654 and suppose that there are auto-generated specialisations and a strictness
655 wrapper for g.  The specialisations get activation AlwaysActive, and the
656 strictness wrapper get activation (ActiveAfter 0).  So the strictness
657 wrepper fails the test and won't be inlined into f's InlineRule. That
658 means f can inline, expose the specialised call to g, so the specialisation
659 rules can fire.
660
661 A note about wrappers
662 ~~~~~~~~~~~~~~~~~~~~~
663 It's also important not to inline a worker back into a wrapper.
664 A wrapper looks like
665         wraper = inline_me (\x -> ...worker... )
666 Normally, the inline_me prevents the worker getting inlined into
667 the wrapper (initially, the worker's only call site!).  But,
668 if the wrapper is sure to be called, the strictness analyser will
669 mark it 'demanded', so when the RHS is simplified, it'll get an ArgOf
670 continuation.
671
672 \begin{code}
673 activeUnfolding :: SimplEnv -> Id -> Bool
674 activeUnfolding env
675   | not (sm_inline mode) = active_unfolding_minimal
676   | otherwise            = case sm_phase mode of
677                              InitialPhase -> active_unfolding_gentle
678                              Phase n      -> active_unfolding n
679   where
680     mode = getMode env
681
682 getUnfoldingInRuleMatch :: SimplEnv -> InScopeEnv
683 -- When matching in RULE, we want to "look through" an unfolding
684 -- (to see a constructor) if *rules* are on, even if *inlinings*
685 -- are not.  A notable example is DFuns, which really we want to
686 -- match in rules like (op dfun) in gentle mode. Another example
687 -- is 'otherwise' which we want exprIsConApp_maybe to be able to
688 -- see very early on
689 getUnfoldingInRuleMatch env
690   = (in_scope, id_unf)
691   where
692     in_scope = seInScope env
693     mode = getMode env
694     id_unf id | unf_is_active id = idUnfolding id
695               | otherwise        = NoUnfolding
696     unf_is_active id
697      | not (sm_rules mode) = active_unfolding_minimal id
698      | otherwise           = isActive (sm_phase mode) (idInlineActivation id)
699
700 active_unfolding_minimal :: Id -> Bool
701 -- Compuslory unfoldings only
702 -- Ignore SimplGently, because we want to inline regardless;
703 -- the Id has no top-level binding at all
704 --
705 -- NB: we used to have a second exception, for data con wrappers.
706 -- On the grounds that we use gentle mode for rule LHSs, and
707 -- they match better when data con wrappers are inlined.
708 -- But that only really applies to the trivial wrappers (like (:)),
709 -- and they are now constructed as Compulsory unfoldings (in MkId)
710 -- so they'll happen anyway.
711 active_unfolding_minimal id = isCompulsoryUnfolding (realIdUnfolding id)
712
713 active_unfolding :: PhaseNum -> Id -> Bool
714 active_unfolding n id = isActiveIn n (idInlineActivation id)
715
716 active_unfolding_gentle :: Id -> Bool
717 -- Anything that is early-active
718 -- See Note [Gentle mode]
719 active_unfolding_gentle id
720   =  isInlinePragma prag
721   && isEarlyActive (inlinePragmaActivation prag)
722        -- NB: wrappers are not early-active
723   where
724     prag = idInlinePragma id
725
726 ----------------------
727 activeRule :: SimplEnv -> Activation -> Bool
728 -- Nothing => No rules at all
729 activeRule env
730   | not (sm_rules mode) = \_ -> False     -- Rewriting is off
731   | otherwise           = isActive (sm_phase mode)
732   where
733     mode = getMode env
734 \end{code}
735
736
737
738 %************************************************************************
739 %*                                                                      *
740                   preInlineUnconditionally
741 %*                                                                      *
742 %************************************************************************
743
744 preInlineUnconditionally
745 ~~~~~~~~~~~~~~~~~~~~~~~~
746 @preInlineUnconditionally@ examines a bndr to see if it is used just
747 once in a completely safe way, so that it is safe to discard the
748 binding inline its RHS at the (unique) usage site, REGARDLESS of how
749 big the RHS might be.  If this is the case we don't simplify the RHS
750 first, but just inline it un-simplified.
751
752 This is much better than first simplifying a perhaps-huge RHS and then
753 inlining and re-simplifying it.  Indeed, it can be at least quadratically
754 better.  Consider
755
756         x1 = e1
757         x2 = e2[x1]
758         x3 = e3[x2]
759         ...etc...
760         xN = eN[xN-1]
761
762 We may end up simplifying e1 N times, e2 N-1 times, e3 N-3 times etc.
763 This can happen with cascades of functions too:
764
765         f1 = \x1.e1
766         f2 = \xs.e2[f1]
767         f3 = \xs.e3[f3]
768         ...etc...
769
770 THE MAIN INVARIANT is this:
771
772         ----  preInlineUnconditionally invariant -----
773    IF preInlineUnconditionally chooses to inline x = <rhs>
774    THEN doing the inlining should not change the occurrence
775         info for the free vars of <rhs>
776         ----------------------------------------------
777
778 For example, it's tempting to look at trivial binding like
779         x = y
780 and inline it unconditionally.  But suppose x is used many times,
781 but this is the unique occurrence of y.  Then inlining x would change
782 y's occurrence info, which breaks the invariant.  It matters: y
783 might have a BIG rhs, which will now be dup'd at every occurrenc of x.
784
785
786 Even RHSs labelled InlineMe aren't caught here, because there might be
787 no benefit from inlining at the call site.
788
789 [Sept 01] Don't unconditionally inline a top-level thing, because that
790 can simply make a static thing into something built dynamically.  E.g.
791         x = (a,b)
792         main = \s -> h x
793
794 [Remember that we treat \s as a one-shot lambda.]  No point in
795 inlining x unless there is something interesting about the call site.
796
797 But watch out: if you aren't careful, some useful foldr/build fusion
798 can be lost (most notably in spectral/hartel/parstof) because the
799 foldr didn't see the build.  Doing the dynamic allocation isn't a big
800 deal, in fact, but losing the fusion can be.  But the right thing here
801 seems to be to do a callSiteInline based on the fact that there is
802 something interesting about the call site (it's strict).  Hmm.  That
803 seems a bit fragile.
804
805 Conclusion: inline top level things gaily until Phase 0 (the last
806 phase), at which point don't.
807
808 Note [pre/postInlineUnconditionally in gentle mode]
809 ~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~
810 Even in gentle mode we want to do preInlineUnconditionally.  The
811 reason is that too little clean-up happens if you don't inline
812 use-once things.  Also a bit of inlining is *good* for full laziness;
813 it can expose constant sub-expressions.  Example in
814 spectral/mandel/Mandel.hs, where the mandelset function gets a useful
815 let-float if you inline windowToViewport
816
817 However, as usual for Gentle mode, do not inline things that are
818 inactive in the intial stages.  See Note [Gentle mode].
819
820 Note [InlineRule and preInlineUnconditionally]
821 ~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~
822 Surprisingly, do not pre-inline-unconditionally Ids with INLINE pragmas!
823 Example
824
825    {-# INLINE f #-}
826    f :: Eq a => a -> a
827    f x = ...
828
829    fInt :: Int -> Int
830    fInt = f Int dEqInt
831
832    ...fInt...fInt...fInt...
833
834 Here f occurs just once, in the RHS of f1. But if we inline it there
835 we'll lose the opportunity to inline at each of fInt's call sites.
836 The INLINE pragma will only inline when the application is saturated
837 for exactly this reason; and we don't want PreInlineUnconditionally
838 to second-guess it.  A live example is Trac #3736.
839     c.f. Note [InlineRule and postInlineUnconditionally]
840
841 Note [Top-level botomming Ids]
842 ~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~
843 Don't inline top-level Ids that are bottoming, even if they are used just
844 once, because FloatOut has gone to some trouble to extract them out.
845 Inlining them won't make the program run faster!
846
847 Note [Do not inline CoVars unconditionally]
848 ~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~
849 Coercion variables appear inside coercions, and the RHS of a let-binding
850 is a term (not a coercion) so we can't necessarily inline the latter in
851 the former.
852
853 \begin{code}
854 preInlineUnconditionally :: DynFlags -> SimplEnv -> TopLevelFlag -> InId -> InExpr -> Bool
855 preInlineUnconditionally dflags env top_lvl bndr rhs
856   | not active                               = False
857   | isStableUnfolding (idUnfolding bndr)     = False -- Note [InlineRule and preInlineUnconditionally]
858   | isTopLevel top_lvl && isBottomingId bndr = False -- Note [Top-level bottoming Ids]
859   | not (gopt Opt_SimplPreInlining dflags)   = False
860   | isCoVar bndr                             = False -- Note [Do not inline CoVars unconditionally]
861   | otherwise = case idOccInfo bndr of
862                   IAmDead                    -> True -- Happens in ((\x.1) v)
863                   OneOcc in_lam True int_cxt -> try_once in_lam int_cxt
864                   _                          -> False
865   where
866     mode = getMode env
867     active = isActive (sm_phase mode) act
868              -- See Note [pre/postInlineUnconditionally in gentle mode]
869     act = idInlineActivation bndr
870     try_once in_lam int_cxt     -- There's one textual occurrence
871         | not in_lam = isNotTopLevel top_lvl || early_phase
872         | otherwise  = int_cxt && canInlineInLam rhs
873
874 -- Be very careful before inlining inside a lambda, because (a) we must not
875 -- invalidate occurrence information, and (b) we want to avoid pushing a
876 -- single allocation (here) into multiple allocations (inside lambda).
877 -- Inlining a *function* with a single *saturated* call would be ok, mind you.
878 --      || (if is_cheap && not (canInlineInLam rhs) then pprTrace "preinline" (ppr bndr <+> ppr rhs) ok else ok)
879 --      where
880 --              is_cheap = exprIsCheap rhs
881 --              ok = is_cheap && int_cxt
882
883         --      int_cxt         The context isn't totally boring
884         -- E.g. let f = \ab.BIG in \y. map f xs
885         --      Don't want to substitute for f, because then we allocate
886         --      its closure every time the \y is called
887         -- But: let f = \ab.BIG in \y. map (f y) xs
888         --      Now we do want to substitute for f, even though it's not
889         --      saturated, because we're going to allocate a closure for
890         --      (f y) every time round the loop anyhow.
891
892         -- canInlineInLam => free vars of rhs are (Once in_lam) or Many,
893         -- so substituting rhs inside a lambda doesn't change the occ info.
894         -- Sadly, not quite the same as exprIsHNF.
895     canInlineInLam (Lit _)              = True
896     canInlineInLam (Lam b e)            = isRuntimeVar b || canInlineInLam e
897     canInlineInLam _                    = False
898       -- not ticks.  Counting ticks cannot be duplicated, and non-counting
899       -- ticks around a Lam will disappear anyway.
900
901     early_phase = case sm_phase mode of
902                     Phase 0 -> False
903                     _       -> True
904 -- If we don't have this early_phase test, consider
905 --      x = length [1,2,3]
906 -- The full laziness pass carefully floats all the cons cells to
907 -- top level, and preInlineUnconditionally floats them all back in.
908 -- Result is (a) static allocation replaced by dynamic allocation
909 --           (b) many simplifier iterations because this tickles
910 --               a related problem; only one inlining per pass
911 --
912 -- On the other hand, I have seen cases where top-level fusion is
913 -- lost if we don't inline top level thing (e.g. string constants)
914 -- Hence the test for phase zero (which is the phase for all the final
915 -- simplifications).  Until phase zero we take no special notice of
916 -- top level things, but then we become more leery about inlining
917 -- them.
918
919 \end{code}
920
921 %************************************************************************
922 %*                                                                      *
923                   postInlineUnconditionally
924 %*                                                                      *
925 %************************************************************************
926
927 postInlineUnconditionally
928 ~~~~~~~~~~~~~~~~~~~~~~~~~
929 @postInlineUnconditionally@ decides whether to unconditionally inline
930 a thing based on the form of its RHS; in particular if it has a
931 trivial RHS.  If so, we can inline and discard the binding altogether.
932
933 NB: a loop breaker has must_keep_binding = True and non-loop-breakers
934 only have *forward* references. Hence, it's safe to discard the binding
935
936 NOTE: This isn't our last opportunity to inline.  We're at the binding
937 site right now, and we'll get another opportunity when we get to the
938 ocurrence(s)
939
940 Note that we do this unconditional inlining only for trival RHSs.
941 Don't inline even WHNFs inside lambdas; doing so may simply increase
942 allocation when the function is called. This isn't the last chance; see
943 NOTE above.
944
945 NB: Even inline pragmas (e.g. IMustBeINLINEd) are ignored here Why?
946 Because we don't even want to inline them into the RHS of constructor
947 arguments. See NOTE above
948
949 NB: At one time even NOINLINE was ignored here: if the rhs is trivial
950 it's best to inline it anyway.  We often get a=E; b=a from desugaring,
951 with both a and b marked NOINLINE.  But that seems incompatible with
952 our new view that inlining is like a RULE, so I'm sticking to the 'active'
953 story for now.
954
955 \begin{code}
956 postInlineUnconditionally
957     :: DynFlags -> SimplEnv -> TopLevelFlag
958     -> OutId            -- The binder (an InId would be fine too)
959                         --            (*not* a CoVar)
960     -> OccInfo          -- From the InId
961     -> OutExpr
962     -> Unfolding
963     -> Bool
964 postInlineUnconditionally dflags env top_lvl bndr occ_info rhs unfolding
965   | not active                  = False
966   | isWeakLoopBreaker occ_info  = False -- If it's a loop-breaker of any kind, don't inline
967                                         -- because it might be referred to "earlier"
968   | isExportedId bndr           = False
969   | isStableUnfolding unfolding = False -- Note [InlineRule and postInlineUnconditionally]
970   | isTopLevel top_lvl          = False -- Note [Top level and postInlineUnconditionally]
971   | exprIsTrivial rhs           = True
972   | otherwise
973   = case occ_info of
974         -- The point of examining occ_info here is that for *non-values*
975         -- that occur outside a lambda, the call-site inliner won't have
976         -- a chance (because it doesn't know that the thing
977         -- only occurs once).   The pre-inliner won't have gotten
978         -- it either, if the thing occurs in more than one branch
979         -- So the main target is things like
980         --      let x = f y in
981         --      case v of
982         --         True  -> case x of ...
983         --         False -> case x of ...
984         -- This is very important in practice; e.g. wheel-seive1 doubles
985         -- in allocation if you miss this out
986       OneOcc in_lam _one_br int_cxt     -- OneOcc => no code-duplication issue
987         ->     smallEnoughToInline dflags unfolding     -- Small enough to dup
988                         -- ToDo: consider discount on smallEnoughToInline if int_cxt is true
989                         --
990                         -- NB: Do NOT inline arbitrarily big things, even if one_br is True
991                         -- Reason: doing so risks exponential behaviour.  We simplify a big
992                         --         expression, inline it, and simplify it again.  But if the
993                         --         very same thing happens in the big expression, we get
994                         --         exponential cost!
995                         -- PRINCIPLE: when we've already simplified an expression once,
996                         -- make sure that we only inline it if it's reasonably small.
997
998            && (not in_lam ||
999                         -- Outside a lambda, we want to be reasonably aggressive
1000                         -- about inlining into multiple branches of case
1001                         -- e.g. let x = <non-value>
1002                         --      in case y of { C1 -> ..x..; C2 -> ..x..; C3 -> ... }
1003                         -- Inlining can be a big win if C3 is the hot-spot, even if
1004                         -- the uses in C1, C2 are not 'interesting'
1005                         -- An example that gets worse if you add int_cxt here is 'clausify'
1006
1007                 (isCheapUnfolding unfolding && int_cxt))
1008                         -- isCheap => acceptable work duplication; in_lam may be true
1009                         -- int_cxt to prevent us inlining inside a lambda without some
1010                         -- good reason.  See the notes on int_cxt in preInlineUnconditionally
1011
1012       IAmDead -> True   -- This happens; for example, the case_bndr during case of
1013                         -- known constructor:  case (a,b) of x { (p,q) -> ... }
1014                         -- Here x isn't mentioned in the RHS, so we don't want to
1015                         -- create the (dead) let-binding  let x = (a,b) in ...
1016
1017       _ -> False
1018
1019 -- Here's an example that we don't handle well:
1020 --      let f = if b then Left (\x.BIG) else Right (\y.BIG)
1021 --      in \y. ....case f of {...} ....
1022 -- Here f is used just once, and duplicating the case work is fine (exprIsCheap).
1023 -- But
1024 --  - We can't preInlineUnconditionally because that woud invalidate
1025 --    the occ info for b.
1026 --  - We can't postInlineUnconditionally because the RHS is big, and
1027 --    that risks exponential behaviour
1028 --  - We can't call-site inline, because the rhs is big
1029 -- Alas!
1030
1031   where
1032     active = isActive (sm_phase (getMode env)) (idInlineActivation bndr)
1033         -- See Note [pre/postInlineUnconditionally in gentle mode]
1034 \end{code}
1035
1036 Note [Top level and postInlineUnconditionally]
1037 ~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~
1038 We don't do postInlineUnconditionally for top-level things (even for
1039 ones that are trivial):
1040
1041   * Doing so will inline top-level error expressions that have been
1042     carefully floated out by FloatOut.  More generally, it might
1043     replace static allocation with dynamic.
1044
1045   * Even for trivial expressions there's a problem.  Consider
1046       {-# RULE "foo" forall (xs::[T]). reverse xs = ruggle xs #-}
1047       blah xs = reverse xs
1048       ruggle = sort
1049     In one simplifier pass we might fire the rule, getting
1050       blah xs = ruggle xs
1051     but in *that* simplifier pass we must not do postInlineUnconditionally
1052     on 'ruggle' because then we'll have an unbound occurrence of 'ruggle'
1053
1054     If the rhs is trivial it'll be inlined by callSiteInline, and then
1055     the binding will be dead and discarded by the next use of OccurAnal
1056
1057   * There is less point, because the main goal is to get rid of local
1058     bindings used in multiple case branches.
1059
1060   * The inliner should inline trivial things at call sites anyway.
1061
1062 Note [InlineRule and postInlineUnconditionally]
1063 ~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~
1064 Do not do postInlineUnconditionally if the Id has an InlineRule, otherwise
1065 we lose the unfolding.  Example
1066
1067      -- f has InlineRule with rhs (e |> co)
1068      --   where 'e' is big
1069      f = e |> co
1070
1071 Then there's a danger we'll optimise to
1072
1073      f' = e
1074      f = f' |> co
1075
1076 and now postInlineUnconditionally, losing the InlineRule on f.  Now f'
1077 won't inline because 'e' is too big.
1078
1079     c.f. Note [InlineRule and preInlineUnconditionally]
1080
1081
1082 %************************************************************************
1083 %*                                                                      *
1084         Rebuilding a lambda
1085 %*                                                                      *
1086 %************************************************************************
1087
1088 \begin{code}
1089 mkLam :: [OutBndr] -> OutExpr -> SimplCont -> SimplM OutExpr
1090 -- mkLam tries three things
1091 --      a) eta reduction, if that gives a trivial expression
1092 --      b) eta expansion [only if there are some value lambdas]
1093
1094 mkLam [] body _cont
1095   = return body
1096 mkLam bndrs body cont
1097   = do  { dflags <- getDynFlags
1098         ; mkLam' dflags bndrs body }
1099   where
1100     mkLam' :: DynFlags -> [OutBndr] -> OutExpr -> SimplM OutExpr
1101     mkLam' dflags bndrs (Cast body co)
1102       | not (any bad bndrs)
1103         -- Note [Casts and lambdas]
1104       = do { lam <- mkLam' dflags bndrs body
1105            ; return (mkCast lam (mkPiCos Representational bndrs co)) }
1106       where
1107         co_vars  = tyCoVarsOfCo co
1108         bad bndr = isCoVar bndr && bndr `elemVarSet` co_vars
1109
1110     mkLam' dflags bndrs body@(Lam {})
1111       = mkLam' dflags (bndrs ++ bndrs1) body1
1112       where
1113         (bndrs1, body1) = collectBinders body
1114
1115     mkLam' dflags bndrs body
1116       | gopt Opt_DoEtaReduction dflags
1117       , Just etad_lam <- tryEtaReduce bndrs body
1118       = do { tick (EtaReduction (head bndrs))
1119            ; return etad_lam }
1120
1121       | not (contIsRhs cont)   -- See Note [Eta-expanding lambdas]
1122       , gopt Opt_DoLambdaEtaExpansion dflags
1123       , any isRuntimeVar bndrs
1124       , let body_arity = exprEtaExpandArity dflags body
1125       , body_arity > 0
1126       = do { tick (EtaExpansion (head bndrs))
1127            ; return (mkLams bndrs (etaExpand body_arity body)) }
1128
1129       | otherwise
1130       = return (mkLams bndrs body)
1131 \end{code}
1132
1133
1134 Note [Eta expanding lambdas]
1135 ~~~~~~~~~~~~~~~~~~~~~~~~~~~~
1136 In general we *do* want to eta-expand lambdas. Consider
1137    f (\x -> case x of (a,b) -> \s -> blah)
1138 where 's' is a state token, and hence can be eta expanded.  This
1139 showed up in the code for GHc.IO.Handle.Text.hPutChar, a rather
1140 important function!
1141
1142 The eta-expansion will never happen unless we do it now.  (Well, it's
1143 possible that CorePrep will do it, but CorePrep only has a half-baked
1144 eta-expander that can't deal with casts.  So it's much better to do it
1145 here.)
1146
1147 However, when the lambda is let-bound, as the RHS of a let, we have a
1148 better eta-expander (in the form of tryEtaExpandRhs), so we don't
1149 bother to try expansion in mkLam in that case; hence the contIsRhs
1150 guard.
1151
1152 Note [Casts and lambdas]
1153 ~~~~~~~~~~~~~~~~~~~~~~~~
1154 Consider
1155         (\x. (\y. e) `cast` g1) `cast` g2
1156 There is a danger here that the two lambdas look separated, and the
1157 full laziness pass might float an expression to between the two.
1158
1159 So this equation in mkLam' floats the g1 out, thus:
1160         (\x. e `cast` g1)  -->  (\x.e) `cast` (tx -> g1)
1161 where x:tx.
1162
1163 In general, this floats casts outside lambdas, where (I hope) they
1164 might meet and cancel with some other cast:
1165         \x. e `cast` co   ===>   (\x. e) `cast` (tx -> co)
1166         /\a. e `cast` co  ===>   (/\a. e) `cast` (/\a. co)
1167         /\g. e `cast` co  ===>   (/\g. e) `cast` (/\g. co)
1168                           (if not (g `in` co))
1169
1170 Notice that it works regardless of 'e'.  Originally it worked only
1171 if 'e' was itself a lambda, but in some cases that resulted in
1172 fruitless iteration in the simplifier.  A good example was when
1173 compiling Text.ParserCombinators.ReadPrec, where we had a definition
1174 like    (\x. Get `cast` g)
1175 where Get is a constructor with nonzero arity.  Then mkLam eta-expanded
1176 the Get, and the next iteration eta-reduced it, and then eta-expanded
1177 it again.
1178
1179 Note also the side condition for the case of coercion binders.
1180 It does not make sense to transform
1181         /\g. e `cast` g  ==>  (/\g.e) `cast` (/\g.g)
1182 because the latter is not well-kinded.
1183
1184 %************************************************************************
1185 %*                                                                      *
1186               Eta expansion
1187 %*                                                                      *
1188 %************************************************************************
1189
1190 \begin{code}
1191 tryEtaExpandRhs :: SimplEnv -> OutId -> OutExpr -> SimplM (Arity, OutExpr)
1192 -- See Note [Eta-expanding at let bindings]
1193 tryEtaExpandRhs env bndr rhs
1194   = do { dflags <- getDynFlags
1195        ; (new_arity, new_rhs) <- try_expand dflags
1196
1197        ; WARN( new_arity < old_id_arity,
1198                (ptext (sLit "Arity decrease:") <+> (ppr bndr <+> ppr old_id_arity
1199                 <+> ppr old_arity <+> ppr new_arity) $$ ppr new_rhs) )
1200                         -- Note [Arity decrease] in Simplify
1201          return (new_arity, new_rhs) }
1202   where
1203     try_expand dflags
1204       | exprIsTrivial rhs
1205       = return (exprArity rhs, rhs)
1206
1207       | sm_eta_expand (getMode env)      -- Provided eta-expansion is on
1208       , let new_arity1 = findRhsArity dflags bndr rhs old_arity
1209             new_arity2 = idCallArity bndr
1210             new_arity  = max new_arity1 new_arity2
1211       , new_arity > old_arity      -- And the current manifest arity isn't enough
1212       = do { tick (EtaExpansion bndr)
1213            ; return (new_arity, etaExpand new_arity rhs) }
1214       | otherwise
1215       = return (old_arity, rhs)
1216
1217     old_arity    = exprArity rhs -- See Note [Do not expand eta-expand PAPs]
1218     old_id_arity = idArity bndr
1219 \end{code}
1220
1221 Note [Eta-expanding at let bindings]
1222 ~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~
1223 We now eta expand at let-bindings, which is where the payoff comes.
1224 The most significant thing is that we can do a simple arity analysis
1225 (in CoreArity.findRhsArity), which we can't do for free-floating lambdas
1226
1227 One useful consequence of not eta-expanding lambdas is this example:
1228    genMap :: C a => ...
1229    {-# INLINE genMap #-}
1230    genMap f xs = ...
1231
1232    myMap :: D a => ...
1233    {-# INLINE myMap #-}
1234    myMap = genMap
1235
1236 Notice that 'genMap' should only inline if applied to two arguments.
1237 In the stable unfolding for myMap we'll have the unfolding
1238     (\d -> genMap Int (..d..))
1239 We do not want to eta-expand to
1240     (\d f xs -> genMap Int (..d..) f xs)
1241 because then 'genMap' will inline, and it really shouldn't: at least
1242 as far as the programmer is concerned, it's not applied to two
1243 arguments!
1244
1245 Note [Do not eta-expand PAPs]
1246 ~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~
1247 We used to have old_arity = manifestArity rhs, which meant that we
1248 would eta-expand even PAPs.  But this gives no particular advantage,
1249 and can lead to a massive blow-up in code size, exhibited by Trac #9020.  
1250 Suppose we have a PAP
1251     foo :: IO ()
1252     foo = returnIO ()
1253 Then we can eta-expand do
1254     foo = (\eta. (returnIO () |> sym g) eta) |> g
1255 where
1256     g :: IO () ~ State# RealWorld -> (# State# RealWorld, () #)
1257
1258 But there is really no point in doing this, and it generates masses of
1259 coercions and whatnot that eventually disappear again. For T9020, GHC
1260 allocated 6.6G beore, and 0.8G afterwards; and residency dropped from
1261 1.8G to 45M.
1262
1263 But note that this won't eta-expand, say
1264   f = \g -> map g
1265 Does it matter not eta-expanding such functions?  I'm not sure.  Perhaps
1266 strictness analysis will have less to bite on?
1267
1268
1269 %************************************************************************
1270 %*                                                                      *
1271 \subsection{Floating lets out of big lambdas}
1272 %*                                                                      *
1273 %************************************************************************
1274
1275 Note [Floating and type abstraction]
1276 ~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~
1277 Consider this:
1278         x = /\a. C e1 e2
1279 We'd like to float this to
1280         y1 = /\a. e1
1281         y2 = /\a. e2
1282         x  = /\a. C (y1 a) (y2 a)
1283 for the usual reasons: we want to inline x rather vigorously.
1284
1285 You may think that this kind of thing is rare.  But in some programs it is
1286 common.  For example, if you do closure conversion you might get:
1287
1288         data a :-> b = forall e. (e -> a -> b) :$ e
1289
1290         f_cc :: forall a. a :-> a
1291         f_cc = /\a. (\e. id a) :$ ()
1292
1293 Now we really want to inline that f_cc thing so that the
1294 construction of the closure goes away.
1295
1296 So I have elaborated simplLazyBind to understand right-hand sides that look
1297 like
1298         /\ a1..an. body
1299
1300 and treat them specially. The real work is done in SimplUtils.abstractFloats,
1301 but there is quite a bit of plumbing in simplLazyBind as well.
1302
1303 The same transformation is good when there are lets in the body:
1304
1305         /\abc -> let(rec) x = e in b
1306    ==>
1307         let(rec) x' = /\abc -> let x = x' a b c in e
1308         in
1309         /\abc -> let x = x' a b c in b
1310
1311 This is good because it can turn things like:
1312
1313         let f = /\a -> letrec g = ... g ... in g
1314 into
1315         letrec g' = /\a -> ... g' a ...
1316         in
1317         let f = /\ a -> g' a
1318
1319 which is better.  In effect, it means that big lambdas don't impede
1320 let-floating.
1321
1322 This optimisation is CRUCIAL in eliminating the junk introduced by
1323 desugaring mutually recursive definitions.  Don't eliminate it lightly!
1324
1325 [May 1999]  If we do this transformation *regardless* then we can
1326 end up with some pretty silly stuff.  For example,
1327
1328         let
1329             st = /\ s -> let { x1=r1 ; x2=r2 } in ...
1330         in ..
1331 becomes
1332         let y1 = /\s -> r1
1333             y2 = /\s -> r2
1334             st = /\s -> ...[y1 s/x1, y2 s/x2]
1335         in ..
1336
1337 Unless the "..." is a WHNF there is really no point in doing this.
1338 Indeed it can make things worse.  Suppose x1 is used strictly,
1339 and is of the form
1340
1341         x1* = case f y of { (a,b) -> e }
1342
1343 If we abstract this wrt the tyvar we then can't do the case inline
1344 as we would normally do.
1345
1346 That's why the whole transformation is part of the same process that
1347 floats let-bindings and constructor arguments out of RHSs.  In particular,
1348 it is guarded by the doFloatFromRhs call in simplLazyBind.
1349
1350
1351 \begin{code}
1352 abstractFloats :: [OutTyVar] -> SimplEnv -> OutExpr -> SimplM ([OutBind], OutExpr)
1353 abstractFloats main_tvs body_env body
1354   = ASSERT( notNull body_floats )
1355     do  { (subst, float_binds) <- mapAccumLM abstract empty_subst body_floats
1356         ; return (float_binds, CoreSubst.substExpr (text "abstract_floats1") subst body) }
1357   where
1358     main_tv_set = mkVarSet main_tvs
1359     body_floats = getFloatBinds body_env
1360     empty_subst = CoreSubst.mkEmptySubst (seInScope body_env)
1361
1362     abstract :: CoreSubst.Subst -> OutBind -> SimplM (CoreSubst.Subst, OutBind)
1363     abstract subst (NonRec id rhs)
1364       = do { (poly_id, poly_app) <- mk_poly tvs_here id
1365            ; let poly_rhs = mkLams tvs_here rhs'
1366                  subst'   = CoreSubst.extendIdSubst subst id poly_app
1367            ; return (subst', (NonRec poly_id poly_rhs)) }
1368       where
1369         rhs' = CoreSubst.substExpr (text "abstract_floats2") subst rhs
1370         tvs_here = varSetElemsKvsFirst (main_tv_set `intersectVarSet` exprSomeFreeVars isTyVar rhs')
1371
1372                 -- Abstract only over the type variables free in the rhs
1373                 -- wrt which the new binding is abstracted.  But the naive
1374                 -- approach of abstract wrt the tyvars free in the Id's type
1375                 -- fails. Consider:
1376                 --      /\ a b -> let t :: (a,b) = (e1, e2)
1377                 --                    x :: a     = fst t
1378                 --                in ...
1379                 -- Here, b isn't free in x's type, but we must nevertheless
1380                 -- abstract wrt b as well, because t's type mentions b.
1381                 -- Since t is floated too, we'd end up with the bogus:
1382                 --      poly_t = /\ a b -> (e1, e2)
1383                 --      poly_x = /\ a   -> fst (poly_t a *b*)
1384                 -- So for now we adopt the even more naive approach of
1385                 -- abstracting wrt *all* the tyvars.  We'll see if that
1386                 -- gives rise to problems.   SLPJ June 98
1387
1388     abstract subst (Rec prs)
1389        = do { (poly_ids, poly_apps) <- mapAndUnzipM (mk_poly tvs_here) ids
1390             ; let subst' = CoreSubst.extendSubstList subst (ids `zip` poly_apps)
1391                   poly_rhss = [mkLams tvs_here (CoreSubst.substExpr (text "abstract_floats3") subst' rhs)
1392                               | rhs <- rhss]
1393             ; return (subst', Rec (poly_ids `zip` poly_rhss)) }
1394        where
1395          (ids,rhss) = unzip prs
1396                 -- For a recursive group, it's a bit of a pain to work out the minimal
1397                 -- set of tyvars over which to abstract:
1398                 --      /\ a b c.  let x = ...a... in
1399                 --                 letrec { p = ...x...q...
1400                 --                          q = .....p...b... } in
1401                 --                 ...
1402                 -- Since 'x' is abstracted over 'a', the {p,q} group must be abstracted
1403                 -- over 'a' (because x is replaced by (poly_x a)) as well as 'b'.
1404                 -- Since it's a pain, we just use the whole set, which is always safe
1405                 --
1406                 -- If you ever want to be more selective, remember this bizarre case too:
1407                 --      x::a = x
1408                 -- Here, we must abstract 'x' over 'a'.
1409          tvs_here = sortQuantVars main_tvs
1410
1411     mk_poly tvs_here var
1412       = do { uniq <- getUniqueM
1413            ; let  poly_name = setNameUnique (idName var) uniq           -- Keep same name
1414                   poly_ty   = mkForAllTys tvs_here (idType var) -- But new type of course
1415                   poly_id   = transferPolyIdInfo var tvs_here $ -- Note [transferPolyIdInfo] in Id.lhs
1416                               mkLocalId poly_name poly_ty
1417            ; return (poly_id, mkTyApps (Var poly_id) (mkTyVarTys tvs_here)) }
1418                 -- In the olden days, it was crucial to copy the occInfo of the original var,
1419                 -- because we were looking at occurrence-analysed but as yet unsimplified code!
1420                 -- In particular, we mustn't lose the loop breakers.  BUT NOW we are looking
1421                 -- at already simplified code, so it doesn't matter
1422                 --
1423                 -- It's even right to retain single-occurrence or dead-var info:
1424                 -- Suppose we started with  /\a -> let x = E in B
1425                 -- where x occurs once in B. Then we transform to:
1426                 --      let x' = /\a -> E in /\a -> let x* = x' a in B
1427                 -- where x* has an INLINE prag on it.  Now, once x* is inlined,
1428                 -- the occurrences of x' will be just the occurrences originally
1429                 -- pinned on x.
1430 \end{code}
1431
1432 Note [Abstract over coercions]
1433 ~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~
1434 If a coercion variable (g :: a ~ Int) is free in the RHS, then so is the
1435 type variable a.  Rather than sort this mess out, we simply bale out and abstract
1436 wrt all the type variables if any of them are coercion variables.
1437
1438
1439 Historical note: if you use let-bindings instead of a substitution, beware of this:
1440
1441                 -- Suppose we start with:
1442                 --
1443                 --      x = /\ a -> let g = G in E
1444                 --
1445                 -- Then we'll float to get
1446                 --
1447                 --      x = let poly_g = /\ a -> G
1448                 --          in /\ a -> let g = poly_g a in E
1449                 --
1450                 -- But now the occurrence analyser will see just one occurrence
1451                 -- of poly_g, not inside a lambda, so the simplifier will
1452                 -- PreInlineUnconditionally poly_g back into g!  Badk to square 1!
1453                 -- (I used to think that the "don't inline lone occurrences" stuff
1454                 --  would stop this happening, but since it's the *only* occurrence,
1455                 --  PreInlineUnconditionally kicks in first!)
1456                 --
1457                 -- Solution: put an INLINE note on g's RHS, so that poly_g seems
1458                 --           to appear many times.  (NB: mkInlineMe eliminates
1459                 --           such notes on trivial RHSs, so do it manually.)
1460
1461 %************************************************************************
1462 %*                                                                      *
1463                 prepareAlts
1464 %*                                                                      *
1465 %************************************************************************
1466
1467 prepareAlts tries these things:
1468
1469 1.  Eliminate alternatives that cannot match, including the
1470     DEFAULT alternative.
1471
1472 2.  If the DEFAULT alternative can match only one possible constructor,
1473     then make that constructor explicit.
1474     e.g.
1475         case e of x { DEFAULT -> rhs }
1476      ===>
1477         case e of x { (a,b) -> rhs }
1478     where the type is a single constructor type.  This gives better code
1479     when rhs also scrutinises x or e.
1480
1481 3. Returns a list of the constructors that cannot holds in the
1482    DEFAULT alternative (if there is one)
1483
1484 Here "cannot match" includes knowledge from GADTs
1485
1486 It's a good idea to do this stuff before simplifying the alternatives, to
1487 avoid simplifying alternatives we know can't happen, and to come up with
1488 the list of constructors that are handled, to put into the IdInfo of the
1489 case binder, for use when simplifying the alternatives.
1490
1491 Eliminating the default alternative in (1) isn't so obvious, but it can
1492 happen:
1493
1494 data Colour = Red | Green | Blue
1495
1496 f x = case x of
1497         Red -> ..
1498         Green -> ..
1499         DEFAULT -> h x
1500
1501 h y = case y of
1502         Blue -> ..
1503         DEFAULT -> [ case y of ... ]
1504
1505 If we inline h into f, the default case of the inlined h can't happen.
1506 If we don't notice this, we may end up filtering out *all* the cases
1507 of the inner case y, which give us nowhere to go!
1508
1509 \begin{code}
1510 prepareAlts :: OutExpr -> OutId -> [InAlt] -> SimplM ([AltCon], [InAlt])
1511 -- The returned alternatives can be empty, none are possible
1512 prepareAlts scrut case_bndr' alts
1513            -- Case binder is needed just for its type. Note that as an
1514            --   OutId, it has maximum information; this is important.
1515            --   Test simpl013 is an example
1516   = do { us <- getUniquesM
1517        ; let (imposs_deflt_cons, refined_deflt, alts') 
1518                 = filterAlts us (varType case_bndr') imposs_cons alts
1519        ; when refined_deflt $ tick (FillInCaseDefault case_bndr')
1520  
1521        ; alts'' <- combineIdenticalAlts case_bndr' alts'
1522        ; return (imposs_deflt_cons, alts'') }
1523   where
1524     imposs_cons = case scrut of
1525                     Var v -> otherCons (idUnfolding v)
1526                     _     -> []
1527 \end{code}
1528
1529 Note [Combine identical alternatives]
1530 ~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~
1531  If several alternatives are identical, merge them into
1532  a single DEFAULT alternative.  I've occasionally seen this
1533  making a big difference:
1534
1535      case e of               =====>     case e of
1536        C _ -> f x                         D v -> ....v....
1537        D v -> ....v....                   DEFAULT -> f x
1538        DEFAULT -> f x
1539
1540 The point is that we merge common RHSs, at least for the DEFAULT case.
1541 [One could do something more elaborate but I've never seen it needed.]
1542 To avoid an expensive test, we just merge branches equal to the *first*
1543 alternative; this picks up the common cases
1544      a) all branches equal
1545      b) some branches equal to the DEFAULT (which occurs first)
1546
1547 The case where Combine Identical Alternatives transformation showed up
1548 was like this (base/Foreign/C/Err/Error.lhs):
1549
1550         x | p `is` 1 -> e1
1551           | p `is` 2 -> e2
1552         ...etc...
1553
1554 where @is@ was something like
1555
1556         p `is` n = p /= (-1) && p == n
1557
1558 This gave rise to a horrible sequence of cases
1559
1560         case p of
1561           (-1) -> $j p
1562           1    -> e1
1563           DEFAULT -> $j p
1564
1565 and similarly in cascade for all the join points!
1566
1567 NB: it's important that all this is done in [InAlt], *before* we work
1568 on the alternatives themselves, because Simpify.simplAlt may zap the
1569 occurrence info on the binders in the alternatives, which in turn
1570 defeats combineIdenticalAlts (see Trac #7360).
1571
1572 \begin{code}
1573 combineIdenticalAlts :: OutId -> [InAlt] -> SimplM [InAlt]
1574 -- See Note [Combine identical alternatives]
1575 combineIdenticalAlts case_bndr ((_con1,bndrs1,rhs1) : con_alts)
1576   | all isDeadBinder bndrs1                     -- Remember the default
1577   , length filtered_alts < length con_alts      -- alternative comes first
1578   = do  { tick (AltMerge case_bndr)
1579         ; return ((DEFAULT, [], rhs1) : filtered_alts) }
1580   where
1581     filtered_alts = filterOut identical_to_alt1 con_alts
1582     identical_to_alt1 (_con,bndrs,rhs) = all isDeadBinder bndrs && rhs `cheapEqExpr` rhs1
1583
1584 combineIdenticalAlts _ alts = return alts
1585 \end{code}
1586
1587
1588 %************************************************************************
1589 %*                                                                      *
1590                 mkCase
1591 %*                                                                      *
1592 %************************************************************************
1593
1594 mkCase tries these things
1595
1596 1.  Merge Nested Cases
1597
1598        case e of b {             ==>   case e of b {
1599          p1 -> rhs1                      p1 -> rhs1
1600          ...                             ...
1601          pm -> rhsm                      pm -> rhsm
1602          _  -> case b of b' {            pn -> let b'=b in rhsn
1603                      pn -> rhsn          ...
1604                      ...                 po -> let b'=b in rhso
1605                      po -> rhso          _  -> let b'=b in rhsd
1606                      _  -> rhsd
1607        }
1608
1609     which merges two cases in one case when -- the default alternative of
1610     the outer case scrutises the same variable as the outer case. This
1611     transformation is called Case Merging.  It avoids that the same
1612     variable is scrutinised multiple times.
1613
1614 2.  Eliminate Identity Case
1615
1616         case e of               ===> e
1617                 True  -> True;
1618                 False -> False
1619
1620     and similar friends.
1621
1622
1623 \begin{code}
1624 mkCase, mkCase1, mkCase2
1625    :: DynFlags
1626    -> OutExpr -> OutId
1627    -> OutType -> [OutAlt]               -- Alternatives in standard (increasing) order
1628    -> SimplM OutExpr
1629
1630 --------------------------------------------------
1631 --      1. Merge Nested Cases
1632 --------------------------------------------------
1633
1634 mkCase dflags scrut outer_bndr alts_ty ((DEFAULT, _, deflt_rhs) : outer_alts)
1635   | gopt Opt_CaseMerge dflags
1636   , Case (Var inner_scrut_var) inner_bndr _ inner_alts <- deflt_rhs
1637   , inner_scrut_var == outer_bndr
1638   = do  { tick (CaseMerge outer_bndr)
1639
1640         ; let wrap_alt (con, args, rhs) = ASSERT( outer_bndr `notElem` args )
1641                                           (con, args, wrap_rhs rhs)
1642                 -- Simplifier's no-shadowing invariant should ensure
1643                 -- that outer_bndr is not shadowed by the inner patterns
1644               wrap_rhs rhs = Let (NonRec inner_bndr (Var outer_bndr)) rhs
1645                 -- The let is OK even for unboxed binders,
1646
1647               wrapped_alts | isDeadBinder inner_bndr = inner_alts
1648                            | otherwise               = map wrap_alt inner_alts
1649
1650               merged_alts = mergeAlts outer_alts wrapped_alts
1651                 -- NB: mergeAlts gives priority to the left
1652                 --      case x of
1653                 --        A -> e1
1654                 --        DEFAULT -> case x of
1655                 --                      A -> e2
1656                 --                      B -> e3
1657                 -- When we merge, we must ensure that e1 takes
1658                 -- precedence over e2 as the value for A!
1659
1660         ; mkCase1 dflags scrut outer_bndr alts_ty merged_alts
1661         }
1662         -- Warning: don't call mkCase recursively!
1663         -- Firstly, there's no point, because inner alts have already had
1664         -- mkCase applied to them, so they won't have a case in their default
1665         -- Secondly, if you do, you get an infinite loop, because the bindCaseBndr
1666         -- in munge_rhs may put a case into the DEFAULT branch!
1667
1668 mkCase dflags scrut bndr alts_ty alts = mkCase1 dflags scrut bndr alts_ty alts
1669
1670 --------------------------------------------------
1671 --      2. Eliminate Identity Case
1672 --------------------------------------------------
1673
1674 mkCase1 _dflags scrut case_bndr _ alts@((_,_,rhs1) : _)      -- Identity case
1675   | all identity_alt alts
1676   = do { tick (CaseIdentity case_bndr)
1677        ; return (re_cast scrut rhs1) }
1678   where
1679     identity_alt (con, args, rhs) = check_eq rhs con args
1680
1681     check_eq (Cast rhs co) con args         = not (any (`elemVarSet` tyCoVarsOfCo co) args)
1682         {- See Note [RHS casts] -}            && check_eq rhs con args
1683     check_eq (Lit lit) (LitAlt lit') _      = lit == lit'
1684     check_eq (Var v)   _ _ | v == case_bndr = True
1685     check_eq (Var v)   (DataAlt con) []     = v == dataConWorkId con   -- Optimisation only
1686     check_eq rhs       (DataAlt con) args   = rhs `cheapEqExpr` mkConApp con (arg_tys ++ varsToCoreExprs args)
1687     check_eq _ _ _ = False
1688
1689     arg_tys = map Type (tyConAppArgs (idType case_bndr))
1690
1691         -- Note [RHS casts]
1692         -- ~~~~~~~~~~~~~~~~
1693         -- We've seen this:
1694         --      case e of x { _ -> x `cast` c }
1695         -- And we definitely want to eliminate this case, to give
1696         --      e `cast` c
1697         -- So we throw away the cast from the RHS, and reconstruct
1698         -- it at the other end.  All the RHS casts must be the same
1699         -- if (all identity_alt alts) holds.
1700         --
1701         -- Don't worry about nested casts, because the simplifier combines them
1702
1703     re_cast scrut (Cast rhs co) = Cast (re_cast scrut rhs) co
1704     re_cast scrut _             = scrut
1705
1706 mkCase1 dflags scrut bndr alts_ty alts = mkCase2 dflags scrut bndr alts_ty alts
1707
1708 --------------------------------------------------
1709 --      Catch-all
1710 --------------------------------------------------
1711 mkCase2 _dflags scrut bndr alts_ty alts
1712   = return (Case scrut bndr alts_ty alts)
1713 \end{code}
1714
1715 Note [Dead binders]
1716 ~~~~~~~~~~~~~~~~~~~~
1717 Note that dead-ness is maintained by the simplifier, so that it is
1718 accurate after simplification as well as before.
1719
1720
1721 Note [Cascading case merge]
1722 ~~~~~~~~~~~~~~~~~~~~~~~~~~~
1723 Case merging should cascade in one sweep, because it
1724 happens bottom-up
1725
1726       case e of a {
1727         DEFAULT -> case a of b
1728                       DEFAULT -> case b of c {
1729                                      DEFAULT -> e
1730                                      A -> ea
1731                       B -> eb
1732         C -> ec
1733 ==>
1734       case e of a {
1735         DEFAULT -> case a of b
1736                       DEFAULT -> let c = b in e
1737                       A -> let c = b in ea
1738                       B -> eb
1739         C -> ec
1740 ==>
1741       case e of a {
1742         DEFAULT -> let b = a in let c = b in e
1743         A -> let b = a in let c = b in ea
1744         B -> let b = a in eb
1745         C -> ec
1746
1747
1748 However here's a tricky case that we still don't catch, and I don't
1749 see how to catch it in one pass:
1750
1751   case x of c1 { I# a1 ->
1752   case a1 of c2 ->
1753     0 -> ...
1754     DEFAULT -> case x of c3 { I# a2 ->
1755                case a2 of ...
1756
1757 After occurrence analysis (and its binder-swap) we get this
1758
1759   case x of c1 { I# a1 ->
1760   let x = c1 in         -- Binder-swap addition
1761   case a1 of c2 ->
1762     0 -> ...
1763     DEFAULT -> case x of c3 { I# a2 ->
1764                case a2 of ...
1765
1766 When we simplify the inner case x, we'll see that
1767 x=c1=I# a1.  So we'll bind a2 to a1, and get
1768
1769   case x of c1 { I# a1 ->
1770   case a1 of c2 ->
1771     0 -> ...
1772     DEFAULT -> case a1 of ...
1773
1774 This is corect, but we can't do a case merge in this sweep
1775 because c2 /= a1.  Reason: the binding c1=I# a1 went inwards
1776 without getting changed to c1=I# c2.
1777
1778 I don't think this is worth fixing, even if I knew how. It'll
1779 all come out in the next pass anyway.
1780
1781