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