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