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