compiler/simplCore/Simplify.lhs

   1 %
   2 % (c) The AQUA Project, Glasgow University, 1993-1998
   3 %
   4 \section[Simplify]{The main module of the simplifier}
   5
   6 \begin{code}
   7 module Simplify ( simplTopBinds, simplExpr ) where
   8
   9 #include "HsVersions.h"
  10
  11 import DynFlags
  12 import SimplMonad
  13 import Type hiding      ( substTy, extendTvSubst )
  14 import SimplEnv
  15 import SimplUtils
  16 import MkId             ( rUNTIME_ERROR_ID )
  17 import FamInstEnv       ( FamInstEnv )
  18 import Id
  19 import Var
  20 import IdInfo
  21 import Coercion
  22 import FamInstEnv       ( topNormaliseType )
  23 import DataCon          ( dataConRepStrictness, dataConUnivTyVars )
  24 import CoreSyn
  25 import NewDemand        ( isStrictDmd, splitStrictSig )
  26 import PprCore          ( pprParendExpr, pprCoreExpr )
  27 import CoreUnfold       ( mkUnfolding, callSiteInline, CallCtxt(..) )
  28 import CoreUtils
  29 import Rules            ( lookupRule, getRules )
  30 import BasicTypes       ( isMarkedStrict )
  31 import CostCentre       ( currentCCS )
  32 import TysPrim          ( realWorldStatePrimTy )
  33 import PrelInfo         ( realWorldPrimId )
  34 import BasicTypes       ( TopLevelFlag(..), isTopLevel,
  35                           RecFlag(..), isNonRuleLoopBreaker )
  36 import Maybes           ( orElse )
  37 import Data.List        ( mapAccumL )
  38 import MonadUtils       ( foldlM )
  39 import StaticFlags      ( opt_PassCaseBndrToJoinPoints )
  40 import Outputable
  41 import FastString
  42 \end{code}
  43
  44
  45 The guts of the simplifier is in this module, but the driver loop for
  46 the simplifier is in SimplCore.lhs.
  47
  48
  49 -----------------------------------------
  50         *** IMPORTANT NOTE ***
  51 -----------------------------------------
  52 The simplifier used to guarantee that the output had no shadowing, but
  53 it does not do so any more.   (Actually, it never did!)  The reason is
  54 documented with simplifyArgs.
  55
  56
  57 -----------------------------------------
  58         *** IMPORTANT NOTE ***
  59 -----------------------------------------
  60 Many parts of the simplifier return a bunch of "floats" as well as an
  61 expression. This is wrapped as a datatype SimplUtils.FloatsWith.
  62
  63 All "floats" are let-binds, not case-binds, but some non-rec lets may
  64 be unlifted (with RHS ok-for-speculation).
  65
  66
  67
  68 -----------------------------------------
  69         ORGANISATION OF FUNCTIONS
  70 -----------------------------------------
  71 simplTopBinds
  72   - simplify all top-level binders
  73   - for NonRec, call simplRecOrTopPair
  74   - for Rec,    call simplRecBind
  75
  76
  77         ------------------------------
  78 simplExpr (applied lambda)      ==> simplNonRecBind
  79 simplExpr (Let (NonRec ...) ..) ==> simplNonRecBind
  80 simplExpr (Let (Rec ...)    ..) ==> simplify binders; simplRecBind
  81
  82         ------------------------------
  83 simplRecBind    [binders already simplfied]
  84   - use simplRecOrTopPair on each pair in turn
  85
  86 simplRecOrTopPair [binder already simplified]
  87   Used for: recursive bindings (top level and nested)
  88             top-level non-recursive bindings
  89   Returns:
  90   - check for PreInlineUnconditionally
  91   - simplLazyBind
  92
  93 simplNonRecBind
  94   Used for: non-top-level non-recursive bindings
  95             beta reductions (which amount to the same thing)
  96   Because it can deal with strict arts, it takes a
  97         "thing-inside" and returns an expression
  98
  99   - check for PreInlineUnconditionally
 100   - simplify binder, including its IdInfo
 101   - if strict binding
 102         simplStrictArg
 103         mkAtomicArgs
 104         completeNonRecX
 105     else
 106         simplLazyBind
 107         addFloats
 108
 109 simplNonRecX:   [given a *simplified* RHS, but an *unsimplified* binder]
 110   Used for: binding case-binder and constr args in a known-constructor case
 111   - check for PreInLineUnconditionally
 112   - simplify binder
 113   - completeNonRecX
 114
 115         ------------------------------
 116 simplLazyBind:  [binder already simplified, RHS not]
 117   Used for: recursive bindings (top level and nested)
 118             top-level non-recursive bindings
 119             non-top-level, but *lazy* non-recursive bindings
 120         [must not be strict or unboxed]
 121   Returns floats + an augmented environment, not an expression
 122   - substituteIdInfo and add result to in-scope
 123         [so that rules are available in rec rhs]
 124   - simplify rhs
 125   - mkAtomicArgs
 126   - float if exposes constructor or PAP
 127   - completeBind
 128
 129
 130 completeNonRecX:        [binder and rhs both simplified]
 131   - if the the thing needs case binding (unlifted and not ok-for-spec)
 132         build a Case
 133    else
 134         completeBind
 135         addFloats
 136
 137 completeBind:   [given a simplified RHS]
 138         [used for both rec and non-rec bindings, top level and not]
 139   - try PostInlineUnconditionally
 140   - add unfolding [this is the only place we add an unfolding]
 141   - add arity
 142
 143
 144
 145 Right hand sides and arguments
 146 ~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~
 147 In many ways we want to treat
 148         (a) the right hand side of a let(rec), and
 149         (b) a function argument
 150 in the same way.  But not always!  In particular, we would
 151 like to leave these arguments exactly as they are, so they
 152 will match a RULE more easily.
 153
 154         f (g x, h x)
 155         g (+ x)
 156
 157 It's harder to make the rule match if we ANF-ise the constructor,
 158 or eta-expand the PAP:
 159
 160         f (let { a = g x; b = h x } in (a,b))
 161         g (\y. + x y)
 162
 163 On the other hand if we see the let-defns
 164
 165         p = (g x, h x)
 166         q = + x
 167
 168 then we *do* want to ANF-ise and eta-expand, so that p and q
 169 can be safely inlined.
 170
 171 Even floating lets out is a bit dubious.  For let RHS's we float lets
 172 out if that exposes a value, so that the value can be inlined more vigorously.
 173 For example
 174
 175         r = let x = e in (x,x)
 176
 177 Here, if we float the let out we'll expose a nice constructor. We did experiments
 178 that showed this to be a generally good thing.  But it was a bad thing to float
 179 lets out unconditionally, because that meant they got allocated more often.
 180
 181 For function arguments, there's less reason to expose a constructor (it won't
 182 get inlined).  Just possibly it might make a rule match, but I'm pretty skeptical.
 183 So for the moment we don't float lets out of function arguments either.
 184
 185
 186 Eta expansion
 187 ~~~~~~~~~~~~~~
 188 For eta expansion, we want to catch things like
 189
 190         case e of (a,b) -> \x -> case a of (p,q) -> \y -> r
 191
 192 If the \x was on the RHS of a let, we'd eta expand to bring the two
 193 lambdas together.  And in general that's a good thing to do.  Perhaps
 194 we should eta expand wherever we find a (value) lambda?  Then the eta
 195 expansion at a let RHS can concentrate solely on the PAP case.
 196
 197
 198 %************************************************************************
 199 %*                                                                      *
 200 \subsection{Bindings}
 201 %*                                                                      *
 202 %************************************************************************
 203
 204 \begin{code}
 205 simplTopBinds :: SimplEnv -> [InBind] -> SimplM [OutBind]
 206
 207 simplTopBinds env0 binds0
 208   = do  {       -- Put all the top-level binders into scope at the start
 209                 -- so that if a transformation rule has unexpectedly brought
 210                 -- anything into scope, then we don't get a complaint about that.
 211                 -- It's rather as if the top-level binders were imported.
 212         ; env1 <- simplRecBndrs env0 (bindersOfBinds binds0)
 213         ; dflags <- getDOptsSmpl
 214         ; let dump_flag = dopt Opt_D_dump_inlinings dflags ||
 215                           dopt Opt_D_dump_rule_firings dflags
 216         ; env2 <- simpl_binds dump_flag env1 binds0
 217         ; freeTick SimplifierDone
 218         ; return (getFloats env2) }
 219   where
 220         -- We need to track the zapped top-level binders, because
 221         -- they should have their fragile IdInfo zapped (notably occurrence info)
 222         -- That's why we run down binds and bndrs' simultaneously.
 223         --
 224         -- The dump-flag emits a trace for each top-level binding, which
 225         -- helps to locate the tracing for inlining and rule firing
 226     simpl_binds :: Bool -> SimplEnv -> [InBind] -> SimplM SimplEnv
 227     simpl_binds _    env []           = return env
 228     simpl_binds dump env (bind:binds) = do { env' <- trace_bind dump bind $
 229                                                      simpl_bind env bind
 230                                            ; simpl_binds dump env' binds }
 231
 232     trace_bind True  bind = pprTrace "SimplBind" (ppr (bindersOf bind))
 233     trace_bind False _    = \x -> x
 234
 235     simpl_bind env (Rec pairs)  = simplRecBind      env  TopLevel pairs
 236     simpl_bind env (NonRec b r) = simplRecOrTopPair env' TopLevel b b' r
 237         where
 238           (env', b') = addBndrRules env b (lookupRecBndr env b)
 239 \end{code}
 240
 241
 242 %************************************************************************
 243 %*                                                                      *
 244 \subsection{Lazy bindings}
 245 %*                                                                      *
 246 %************************************************************************
 247
 248 simplRecBind is used for
 249         * recursive bindings only
 250
 251 \begin{code}
 252 simplRecBind :: SimplEnv -> TopLevelFlag
 253              -> [(InId, InExpr)]
 254              -> SimplM SimplEnv
 255 simplRecBind env0 top_lvl pairs0
 256   = do  { let (env_with_info, triples) = mapAccumL add_rules env0 pairs0
 257         ; env1 <- go (zapFloats env_with_info) triples
 258         ; return (env0 `addRecFloats` env1) }
 259         -- addFloats adds the floats from env1,
 260         -- _and_ updates env0 with the in-scope set from env1
 261   where
 262     add_rules :: SimplEnv -> (InBndr,InExpr) -> (SimplEnv, (InBndr, OutBndr, InExpr))
 263         -- Add the (substituted) rules to the binder
 264     add_rules env (bndr, rhs) = (env', (bndr, bndr', rhs))
 265         where
 266           (env', bndr') = addBndrRules env bndr (lookupRecBndr env bndr)
 267
 268     go env [] = return env
 269
 270     go env ((old_bndr, new_bndr, rhs) : pairs)
 271         = do { env' <- simplRecOrTopPair env top_lvl old_bndr new_bndr rhs
 272              ; go env' pairs }
 273 \end{code}
 274
 275 simplOrTopPair is used for
 276         * recursive bindings (whether top level or not)
 277         * top-level non-recursive bindings
 278
 279 It assumes the binder has already been simplified, but not its IdInfo.
 280
 281 \begin{code}
 282 simplRecOrTopPair :: SimplEnv
 283                   -> TopLevelFlag
 284                   -> InId -> OutBndr -> InExpr  -- Binder and rhs
 285                   -> SimplM SimplEnv    -- Returns an env that includes the binding
 286
 287 simplRecOrTopPair env top_lvl old_bndr new_bndr rhs
 288   | preInlineUnconditionally env top_lvl old_bndr rhs   -- Check for unconditional inline
 289   = do  { tick (PreInlineUnconditionally old_bndr)
 290         ; return (extendIdSubst env old_bndr (mkContEx env rhs)) }
 291
 292   | otherwise
 293   = simplLazyBind env top_lvl Recursive old_bndr new_bndr rhs env
 294         -- May not actually be recursive, but it doesn't matter
 295 \end{code}
 296
 297
 298 simplLazyBind is used for
 299   * [simplRecOrTopPair] recursive bindings (whether top level or not)
 300   * [simplRecOrTopPair] top-level non-recursive bindings
 301   * [simplNonRecE]      non-top-level *lazy* non-recursive bindings
 302
 303 Nota bene:
 304     1. It assumes that the binder is *already* simplified,
 305        and is in scope, and its IdInfo too, except unfolding
 306
 307     2. It assumes that the binder type is lifted.
 308
 309     3. It does not check for pre-inline-unconditionallly;
 310        that should have been done already.
 311
 312 \begin{code}
 313 simplLazyBind :: SimplEnv
 314               -> TopLevelFlag -> RecFlag
 315               -> InId -> OutId          -- Binder, both pre-and post simpl
 316                                         -- The OutId has IdInfo, except arity, unfolding
 317               -> InExpr -> SimplEnv     -- The RHS and its environment
 318               -> SimplM SimplEnv
 319
 320 simplLazyBind env top_lvl is_rec bndr bndr1 rhs rhs_se
 321   = do  { let   rhs_env     = rhs_se `setInScope` env
 322                 (tvs, body) = case collectTyBinders rhs of
 323                                 (tvs, body) | not_lam body -> (tvs,body)
 324                                             | otherwise    -> ([], rhs)
 325                 not_lam (Lam _ _) = False
 326                 not_lam _         = True
 327                         -- Do not do the "abstract tyyvar" thing if there's
 328                         -- a lambda inside, becuase it defeats eta-reduction
 329                         --    f = /\a. \x. g a x
 330                         -- should eta-reduce
 331
 332         ; (body_env, tvs') <- simplBinders rhs_env tvs
 333                 -- See Note [Floating and type abstraction] in SimplUtils
 334
 335         -- Simplify the RHS
 336         ; (body_env1, body1) <- simplExprF body_env body mkBoringStop
 337
 338         -- ANF-ise a constructor or PAP rhs
 339         ; (body_env2, body2) <- prepareRhs body_env1 body1
 340
 341         ; (env', rhs')
 342             <-  if not (doFloatFromRhs top_lvl is_rec False body2 body_env2)
 343                 then                            -- No floating, just wrap up!
 344                      do { rhs' <- mkLam tvs' (wrapFloats body_env2 body2)
 345                         ; return (env, rhs') }
 346
 347                 else if null tvs then           -- Simple floating
 348                      do { tick LetFloatFromLet
 349                         ; return (addFloats env body_env2, body2) }
 350
 351                 else                            -- Do type-abstraction first
 352                      do { tick LetFloatFromLet
 353                         ; (poly_binds, body3) <- abstractFloats tvs' body_env2 body2
 354                         ; rhs' <- mkLam tvs' body3
 355                         ; let env' = foldl (addPolyBind top_lvl) env poly_binds
 356                         ; return (env', rhs') }
 357
 358         ; completeBind env' top_lvl bndr bndr1 rhs' }
 359 \end{code}
 360
 361 A specialised variant of simplNonRec used when the RHS is already simplified,
 362 notably in knownCon.  It uses case-binding where necessary.
 363
 364 \begin{code}
 365 simplNonRecX :: SimplEnv
 366              -> InId            -- Old binder
 367              -> OutExpr         -- Simplified RHS
 368              -> SimplM SimplEnv
 369
 370 simplNonRecX env bndr new_rhs
 371   | isDeadBinder bndr   -- Not uncommon; e.g. case (a,b) of b { (p,q) -> p }
 372   = return env          --               Here b is dead, and we avoid creating
 373   | otherwise           --               the binding b = (a,b)
 374   = do  { (env', bndr') <- simplBinder env bndr
 375         ; completeNonRecX env' (isStrictId bndr) bndr bndr' new_rhs }
 376
 377 completeNonRecX :: SimplEnv
 378                 -> Bool
 379                 -> InId                 -- Old binder
 380                 -> OutId                -- New binder
 381                 -> OutExpr              -- Simplified RHS
 382                 -> SimplM SimplEnv
 383
 384 completeNonRecX env is_strict old_bndr new_bndr new_rhs
 385   = do  { (env1, rhs1) <- prepareRhs (zapFloats env) new_rhs
 386         ; (env2, rhs2) <-
 387                 if doFloatFromRhs NotTopLevel NonRecursive is_strict rhs1 env1
 388                 then do { tick LetFloatFromLet
 389                         ; return (addFloats env env1, rhs1) }   -- Add the floats to the main env
 390                 else return (env, wrapFloats env1 rhs1)         -- Wrap the floats around the RHS
 391         ; completeBind env2 NotTopLevel old_bndr new_bndr rhs2 }
 392 \end{code}
 393
 394 {- No, no, no!  Do not try preInlineUnconditionally in completeNonRecX
 395    Doing so risks exponential behaviour, because new_rhs has been simplified once already
 396    In the cases described by the folowing commment, postInlineUnconditionally will
 397    catch many of the relevant cases.
 398         -- This happens; for example, the case_bndr during case of
 399         -- known constructor:  case (a,b) of x { (p,q) -> ... }
 400         -- Here x isn't mentioned in the RHS, so we don't want to
 401         -- create the (dead) let-binding  let x = (a,b) in ...
 402         --
 403         -- Similarly, single occurrences can be inlined vigourously
 404         -- e.g.  case (f x, g y) of (a,b) -> ....
 405         -- If a,b occur once we can avoid constructing the let binding for them.
 406
 407    Furthermore in the case-binding case preInlineUnconditionally risks extra thunks
 408         -- Consider     case I# (quotInt# x y) of
 409         --                I# v -> let w = J# v in ...
 410         -- If we gaily inline (quotInt# x y) for v, we end up building an
 411         -- extra thunk:
 412         --                let w = J# (quotInt# x y) in ...
 413         -- because quotInt# can fail.
 414
 415   | preInlineUnconditionally env NotTopLevel bndr new_rhs
 416   = thing_inside (extendIdSubst env bndr (DoneEx new_rhs))
 417 -}
 418
 419 ----------------------------------
 420 prepareRhs takes a putative RHS, checks whether it's a PAP or
 421 constructor application and, if so, converts it to ANF, so that the
 422 resulting thing can be inlined more easily.  Thus
 423         x = (f a, g b)
 424 becomes
 425         t1 = f a
 426         t2 = g b
 427         x = (t1,t2)
 428
 429 We also want to deal well cases like this
 430         v = (f e1 `cast` co) e2
 431 Here we want to make e1,e2 trivial and get
 432         x1 = e1; x2 = e2; v = (f x1 `cast` co) v2
 433 That's what the 'go' loop in prepareRhs does
 434
 435 \begin{code}
 436 prepareRhs :: SimplEnv -> OutExpr -> SimplM (SimplEnv, OutExpr)
 437 -- Adds new floats to the env iff that allows us to return a good RHS
 438 prepareRhs env (Cast rhs co)    -- Note [Float coercions]
 439   | (ty1, _ty2) <- coercionKind co       -- Do *not* do this if rhs has an unlifted type
 440   , not (isUnLiftedType ty1)            -- see Note [Float coercions (unlifted)]
 441   = do  { (env', rhs') <- makeTrivial env rhs
 442         ; return (env', Cast rhs' co) }
 443
 444 prepareRhs env0 rhs0
 445   = do  { (_is_val, env1, rhs1) <- go 0 env0 rhs0
 446         ; return (env1, rhs1) }
 447   where
 448     go n_val_args env (Cast rhs co)
 449         = do { (is_val, env', rhs') <- go n_val_args env rhs
 450              ; return (is_val, env', Cast rhs' co) }
 451     go n_val_args env (App fun (Type ty))
 452         = do { (is_val, env', rhs') <- go n_val_args env fun
 453              ; return (is_val, env', App rhs' (Type ty)) }
 454     go n_val_args env (App fun arg)
 455         = do { (is_val, env', fun') <- go (n_val_args+1) env fun
 456              ; case is_val of
 457                 True -> do { (env'', arg') <- makeTrivial env' arg
 458                            ; return (True, env'', App fun' arg') }
 459                 False -> return (False, env, App fun arg) }
 460     go n_val_args env (Var fun)
 461         = return (is_val, env, Var fun)
 462         where
 463           is_val = n_val_args > 0       -- There is at least one arg
 464                                         -- ...and the fun a constructor or PAP
 465                  && (isDataConWorkId fun || n_val_args < idArity fun)
 466     go _ env other
 467         = return (False, env, other)
 468 \end{code}
 469
 470
 471 Note [Float coercions]
 472 ~~~~~~~~~~~~~~~~~~~~~~
 473 When we find the binding
 474         x = e `cast` co
 475 we'd like to transform it to
 476         x' = e
 477         x = x `cast` co         -- A trivial binding
 478 There's a chance that e will be a constructor application or function, or something
 479 like that, so moving the coerion to the usage site may well cancel the coersions
 480 and lead to further optimisation.  Example:
 481
 482      data family T a :: *
 483      data instance T Int = T Int
 484
 485      foo :: Int -> Int -> Int
 486      foo m n = ...
 487         where
 488           x = T m
 489           go 0 = 0
 490           go n = case x of { T m -> go (n-m) }
 491                 -- This case should optimise
 492
 493 Note [Float coercions (unlifted)]
 494 ~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~
 495 BUT don't do [Float coercions] if 'e' has an unlifted type.
 496 This *can* happen:
 497
 498      foo :: Int = (error (# Int,Int #) "urk")
 499                   `cast` CoUnsafe (# Int,Int #) Int
 500
 501 If do the makeTrivial thing to the error call, we'll get
 502     foo = case error (# Int,Int #) "urk" of v -> v `cast` ...
 503 But 'v' isn't in scope!
 504
 505 These strange casts can happen as a result of case-of-case
 506         bar = case (case x of { T -> (# 2,3 #); F -> error "urk" }) of
 507                 (# p,q #) -> p+q
 508
 509
 510 \begin{code}
 511 makeTrivial :: SimplEnv -> OutExpr -> SimplM (SimplEnv, OutExpr)
 512 -- Binds the expression to a variable, if it's not trivial, returning the variable
 513 makeTrivial env expr
 514   | exprIsTrivial expr
 515   = return (env, expr)
 516   | otherwise           -- See Note [Take care] below
 517   = do  { var <- newId (fsLit "a") (exprType expr)
 518         ; env' <- completeNonRecX env False var var expr
 519 --        pprTrace "makeTrivial" (vcat [ppr var <+> ppr (exprArity (substExpr env' (Var var)))
 520 --                                     , ppr expr
 521 --                                     , ppr (substExpr env' (Var var))
 522 --                                     , ppr (idArity (fromJust (lookupInScope (seInScope env') var))) ]) $
 523         ; return (env', substExpr env' (Var var)) }
 524         -- The substitution is needed becase we're constructing a new binding
 525         --     a = rhs
 526         -- And if rhs is of form (rhs1 |> co), then we might get
 527         --     a1 = rhs1
 528         --     a = a1 |> co
 529         -- and now a's RHS is trivial and can be substituted out, and that
 530         -- is what completeNonRecX will do
 531 \end{code}
 532
 533
 534 %************************************************************************
 535 %*                                                                      *
 536 \subsection{Completing a lazy binding}
 537 %*                                                                      *
 538 %************************************************************************
 539
 540 completeBind
 541   * deals only with Ids, not TyVars
 542   * takes an already-simplified binder and RHS
 543   * is used for both recursive and non-recursive bindings
 544   * is used for both top-level and non-top-level bindings
 545
 546 It does the following:
 547   - tries discarding a dead binding
 548   - tries PostInlineUnconditionally
 549   - add unfolding [this is the only place we add an unfolding]
 550   - add arity
 551
 552 It does *not* attempt to do let-to-case.  Why?  Because it is used for
 553   - top-level bindings (when let-to-case is impossible)
 554   - many situations where the "rhs" is known to be a WHNF
 555                 (so let-to-case is inappropriate).
 556
 557 Nor does it do the atomic-argument thing
 558
 559 \begin{code}
 560 completeBind :: SimplEnv
 561              -> TopLevelFlag            -- Flag stuck into unfolding
 562              -> InId                    -- Old binder
 563              -> OutId -> OutExpr        -- New binder and RHS
 564              -> SimplM SimplEnv
 565 -- completeBind may choose to do its work
 566 --      * by extending the substitution (e.g. let x = y in ...)
 567 --      * or by adding to the floats in the envt
 568
 569 completeBind env top_lvl old_bndr new_bndr new_rhs
 570   | postInlineUnconditionally env top_lvl new_bndr occ_info new_rhs unfolding
 571                 -- Inline and discard the binding
 572   = do  { tick (PostInlineUnconditionally old_bndr)
 573         ; -- pprTrace "postInlineUnconditionally" (ppr old_bndr <+> ppr new_bndr <+> ppr new_rhs) $
 574           return (extendIdSubst env old_bndr (DoneEx new_rhs)) }
 575         -- Use the substitution to make quite, quite sure that the
 576         -- substitution will happen, since we are going to discard the binding
 577
 578   | otherwise
 579   = return (addNonRecWithUnf env new_bndr new_rhs unfolding wkr)
 580   where
 581     unfolding | omit_unfolding = NoUnfolding
 582               | otherwise      = mkUnfolding  (isTopLevel top_lvl) new_rhs
 583     old_info    = idInfo old_bndr
 584     occ_info    = occInfo old_info
 585     wkr         = substWorker env (workerInfo old_info)
 586     omit_unfolding = isNonRuleLoopBreaker occ_info
 587                    --       or not (activeInline env old_bndr)
 588                    -- Do *not* trim the unfolding in SimplGently, else
 589                    -- the specialiser can't see it!
 590
 591 -----------------
 592 addPolyBind :: TopLevelFlag -> SimplEnv -> OutBind -> SimplEnv
 593 -- Add a new binding to the environment, complete with its unfolding
 594 -- but *do not* do postInlineUnconditionally, because we have already
 595 -- processed some of the scope of the binding
 596 -- We still want the unfolding though.  Consider
 597 --      let
 598 --            x = /\a. let y = ... in Just y
 599 --      in body
 600 -- Then we float the y-binding out (via abstractFloats and addPolyBind)
 601 -- but 'x' may well then be inlined in 'body' in which case we'd like the
 602 -- opportunity to inline 'y' too.
 603
 604 addPolyBind top_lvl env (NonRec poly_id rhs)
 605   = addNonRecWithUnf env poly_id rhs unfolding NoWorker
 606   where
 607     unfolding | not (activeInline env poly_id) = NoUnfolding
 608               | otherwise                      = mkUnfolding (isTopLevel top_lvl) rhs
 609                 -- addNonRecWithInfo adds the new binding in the
 610                 -- proper way (ie complete with unfolding etc),
 611                 -- and extends the in-scope set
 612
 613 addPolyBind _ env bind@(Rec _) = extendFloats env bind
 614                 -- Hack: letrecs are more awkward, so we extend "by steam"
 615                 -- without adding unfoldings etc.  At worst this leads to
 616                 -- more simplifier iterations
 617
 618 -----------------
 619 addNonRecWithUnf :: SimplEnv
 620                   -> OutId -> OutExpr        -- New binder and RHS
 621                   -> Unfolding -> WorkerInfo -- and unfolding
 622                   -> SimplEnv
 623 -- Add suitable IdInfo to the Id, add the binding to the floats, and extend the in-scope set
 624 addNonRecWithUnf env new_bndr rhs unfolding wkr
 625   = ASSERT( isId new_bndr )
 626     WARN( new_arity < old_arity || new_arity < dmd_arity,
 627           (ppr final_id <+> ppr old_arity <+> ppr new_arity <+> ppr dmd_arity) $$ ppr rhs )
 628     final_id `seq`      -- This seq forces the Id, and hence its IdInfo,
 629                         -- and hence any inner substitutions
 630     addNonRec env final_id rhs
 631         -- The addNonRec adds it to the in-scope set too
 632   where
 633         dmd_arity = length $ fst $ splitStrictSig $ idNewStrictness new_bndr
 634         old_arity = idArity new_bndr
 635
 636         --      Arity info
 637         new_arity = exprArity rhs
 638         new_bndr_info = idInfo new_bndr `setArityInfo` new_arity
 639
 640         --      Unfolding info
 641         -- Add the unfolding *only* for non-loop-breakers
 642         -- Making loop breakers not have an unfolding at all
 643         -- means that we can avoid tests in exprIsConApp, for example.
 644         -- This is important: if exprIsConApp says 'yes' for a recursive
 645         -- thing, then we can get into an infinite loop
 646
 647         --      Demand info
 648         -- If the unfolding is a value, the demand info may
 649         -- go pear-shaped, so we nuke it.  Example:
 650         --      let x = (a,b) in
 651         --      case x of (p,q) -> h p q x
 652         -- Here x is certainly demanded. But after we've nuked
 653         -- the case, we'll get just
 654         --      let x = (a,b) in h a b x
 655         -- and now x is not demanded (I'm assuming h is lazy)
 656         -- This really happens.  Similarly
 657         --      let f = \x -> e in ...f..f...
 658         -- After inlining f at some of its call sites the original binding may
 659         -- (for example) be no longer strictly demanded.
 660         -- The solution here is a bit ad hoc...
 661         info_w_unf = new_bndr_info `setUnfoldingInfo` unfolding
 662                                    `setWorkerInfo`    wkr
 663
 664         final_info | isEvaldUnfolding unfolding = zapDemandInfo info_w_unf `orElse` info_w_unf
 665                    | otherwise                  = info_w_unf
 666
 667         final_id = new_bndr `setIdInfo` final_info
 668 \end{code}
 669
 670
 671
 672 %************************************************************************
 673 %*                                                                      *
 674 \subsection[Simplify-simplExpr]{The main function: simplExpr}
 675 %*                                                                      *
 676 %************************************************************************
 677
 678 The reason for this OutExprStuff stuff is that we want to float *after*
 679 simplifying a RHS, not before.  If we do so naively we get quadratic
 680 behaviour as things float out.
 681
 682 To see why it's important to do it after, consider this (real) example:
 683
 684         let t = f x
 685         in fst t
 686 ==>
 687         let t = let a = e1
 688                     b = e2
 689                 in (a,b)
 690         in fst t
 691 ==>
 692         let a = e1
 693             b = e2
 694             t = (a,b)
 695         in
 696         a       -- Can't inline a this round, cos it appears twice
 697 ==>
 698         e1
 699
 700 Each of the ==> steps is a round of simplification.  We'd save a
 701 whole round if we float first.  This can cascade.  Consider
 702
 703         let f = g d
 704         in \x -> ...f...
 705 ==>
 706         let f = let d1 = ..d.. in \y -> e
 707         in \x -> ...f...
 708 ==>
 709         let d1 = ..d..
 710         in \x -> ...(\y ->e)...
 711
 712 Only in this second round can the \y be applied, and it
 713 might do the same again.
 714
 715
 716 \begin{code}
 717 simplExpr :: SimplEnv -> CoreExpr -> SimplM CoreExpr
 718 simplExpr env expr = simplExprC env expr mkBoringStop
 719
 720 simplExprC :: SimplEnv -> CoreExpr -> SimplCont -> SimplM CoreExpr
 721         -- Simplify an expression, given a continuation
 722 simplExprC env expr cont
 723   = -- pprTrace "simplExprC" (ppr expr $$ ppr cont {- $$ ppr (seIdSubst env) -} $$ ppr (seFloats env) ) $
 724     do  { (env', expr') <- simplExprF (zapFloats env) expr cont
 725         ; -- pprTrace "simplExprC ret" (ppr expr $$ ppr expr') $
 726           -- pprTrace "simplExprC ret3" (ppr (seInScope env')) $
 727           -- pprTrace "simplExprC ret4" (ppr (seFloats env')) $
 728           return (wrapFloats env' expr') }
 729
 730 --------------------------------------------------
 731 simplExprF :: SimplEnv -> InExpr -> SimplCont
 732            -> SimplM (SimplEnv, OutExpr)
 733
 734 simplExprF env e cont
 735   = -- pprTrace "simplExprF" (ppr e $$ ppr cont $$ ppr (seTvSubst env) $$ ppr (seIdSubst env) {- $$ ppr (seFloats env) -} ) $
 736     simplExprF' env e cont
 737
 738 simplExprF' :: SimplEnv -> InExpr -> SimplCont
 739             -> SimplM (SimplEnv, OutExpr)
 740 simplExprF' env (Var v)        cont = simplVar env v cont
 741 simplExprF' env (Lit lit)      cont = rebuild env (Lit lit) cont
 742 simplExprF' env (Note n expr)  cont = simplNote env n expr cont
 743 simplExprF' env (Cast body co) cont = simplCast env body co cont
 744 simplExprF' env (App fun arg)  cont = simplExprF env fun $
 745                                       ApplyTo NoDup arg env cont
 746
 747 simplExprF' env expr@(Lam _ _) cont
 748   = simplLam env (map zap bndrs) body cont
 749         -- The main issue here is under-saturated lambdas
 750         --   (\x1. \x2. e) arg1
 751         -- Here x1 might have "occurs-once" occ-info, because occ-info
 752         -- is computed assuming that a group of lambdas is applied
 753         -- all at once.  If there are too few args, we must zap the
 754         -- occ-info.
 755   where
 756     n_args   = countArgs cont
 757     n_params = length bndrs
 758     (bndrs, body) = collectBinders expr
 759     zap | n_args >= n_params = \b -> b
 760         | otherwise          = \b -> if isTyVar b then b
 761                                      else zapLamIdInfo b
 762         -- NB: we count all the args incl type args
 763         -- so we must count all the binders (incl type lambdas)
 764
 765 simplExprF' env (Type ty) cont
 766   = ASSERT( contIsRhsOrArg cont )
 767     do  { ty' <- simplType env ty
 768         ; rebuild env (Type ty') cont }
 769
 770 simplExprF' env (Case scrut bndr _ alts) cont
 771   | not (switchIsOn (getSwitchChecker env) NoCaseOfCase)
 772   =     -- Simplify the scrutinee with a Select continuation
 773     simplExprF env scrut (Select NoDup bndr alts env cont)
 774
 775   | otherwise
 776   =     -- If case-of-case is off, simply simplify the case expression
 777         -- in a vanilla Stop context, and rebuild the result around it
 778     do  { case_expr' <- simplExprC env scrut case_cont
 779         ; rebuild env case_expr' cont }
 780   where
 781     case_cont = Select NoDup bndr alts env mkBoringStop
 782
 783 simplExprF' env (Let (Rec pairs) body) cont
 784   = do  { env' <- simplRecBndrs env (map fst pairs)
 785                 -- NB: bndrs' don't have unfoldings or rules
 786                 -- We add them as we go down
 787
 788         ; env'' <- simplRecBind env' NotTopLevel pairs
 789         ; simplExprF env'' body cont }
 790
 791 simplExprF' env (Let (NonRec bndr rhs) body) cont
 792   = simplNonRecE env bndr (rhs, env) ([], body) cont
 793
 794 ---------------------------------
 795 simplType :: SimplEnv -> InType -> SimplM OutType
 796         -- Kept monadic just so we can do the seqType
 797 simplType env ty
 798   = -- pprTrace "simplType" (ppr ty $$ ppr (seTvSubst env)) $
 799     seqType new_ty   `seq`   return new_ty
 800   where
 801     new_ty = substTy env ty
 802 \end{code}
 803
 804
 805 %************************************************************************
 806 %*                                                                      *
 807 \subsection{The main rebuilder}
 808 %*                                                                      *
 809 %************************************************************************
 810
 811 \begin{code}
 812 rebuild :: SimplEnv -> OutExpr -> SimplCont -> SimplM (SimplEnv, OutExpr)
 813 -- At this point the substitution in the SimplEnv should be irrelevant
 814 -- only the in-scope set and floats should matter
 815 rebuild env expr cont0
 816   = -- pprTrace "rebuild" (ppr expr $$ ppr cont0 $$ ppr (seFloats env)) $
 817     case cont0 of
 818       Stop {}                      -> return (env, expr)
 819       CoerceIt co cont             -> rebuild env (mkCoerce co expr) cont
 820       Select _ bndr alts se cont   -> rebuildCase (se `setFloats` env) expr bndr alts cont
 821       StrictArg fun _ info cont    -> rebuildCall env (fun `App` expr) info cont
 822       StrictBind b bs body se cont -> do { env' <- simplNonRecX (se `setFloats` env) b expr
 823                                          ; simplLam env' bs body cont }
 824       ApplyTo _ arg se cont        -> do { arg' <- simplExpr (se `setInScope` env) arg
 825                                          ; rebuild env (App expr arg') cont }
 826 \end{code}
 827
 828
 829 %************************************************************************
 830 %*                                                                      *
 831 \subsection{Lambdas}
 832 %*                                                                      *
 833 %************************************************************************
 834
 835 \begin{code}
 836 simplCast :: SimplEnv -> InExpr -> Coercion -> SimplCont
 837           -> SimplM (SimplEnv, OutExpr)
 838 simplCast env body co0 cont0
 839   = do  { co1 <- simplType env co0
 840         ; simplExprF env body (addCoerce co1 cont0) }
 841   where
 842        addCoerce co cont = add_coerce co (coercionKind co) cont
 843
 844        add_coerce _co (s1, k1) cont     -- co :: ty~ty
 845          | s1 `coreEqType` k1 = cont    -- is a no-op
 846
 847        add_coerce co1 (s1, _k2) (CoerceIt co2 cont)
 848          | (_l1, t1) <- coercionKind co2
 849                 --      e |> (g1 :: S1~L) |> (g2 :: L~T1)
 850                 -- ==>
 851                 --      e,                       if T1=T2
 852                 --      e |> (g1 . g2 :: T1~T2)  otherwise
 853                 --
 854                 -- For example, in the initial form of a worker
 855                 -- we may find  (coerce T (coerce S (\x.e))) y
 856                 -- and we'd like it to simplify to e[y/x] in one round
 857                 -- of simplification
 858          , s1 `coreEqType` t1  = cont            -- The coerces cancel out
 859          | otherwise           = CoerceIt (mkTransCoercion co1 co2) cont
 860
 861        add_coerce co (s1s2, _t1t2) (ApplyTo dup (Type arg_ty) arg_se cont)
 862                 -- (f |> g) ty  --->   (f ty) |> (g @ ty)
 863                 -- This implements the PushT rule from the paper
 864          | Just (tyvar,_) <- splitForAllTy_maybe s1s2
 865          , not (isCoVar tyvar)
 866          = ApplyTo dup (Type ty') (zapSubstEnv env) (addCoerce (mkInstCoercion co ty') cont)
 867          where
 868            ty' = substTy (arg_se `setInScope` env) arg_ty
 869
 870         -- ToDo: the PushC rule is not implemented at all
 871
 872        add_coerce co (s1s2, _t1t2) (ApplyTo dup arg arg_se cont)
 873          | not (isTypeArg arg)  -- This implements the Push rule from the paper
 874          , isFunTy s1s2   -- t1t2 must be a function type, becuase it's applied
 875                 --      (e |> (g :: s1s2 ~ t1->t2)) f
 876                 -- ===>
 877                 --      (e (f |> (arg g :: t1~s1))
 878                 --      |> (res g :: s2->t2)
 879                 --
 880                 -- t1t2 must be a function type, t1->t2, because it's applied
 881                 -- to something but s1s2 might conceivably not be
 882                 --
 883                 -- When we build the ApplyTo we can't mix the out-types
 884                 -- with the InExpr in the argument, so we simply substitute
 885                 -- to make it all consistent.  It's a bit messy.
 886                 -- But it isn't a common case.
 887                 --
 888                 -- Example of use: Trac #995
 889          = ApplyTo dup new_arg (zapSubstEnv env) (addCoerce co2 cont)
 890          where
 891            -- we split coercion t1->t2 ~ s1->s2 into t1 ~ s1 and
 892            -- t2 ~ s2 with left and right on the curried form:
 893            --    (->) t1 t2 ~ (->) s1 s2
 894            [co1, co2] = decomposeCo 2 co
 895            new_arg    = mkCoerce (mkSymCoercion co1) arg'
 896            arg'       = substExpr (arg_se `setInScope` env) arg
 897
 898        add_coerce co _ cont = CoerceIt co cont
 899 \end{code}
 900
 901
 902 %************************************************************************
 903 %*                                                                      *
 904 \subsection{Lambdas}
 905 %*                                                                      *
 906 %************************************************************************
 907
 908 \begin{code}
 909 simplLam :: SimplEnv -> [InId] -> InExpr -> SimplCont
 910          -> SimplM (SimplEnv, OutExpr)
 911
 912 simplLam env [] body cont = simplExprF env body cont
 913
 914         -- Beta reduction
 915 simplLam env (bndr:bndrs) body (ApplyTo _ arg arg_se cont)
 916   = do  { tick (BetaReduction bndr)
 917         ; simplNonRecE env bndr (arg, arg_se) (bndrs, body) cont }
 918
 919         -- Not enough args, so there are real lambdas left to put in the result
 920 simplLam env bndrs body cont
 921   = do  { (env', bndrs') <- simplLamBndrs env bndrs
 922         ; body' <- simplExpr env' body
 923         ; new_lam <- mkLam bndrs' body'
 924         ; rebuild env' new_lam cont }
 925
 926 ------------------
 927 simplNonRecE :: SimplEnv
 928              -> InId                    -- The binder
 929              -> (InExpr, SimplEnv)      -- Rhs of binding (or arg of lambda)
 930              -> ([InBndr], InExpr)      -- Body of the let/lambda
 931                                         --      \xs.e
 932              -> SimplCont
 933              -> SimplM (SimplEnv, OutExpr)
 934
 935 -- simplNonRecE is used for
 936 --  * non-top-level non-recursive lets in expressions
 937 --  * beta reduction
 938 --
 939 -- It deals with strict bindings, via the StrictBind continuation,
 940 -- which may abort the whole process
 941 --
 942 -- The "body" of the binding comes as a pair of ([InId],InExpr)
 943 -- representing a lambda; so we recurse back to simplLam
 944 -- Why?  Because of the binder-occ-info-zapping done before
 945 --       the call to simplLam in simplExprF (Lam ...)
 946
 947         -- First deal with type applications and type lets
 948         --   (/\a. e) (Type ty)   and   (let a = Type ty in e)
 949 simplNonRecE env bndr (Type ty_arg, rhs_se) (bndrs, body) cont
 950   = ASSERT( isTyVar bndr )
 951     do  { ty_arg' <- simplType (rhs_se `setInScope` env) ty_arg
 952         ; simplLam (extendTvSubst env bndr ty_arg') bndrs body cont }
 953
 954 simplNonRecE env bndr (rhs, rhs_se) (bndrs, body) cont
 955   | preInlineUnconditionally env NotTopLevel bndr rhs
 956   = do  { tick (PreInlineUnconditionally bndr)
 957         ; simplLam (extendIdSubst env bndr (mkContEx rhs_se rhs)) bndrs body cont }
 958
 959   | isStrictId bndr
 960   = do  { simplExprF (rhs_se `setFloats` env) rhs
 961                      (StrictBind bndr bndrs body env cont) }
 962
 963   | otherwise
 964   = ASSERT( not (isTyVar bndr) )
 965     do  { (env1, bndr1) <- simplNonRecBndr env bndr
 966         ; let (env2, bndr2) = addBndrRules env1 bndr bndr1
 967         ; env3 <- simplLazyBind env2 NotTopLevel NonRecursive bndr bndr2 rhs rhs_se
 968         ; simplLam env3 bndrs body cont }
 969 \end{code}
 970
 971
 972 %************************************************************************
 973 %*                                                                      *
 974 \subsection{Notes}
 975 %*                                                                      *
 976 %************************************************************************
 977
 978 \begin{code}
 979 -- Hack alert: we only distinguish subsumed cost centre stacks for the
 980 -- purposes of inlining.  All other CCCSs are mapped to currentCCS.
 981 simplNote :: SimplEnv -> Note -> CoreExpr -> SimplCont
 982           -> SimplM (SimplEnv, OutExpr)
 983 simplNote env (SCC cc) e cont
 984   = do  { e' <- simplExpr (setEnclosingCC env currentCCS) e
 985         ; rebuild env (mkSCC cc e') cont }
 986
 987 -- See notes with SimplMonad.inlineMode
 988 simplNote env InlineMe e cont
 989   | Just (inside, outside) <- splitInlineCont cont  -- Boring boring continuation; see notes above
 990   = do  {                       -- Don't inline inside an INLINE expression
 991           e' <- simplExprC (setMode inlineMode env) e inside
 992         ; rebuild env (mkInlineMe e') outside }
 993
 994   | otherwise   -- Dissolve the InlineMe note if there's
 995                 -- an interesting context of any kind to combine with
 996                 -- (even a type application -- anything except Stop)
 997   = simplExprF env e cont
 998
 999 simplNote env (CoreNote s) e cont = do
1000     e' <- simplExpr env e
1001     rebuild env (Note (CoreNote s) e') cont
1002 \end{code}
1003
1004
1005 %************************************************************************
1006 %*                                                                      *
1007 \subsection{Dealing with calls}
1008 %*                                                                      *
1009 %************************************************************************
1010
1011 \begin{code}
1012 simplVar :: SimplEnv -> Id -> SimplCont -> SimplM (SimplEnv, OutExpr)
1013 simplVar env var cont
1014   = case substId env var of
1015         DoneEx e         -> simplExprF (zapSubstEnv env) e cont
1016         ContEx tvs ids e -> simplExprF (setSubstEnv env tvs ids) e cont
1017         DoneId var1      -> completeCall (zapSubstEnv env) var1 cont
1018                 -- Note [zapSubstEnv]
1019                 -- The template is already simplified, so don't re-substitute.
1020                 -- This is VITAL.  Consider
1021                 --      let x = e in
1022                 --      let y = \z -> ...x... in
1023                 --      \ x -> ...y...
1024                 -- We'll clone the inner \x, adding x->x' in the id_subst
1025                 -- Then when we inline y, we must *not* replace x by x' in
1026                 -- the inlined copy!!
1027
1028 ---------------------------------------------------------
1029 --      Dealing with a call site
1030
1031 completeCall :: SimplEnv -> Id -> SimplCont -> SimplM (SimplEnv, OutExpr)
1032 completeCall env var cont
1033   = do  { dflags <- getDOptsSmpl
1034         ; let   (args,call_cont) = contArgs cont
1035                 -- The args are OutExprs, obtained by *lazily* substituting
1036                 -- in the args found in cont.  These args are only examined
1037                 -- to limited depth (unless a rule fires).  But we must do
1038                 -- the substitution; rule matching on un-simplified args would
1039                 -- be bogus
1040
1041         ------------- First try rules ----------------
1042         -- Do this before trying inlining.  Some functions have
1043         -- rules *and* are strict; in this case, we don't want to
1044         -- inline the wrapper of the non-specialised thing; better
1045         -- to call the specialised thing instead.
1046         --
1047         -- We used to use the black-listing mechanism to ensure that inlining of
1048         -- the wrapper didn't occur for things that have specialisations till a
1049         -- later phase, so but now we just try RULES first
1050         --
1051         -- Note [Rules for recursive functions]
1052         -- ~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~
1053         -- You might think that we shouldn't apply rules for a loop breaker:
1054         -- doing so might give rise to an infinite loop, because a RULE is
1055         -- rather like an extra equation for the function:
1056         --      RULE:           f (g x) y = x+y
1057         --      Eqn:            f a     y = a-y
1058         --
1059         -- But it's too drastic to disable rules for loop breakers.
1060         -- Even the foldr/build rule would be disabled, because foldr
1061         -- is recursive, and hence a loop breaker:
1062         --      foldr k z (build g) = g k z
1063         -- So it's up to the programmer: rules can cause divergence
1064         ; rule_base <- getSimplRules
1065         ; let   in_scope   = getInScope env
1066                 rules      = getRules rule_base var
1067                 maybe_rule = case activeRule dflags env of
1068                                 Nothing     -> Nothing  -- No rules apply
1069                                 Just act_fn -> lookupRule act_fn in_scope
1070                                                           var args rules
1071         ; case maybe_rule of {
1072             Just (rule, rule_rhs) -> do
1073                 tick (RuleFired (ru_name rule))
1074                 (if dopt Opt_D_dump_rule_firings dflags then
1075                    pprTrace "Rule fired" (vcat [
1076                         text "Rule:" <+> ftext (ru_name rule),
1077                         text "Before:" <+> ppr var <+> sep (map pprParendExpr args),
1078                         text "After: " <+> pprCoreExpr rule_rhs,
1079                         text "Cont:  " <+> ppr call_cont])
1080                  else
1081                         id)             $
1082                  simplExprF env rule_rhs (dropArgs (ruleArity rule) cont)
1083                  -- The ruleArity says how many args the rule consumed
1084
1085           ; Nothing -> do       -- No rules
1086
1087         ------------- Next try inlining ----------------
1088         { let   arg_infos = [interestingArg arg | arg <- args, isValArg arg]
1089                 n_val_args = length arg_infos
1090                 interesting_cont = interestingCallContext call_cont
1091                 active_inline = activeInline env var
1092                 maybe_inline  = callSiteInline dflags active_inline var
1093                                                (null args) arg_infos interesting_cont
1094         ; case maybe_inline of {
1095             Just unfolding      -- There is an inlining!
1096               ->  do { tick (UnfoldingDone var)
1097                      ; (if dopt Opt_D_dump_inlinings dflags then
1098                            pprTrace ("Inlining done" ++ showSDoc (ppr var)) (vcat [
1099                                 text "Before:" <+> ppr var <+> sep (map pprParendExpr args),
1100                                 text "Inlined fn: " <+> nest 2 (ppr unfolding),
1101                                 text "Cont:  " <+> ppr call_cont])
1102                          else
1103                                 id)
1104                        simplExprF env unfolding cont }
1105
1106             ; Nothing ->                -- No inlining!
1107
1108         ------------- No inlining! ----------------
1109         -- Next, look for rules or specialisations that match
1110         --
1111         rebuildCall env (Var var)
1112                     (mkArgInfo var n_val_args call_cont) cont
1113     }}}}
1114
1115 rebuildCall :: SimplEnv
1116             -> OutExpr       -- Function
1117             -> ArgInfo
1118             -> SimplCont
1119             -> SimplM (SimplEnv, OutExpr)
1120 rebuildCall env fun (ArgInfo { ai_strs = [] }) cont
1121   -- When we run out of strictness args, it means
1122   -- that the call is definitely bottom; see SimplUtils.mkArgInfo
1123   -- Then we want to discard the entire strict continuation.  E.g.
1124   --    * case (error "hello") of { ... }
1125   --    * (error "Hello") arg
1126   --    * f (error "Hello") where f is strict
1127   --    etc
1128   -- Then, especially in the first of these cases, we'd like to discard
1129   -- the continuation, leaving just the bottoming expression.  But the
1130   -- type might not be right, so we may have to add a coerce.
1131   | not (contIsTrivial cont)     -- Only do this if there is a non-trivial
1132   = return (env, mk_coerce fun)  -- contination to discard, else we do it
1133   where                          -- again and again!
1134     fun_ty  = exprType fun
1135     cont_ty = contResultType env fun_ty cont
1136     co      = mkUnsafeCoercion fun_ty cont_ty
1137     mk_coerce expr | cont_ty `coreEqType` fun_ty = expr
1138                    | otherwise = mkCoerce co expr
1139
1140 rebuildCall env fun info (ApplyTo _ (Type arg_ty) se cont)
1141   = do  { ty' <- simplType (se `setInScope` env) arg_ty
1142         ; rebuildCall env (fun `App` Type ty') info cont }
1143
1144 rebuildCall env fun
1145            (ArgInfo { ai_rules = has_rules, ai_strs = str:strs, ai_discs = disc:discs })
1146            (ApplyTo _ arg arg_se cont)
1147   | str                 -- Strict argument
1148   = -- pprTrace "Strict Arg" (ppr arg $$ ppr (seIdSubst env) $$ ppr (seInScope env)) $
1149     simplExprF (arg_se `setFloats` env) arg
1150                (StrictArg fun cci arg_info' cont)
1151                 -- Note [Shadowing]
1152
1153   | otherwise                           -- Lazy argument
1154         -- DO NOT float anything outside, hence simplExprC
1155         -- There is no benefit (unlike in a let-binding), and we'd
1156         -- have to be very careful about bogus strictness through
1157         -- floating a demanded let.
1158   = do  { arg' <- simplExprC (arg_se `setInScope` env) arg
1159                              (mkLazyArgStop cci)
1160         ; rebuildCall env (fun `App` arg') arg_info' cont }
1161   where
1162     arg_info' = ArgInfo { ai_rules = has_rules, ai_strs = strs, ai_discs = discs }
1163     cci | has_rules || disc > 0 = ArgCtxt has_rules disc  -- Be keener here
1164         | otherwise             = BoringCtxt              -- Nothing interesting
1165
1166 rebuildCall env fun _ cont
1167   = rebuild env fun cont
1168 \end{code}
1169
1170 Note [Shadowing]
1171 ~~~~~~~~~~~~~~~~
1172 This part of the simplifier may break the no-shadowing invariant
1173 Consider
1174         f (...(\a -> e)...) (case y of (a,b) -> e')
1175 where f is strict in its second arg
1176 If we simplify the innermost one first we get (...(\a -> e)...)
1177 Simplifying the second arg makes us float the case out, so we end up with
1178         case y of (a,b) -> f (...(\a -> e)...) e'
1179 So the output does not have the no-shadowing invariant.  However, there is
1180 no danger of getting name-capture, because when the first arg was simplified
1181 we used an in-scope set that at least mentioned all the variables free in its
1182 static environment, and that is enough.
1183
1184 We can't just do innermost first, or we'd end up with a dual problem:
1185         case x of (a,b) -> f e (...(\a -> e')...)
1186
1187 I spent hours trying to recover the no-shadowing invariant, but I just could
1188 not think of an elegant way to do it.  The simplifier is already knee-deep in
1189 continuations.  We have to keep the right in-scope set around; AND we have
1190 to get the effect that finding (error "foo") in a strict arg position will
1191 discard the entire application and replace it with (error "foo").  Getting
1192 all this at once is TOO HARD!
1193
1194 %************************************************************************
1195 %*                                                                      *
1196                 Rebuilding a cse expression
1197 %*                                                                      *
1198 %************************************************************************
1199
1200 Note [Case elimination]
1201 ~~~~~~~~~~~~~~~~~~~~~~~
1202 The case-elimination transformation discards redundant case expressions.
1203 Start with a simple situation:
1204
1205         case x# of      ===>   e[x#/y#]
1206           y# -> e
1207
1208 (when x#, y# are of primitive type, of course).  We can't (in general)
1209 do this for algebraic cases, because we might turn bottom into
1210 non-bottom!
1211
1212 The code in SimplUtils.prepareAlts has the effect of generalise this
1213 idea to look for a case where we're scrutinising a variable, and we
1214 know that only the default case can match.  For example:
1215
1216         case x of
1217           0#      -> ...
1218           DEFAULT -> ...(case x of
1219                          0#      -> ...
1220                          DEFAULT -> ...) ...
1221
1222 Here the inner case is first trimmed to have only one alternative, the
1223 DEFAULT, after which it's an instance of the previous case.  This
1224 really only shows up in eliminating error-checking code.
1225
1226 We also make sure that we deal with this very common case:
1227
1228         case e of
1229           x -> ...x...
1230
1231 Here we are using the case as a strict let; if x is used only once
1232 then we want to inline it.  We have to be careful that this doesn't
1233 make the program terminate when it would have diverged before, so we
1234 check that
1235         - e is already evaluated (it may so if e is a variable)
1236         - x is used strictly, or
1237
1238 Lastly, the code in SimplUtils.mkCase combines identical RHSs.  So
1239
1240         case e of       ===> case e of DEFAULT -> r
1241            True  -> r
1242            False -> r
1243
1244 Now again the case may be elminated by the CaseElim transformation.
1245
1246
1247 Further notes about case elimination
1248 ~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~
1249 Consider:       test :: Integer -> IO ()
1250                 test = print
1251
1252 Turns out that this compiles to:
1253     Print.test
1254       = \ eta :: Integer
1255           eta1 :: State# RealWorld ->
1256           case PrelNum.< eta PrelNum.zeroInteger of wild { __DEFAULT ->
1257           case hPutStr stdout
1258                  (PrelNum.jtos eta ($w[] @ Char))
1259                  eta1
1260           of wild1 { (# new_s, a4 #) -> PrelIO.lvl23 new_s  }}
1261
1262 Notice the strange '<' which has no effect at all. This is a funny one.
1263 It started like this:
1264
1265 f x y = if x < 0 then jtos x
1266           else if y==0 then "" else jtos x
1267
1268 At a particular call site we have (f v 1).  So we inline to get
1269
1270         if v < 0 then jtos x
1271         else if 1==0 then "" else jtos x
1272
1273 Now simplify the 1==0 conditional:
1274
1275         if v<0 then jtos v else jtos v
1276
1277 Now common-up the two branches of the case:
1278
1279         case (v<0) of DEFAULT -> jtos v
1280
1281 Why don't we drop the case?  Because it's strict in v.  It's technically
1282 wrong to drop even unnecessary evaluations, and in practice they
1283 may be a result of 'seq' so we *definitely* don't want to drop those.
1284 I don't really know how to improve this situation.
1285
1286 \begin{code}
1287 ---------------------------------------------------------
1288 --      Eliminate the case if possible
1289
1290 rebuildCase :: SimplEnv
1291             -> OutExpr          -- Scrutinee
1292             -> InId             -- Case binder
1293             -> [InAlt]          -- Alternatives (inceasing order)
1294             -> SimplCont
1295             -> SimplM (SimplEnv, OutExpr)
1296
1297 --------------------------------------------------
1298 --      1. Eliminate the case if there's a known constructor
1299 --------------------------------------------------
1300
1301 rebuildCase env scrut case_bndr alts cont
1302   | Just (con,args) <- exprIsConApp_maybe scrut
1303         -- Works when the scrutinee is a variable with a known unfolding
1304         -- as well as when it's an explicit constructor application
1305   = knownCon env scrut (DataAlt con) args case_bndr alts cont
1306
1307   | Lit lit <- scrut    -- No need for same treatment as constructors
1308                         -- because literals are inlined more vigorously
1309   = knownCon env scrut (LitAlt lit) [] case_bndr alts cont
1310
1311
1312 --------------------------------------------------
1313 --      2. Eliminate the case if scrutinee is evaluated
1314 --------------------------------------------------
1315
1316 rebuildCase env scrut case_bndr [(_, bndrs, rhs)] cont
1317   -- See if we can get rid of the case altogether
1318   -- See Note [Case eliminiation]
1319   -- mkCase made sure that if all the alternatives are equal,
1320   -- then there is now only one (DEFAULT) rhs
1321  | all isDeadBinder bndrs       -- bndrs are [InId]
1322
1323         -- Check that the scrutinee can be let-bound instead of case-bound
1324  , exprOkForSpeculation scrut
1325                 -- OK not to evaluate it
1326                 -- This includes things like (==# a# b#)::Bool
1327                 -- so that we simplify
1328                 --      case ==# a# b# of { True -> x; False -> x }
1329                 -- to just
1330                 --      x
1331                 -- This particular example shows up in default methods for
1332                 -- comparision operations (e.g. in (>=) for Int.Int32)
1333         || exprIsHNF scrut                      -- It's already evaluated
1334         || var_demanded_later scrut             -- It'll be demanded later
1335
1336 --      || not opt_SimplPedanticBottoms)        -- Or we don't care!
1337 --      We used to allow improving termination by discarding cases, unless -fpedantic-bottoms was on,
1338 --      but that breaks badly for the dataToTag# primop, which relies on a case to evaluate
1339 --      its argument:  case x of { y -> dataToTag# y }
1340 --      Here we must *not* discard the case, because dataToTag# just fetches the tag from
1341 --      the info pointer.  So we'll be pedantic all the time, and see if that gives any
1342 --      other problems
1343 --      Also we don't want to discard 'seq's
1344   = do  { tick (CaseElim case_bndr)
1345         ; env' <- simplNonRecX env case_bndr scrut
1346         ; simplExprF env' rhs cont }
1347   where
1348         -- The case binder is going to be evaluated later,
1349         -- and the scrutinee is a simple variable
1350     var_demanded_later (Var v) = isStrictDmd (idNewDemandInfo case_bndr)
1351                                  && not (isTickBoxOp v)
1352                                     -- ugly hack; covering this case is what
1353                                     -- exprOkForSpeculation was intended for.
1354     var_demanded_later _       = False
1355
1356
1357 --------------------------------------------------
1358 --      3. Catch-all case
1359 --------------------------------------------------
1360
1361 rebuildCase env scrut case_bndr alts cont
1362   = do  {       -- Prepare the continuation;
1363                 -- The new subst_env is in place
1364           (env', dup_cont, nodup_cont) <- prepareCaseCont env alts cont
1365
1366         -- Simplify the alternatives
1367         ; (scrut', case_bndr', alts') <- simplAlts env' scrut case_bndr alts dup_cont
1368
1369         -- Check for empty alternatives
1370         ; if null alts' then
1371                 -- This isn't strictly an error, although it is unusual.
1372                 -- It's possible that the simplifer might "see" that
1373                 -- an inner case has no accessible alternatives before
1374                 -- it "sees" that the entire branch of an outer case is
1375                 -- inaccessible.  So we simply put an error case here instead.
1376             pprTrace "mkCase: null alts" (ppr case_bndr <+> ppr scrut) $
1377             let res_ty' = contResultType env' (substTy env' (coreAltsType alts)) dup_cont
1378                 lit = mkStringLit "Impossible alternative"
1379             in return (env', mkApps (Var rUNTIME_ERROR_ID) [Type res_ty', lit])
1380
1381           else do
1382         { case_expr <- mkCase scrut' case_bndr' alts'
1383
1384         -- Notice that rebuild gets the in-scope set from env, not alt_env
1385         -- The case binder *not* scope over the whole returned case-expression
1386         ; rebuild env' case_expr nodup_cont } }
1387 \end{code}
1388
1389 simplCaseBinder checks whether the scrutinee is a variable, v.  If so,
1390 try to eliminate uses of v in the RHSs in favour of case_bndr; that
1391 way, there's a chance that v will now only be used once, and hence
1392 inlined.
1393
1394 Historical note: we use to do the "case binder swap" in the Simplifier
1395 so there were additional complications if the scrutinee was a variable.
1396 Now the binder-swap stuff is done in the occurrence analyer; see
1397 OccurAnal Note [Binder swap].
1398
1399 Note [zapOccInfo]
1400 ~~~~~~~~~~~~~~~~~
1401 If the case binder is not dead, then neither are the pattern bound
1402 variables:
1403         case <any> of x { (a,b) ->
1404         case x of { (p,q) -> p } }
1405 Here (a,b) both look dead, but come alive after the inner case is eliminated.
1406 The point is that we bring into the envt a binding
1407         let x = (a,b)
1408 after the outer case, and that makes (a,b) alive.  At least we do unless
1409 the case binder is guaranteed dead.
1410
1411 Note [Improving seq]
1412 ~~~~~~~~~~~~~~~~~~~
1413 Consider
1414         type family F :: * -> *
1415         type instance F Int = Int
1416
1417         ... case e of x { DEFAULT -> rhs } ...
1418
1419 where x::F Int.  Then we'd like to rewrite (F Int) to Int, getting
1420
1421         case e `cast` co of x'::Int
1422            I# x# -> let x = x' `cast` sym co
1423                     in rhs
1424
1425 so that 'rhs' can take advantage of the form of x'.  Notice that Note
1426 [Case of cast] may then apply to the result.
1427
1428 This showed up in Roman's experiments.  Example:
1429   foo :: F Int -> Int -> Int
1430   foo t n = t `seq` bar n
1431      where
1432        bar 0 = 0
1433        bar n = bar (n - case t of TI i -> i)
1434 Here we'd like to avoid repeated evaluating t inside the loop, by
1435 taking advantage of the `seq`.
1436
1437 At one point I did transformation in LiberateCase, but it's more robust here.
1438 (Otherwise, there's a danger that we'll simply drop the 'seq' altogether, before
1439 LiberateCase gets to see it.)
1440
1441
1442 Historical note [no-case-of-case]
1443 ~~~~~~~~~~~~~~~~~~~~~~
1444 We *used* to suppress the binder-swap in case expressoins when
1445 -fno-case-of-case is on.  Old remarks:
1446     "This happens in the first simplifier pass,
1447     and enhances full laziness.  Here's the bad case:
1448             f = \ y -> ...(case x of I# v -> ...(case x of ...) ... )
1449     If we eliminate the inner case, we trap it inside the I# v -> arm,
1450     which might prevent some full laziness happening.  I've seen this
1451     in action in spectral/cichelli/Prog.hs:
1452              [(m,n) | m <- [1..max], n <- [1..max]]
1453     Hence the check for NoCaseOfCase."
1454 However, now the full-laziness pass itself reverses the binder-swap, so this
1455 check is no longer necessary.
1456
1457 Historical note [Suppressing the case binder-swap]
1458 ~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~
1459 There is another situation when it might make sense to suppress the
1460 case-expression binde-swap. If we have
1461
1462     case x of w1 { DEFAULT -> case x of w2 { A -> e1; B -> e2 }
1463                    ...other cases .... }
1464
1465 We'll perform the binder-swap for the outer case, giving
1466
1467     case x of w1 { DEFAULT -> case w1 of w2 { A -> e1; B -> e2 }
1468                    ...other cases .... }
1469
1470 But there is no point in doing it for the inner case, because w1 can't
1471 be inlined anyway.  Furthermore, doing the case-swapping involves
1472 zapping w2's occurrence info (see paragraphs that follow), and that
1473 forces us to bind w2 when doing case merging.  So we get
1474
1475     case x of w1 { A -> let w2 = w1 in e1
1476                    B -> let w2 = w1 in e2
1477                    ...other cases .... }
1478
1479 This is plain silly in the common case where w2 is dead.
1480
1481 Even so, I can't see a good way to implement this idea.  I tried
1482 not doing the binder-swap if the scrutinee was already evaluated
1483 but that failed big-time:
1484
1485         data T = MkT !Int
1486
1487         case v of w  { MkT x ->
1488         case x of x1 { I# y1 ->
1489         case x of x2 { I# y2 -> ...
1490
1491 Notice that because MkT is strict, x is marked "evaluated".  But to
1492 eliminate the last case, we must either make sure that x (as well as
1493 x1) has unfolding MkT y1.  THe straightforward thing to do is to do
1494 the binder-swap.  So this whole note is a no-op.
1495
1496
1497 \begin{code}
1498 improveSeq :: (FamInstEnv, FamInstEnv) -> SimplEnv
1499            -> OutExpr -> InId -> OutId -> [InAlt]
1500            -> SimplM (SimplEnv, OutExpr, OutId)
1501 -- Note [Improving seq]
1502 improveSeq fam_envs env scrut case_bndr case_bndr1 [(DEFAULT,_,_)]
1503   | Just (co, ty2) <- topNormaliseType fam_envs (idType case_bndr1)
1504   =  do { case_bndr2 <- newId (fsLit "nt") ty2
1505         ; let rhs  = DoneEx (Var case_bndr2 `Cast` mkSymCoercion co)
1506               env2 = extendIdSubst env case_bndr rhs
1507         ; return (env2, scrut `Cast` co, case_bndr2) }
1508
1509 improveSeq _ env scrut _ case_bndr1 _
1510   = return (env, scrut, case_bndr1)
1511
1512 {-
1513     improve_case_bndr env scrut case_bndr
1514         -- See Note [no-case-of-case]
1515         --  | switchIsOn (getSwitchChecker env) NoCaseOfCase
1516         --  = (env, case_bndr)
1517
1518         | otherwise     -- Failed try; see Note [Suppressing the case binder-swap]
1519                         --     not (isEvaldUnfolding (idUnfolding v))
1520         = case scrut of
1521             Var v -> (modifyInScope env1 v case_bndr', case_bndr')
1522                 -- Note about using modifyInScope for v here
1523                 -- We could extend the substitution instead, but it would be
1524                 -- a hack because then the substitution wouldn't be idempotent
1525                 -- any more (v is an OutId).  And this does just as well.
1526
1527             Cast (Var v) co -> (addBinderUnfolding env1 v rhs, case_bndr')
1528                             where
1529                                 rhs = Cast (Var case_bndr') (mkSymCoercion co)
1530
1531             _ -> (env, case_bndr)
1532         where
1533           case_bndr' = zapIdOccInfo case_bndr
1534           env1       = modifyInScope env case_bndr case_bndr'
1535 -}
1536 \end{code}
1537
1538
1539 simplAlts does two things:
1540
1541 1.  Eliminate alternatives that cannot match, including the
1542     DEFAULT alternative.
1543
1544 2.  If the DEFAULT alternative can match only one possible constructor,
1545     then make that constructor explicit.
1546     e.g.
1547         case e of x { DEFAULT -> rhs }
1548      ===>
1549         case e of x { (a,b) -> rhs }
1550     where the type is a single constructor type.  This gives better code
1551     when rhs also scrutinises x or e.
1552
1553 Here "cannot match" includes knowledge from GADTs
1554
1555 It's a good idea do do this stuff before simplifying the alternatives, to
1556 avoid simplifying alternatives we know can't happen, and to come up with
1557 the list of constructors that are handled, to put into the IdInfo of the
1558 case binder, for use when simplifying the alternatives.
1559
1560 Eliminating the default alternative in (1) isn't so obvious, but it can
1561 happen:
1562
1563 data Colour = Red | Green | Blue
1564
1565 f x = case x of
1566         Red -> ..
1567         Green -> ..
1568         DEFAULT -> h x
1569
1570 h y = case y of
1571         Blue -> ..
1572         DEFAULT -> [ case y of ... ]
1573
1574 If we inline h into f, the default case of the inlined h can't happen.
1575 If we don't notice this, we may end up filtering out *all* the cases
1576 of the inner case y, which give us nowhere to go!
1577
1578
1579 \begin{code}
1580 simplAlts :: SimplEnv
1581           -> OutExpr
1582           -> InId                       -- Case binder
1583           -> [InAlt]                    -- Non-empty
1584           -> SimplCont
1585           -> SimplM (OutExpr, OutId, [OutAlt])  -- Includes the continuation
1586 -- Like simplExpr, this just returns the simplified alternatives;
1587 -- it not return an environment
1588
1589 simplAlts env scrut case_bndr alts cont'
1590   = -- pprTrace "simplAlts" (ppr alts $$ ppr (seIdSubst env)) $
1591     do  { let env0 = zapFloats env
1592
1593         ; (env1, case_bndr1) <- simplBinder env0 case_bndr
1594
1595         ; fam_envs <- getFamEnvs
1596         ; (alt_env', scrut', case_bndr') <- improveSeq fam_envs env1 scrut
1597                                                        case_bndr case_bndr1 alts
1598
1599         ; (imposs_deflt_cons, in_alts) <- prepareAlts alt_env' scrut' case_bndr' alts
1600
1601         ; alts' <- mapM (simplAlt alt_env' imposs_deflt_cons case_bndr' cont') in_alts
1602         ; return (scrut', case_bndr', alts') }
1603
1604 ------------------------------------
1605 simplAlt :: SimplEnv
1606          -> [AltCon]    -- These constructors can't be present when
1607                         -- matching the DEFAULT alternative
1608          -> OutId       -- The case binder
1609          -> SimplCont
1610          -> InAlt
1611          -> SimplM OutAlt
1612
1613 simplAlt env imposs_deflt_cons case_bndr' cont' (DEFAULT, bndrs, rhs)
1614   = ASSERT( null bndrs )
1615     do  { let env' = addBinderOtherCon env case_bndr' imposs_deflt_cons
1616                 -- Record the constructors that the case-binder *can't* be.
1617         ; rhs' <- simplExprC env' rhs cont'
1618         ; return (DEFAULT, [], rhs') }
1619
1620 simplAlt env _ case_bndr' cont' (LitAlt lit, bndrs, rhs)
1621   = ASSERT( null bndrs )
1622     do  { let env' = addBinderUnfolding env case_bndr' (Lit lit)
1623         ; rhs' <- simplExprC env' rhs cont'
1624         ; return (LitAlt lit, [], rhs') }
1625
1626 simplAlt env _ case_bndr' cont' (DataAlt con, vs, rhs)
1627   = do  {       -- Deal with the pattern-bound variables
1628                 -- Mark the ones that are in ! positions in the
1629                 -- data constructor as certainly-evaluated.
1630                 -- NB: simplLamBinders preserves this eval info
1631           let vs_with_evals = add_evals (dataConRepStrictness con)
1632         ; (env', vs') <- simplLamBndrs env vs_with_evals
1633
1634                 -- Bind the case-binder to (con args)
1635         ; let inst_tys' = tyConAppArgs (idType case_bndr')
1636               con_args  = map Type inst_tys' ++ varsToCoreExprs vs'
1637               env''     = addBinderUnfolding env' case_bndr'
1638                                              (mkConApp con con_args)
1639
1640         ; rhs' <- simplExprC env'' rhs cont'
1641         ; return (DataAlt con, vs', rhs') }
1642   where
1643         -- add_evals records the evaluated-ness of the bound variables of
1644         -- a case pattern.  This is *important*.  Consider
1645         --      data T = T !Int !Int
1646         --
1647         --      case x of { T a b -> T (a+1) b }
1648         --
1649         -- We really must record that b is already evaluated so that we don't
1650         -- go and re-evaluate it when constructing the result.
1651         -- See Note [Data-con worker strictness] in MkId.lhs
1652     add_evals the_strs
1653         = go vs the_strs
1654         where
1655           go [] [] = []
1656           go (v:vs') strs | isTyVar v = v : go vs' strs
1657           go (v:vs') (str:strs)
1658             | isMarkedStrict str = evald_v  : go vs' strs
1659             | otherwise          = zapped_v : go vs' strs
1660             where
1661               zapped_v = zap_occ_info v
1662               evald_v  = zapped_v `setIdUnfolding` evaldUnfolding
1663           go _ _ = pprPanic "cat_evals" (ppr con $$ ppr vs $$ ppr the_strs)
1664
1665         -- See Note [zapOccInfo]
1666         -- zap_occ_info: if the case binder is alive, then we add the unfolding
1667         --      case_bndr = C vs
1668         -- to the envt; so vs are now very much alive
1669         -- Note [Aug06] I can't see why this actually matters, but it's neater
1670         --        case e of t { (a,b) -> ...(case t of (p,q) -> p)... }
1671         --   ==>  case e of t { (a,b) -> ...(a)... }
1672         -- Look, Ma, a is alive now.
1673     zap_occ_info = zapCasePatIdOcc case_bndr'
1674
1675 addBinderUnfolding :: SimplEnv -> Id -> CoreExpr -> SimplEnv
1676 addBinderUnfolding env bndr rhs
1677   = modifyInScope env (bndr `setIdUnfolding` mkUnfolding False rhs)
1678
1679 addBinderOtherCon :: SimplEnv -> Id -> [AltCon] -> SimplEnv
1680 addBinderOtherCon env bndr cons
1681   = modifyInScope env (bndr `setIdUnfolding` mkOtherCon cons)
1682
1683 zapCasePatIdOcc :: Id -> Id -> Id
1684 -- Consider  case e of b { (a,b) -> ... }
1685 -- Then if we bind b to (a,b) in "...", and b is not dead,
1686 -- then we must zap the deadness info on a,b
1687 zapCasePatIdOcc case_bndr
1688   | isDeadBinder case_bndr = \ pat_id -> pat_id
1689   | otherwise              = \ pat_id -> zapIdOccInfo pat_id
1690 \end{code}
1691
1692
1693 %************************************************************************
1694 %*                                                                      *
1695 \subsection{Known constructor}
1696 %*                                                                      *
1697 %************************************************************************
1698
1699 We are a bit careful with occurrence info.  Here's an example
1700
1701         (\x* -> case x of (a*, b) -> f a) (h v, e)
1702
1703 where the * means "occurs once".  This effectively becomes
1704         case (h v, e) of (a*, b) -> f a)
1705 and then
1706         let a* = h v; b = e in f a
1707 and then
1708         f (h v)
1709
1710 All this should happen in one sweep.
1711
1712 \begin{code}
1713 knownCon :: SimplEnv -> OutExpr -> AltCon
1714          -> [OutExpr]           -- Args *including* the universal args
1715          -> InId -> [InAlt] -> SimplCont
1716          -> SimplM (SimplEnv, OutExpr)
1717
1718 knownCon env scrut con args bndr alts cont
1719   = do  { tick (KnownBranch bndr)
1720         ; knownAlt env scrut args bndr (findAlt con alts) cont }
1721
1722 knownAlt :: SimplEnv -> OutExpr -> [OutExpr]
1723          -> InId -> (AltCon, [CoreBndr], InExpr) -> SimplCont
1724          -> SimplM (SimplEnv, OutExpr)
1725 knownAlt env scrut _ bndr (DEFAULT, bs, rhs) cont
1726   = ASSERT( null bs )
1727     do  { env' <- simplNonRecX env bndr scrut
1728                 -- This might give rise to a binding with non-atomic args
1729                 -- like x = Node (f x) (g x)
1730                 -- but simplNonRecX will atomic-ify it
1731         ; simplExprF env' rhs cont }
1732
1733 knownAlt env scrut _ bndr (LitAlt _, bs, rhs) cont
1734   = ASSERT( null bs )
1735     do  { env' <- simplNonRecX env bndr scrut
1736         ; simplExprF env' rhs cont }
1737
1738 knownAlt env scrut the_args bndr (DataAlt dc, bs, rhs) cont
1739   = do  { let n_drop_tys = length (dataConUnivTyVars dc)
1740         ; env' <- bind_args env bs (drop n_drop_tys the_args)
1741         ; let
1742                 -- It's useful to bind bndr to scrut, rather than to a fresh
1743                 -- binding      x = Con arg1 .. argn
1744                 -- because very often the scrut is a variable, so we avoid
1745                 -- creating, and then subsequently eliminating, a let-binding
1746                 -- BUT, if scrut is a not a variable, we must be careful
1747                 -- about duplicating the arg redexes; in that case, make
1748                 -- a new con-app from the args
1749                 bndr_rhs  = case scrut of
1750                                 Var _ -> scrut
1751                                 _     -> con_app
1752                 con_app = mkConApp dc (take n_drop_tys the_args ++ con_args)
1753                 con_args = [substExpr env' (varToCoreExpr b) | b <- bs]
1754                                 -- args are aready OutExprs, but bs are InIds
1755
1756         ; env'' <- simplNonRecX env' bndr bndr_rhs
1757         ; simplExprF env'' rhs cont }
1758   where
1759     zap_occ = zapCasePatIdOcc bndr    -- bndr is an InId
1760
1761                   -- Ugh!
1762     bind_args env' [] _  = return env'
1763
1764     bind_args env' (b:bs') (Type ty : args)
1765       = ASSERT( isTyVar b )
1766         bind_args (extendTvSubst env' b ty) bs' args
1767
1768     bind_args env' (b:bs') (arg : args)
1769       = ASSERT( isId b )
1770         do { let b' = zap_occ b
1771              -- Note that the binder might be "dead", because it doesn't
1772              -- occur in the RHS; and simplNonRecX may therefore discard
1773              -- it via postInlineUnconditionally.
1774              -- Nevertheless we must keep it if the case-binder is alive,
1775              -- because it may be used in the con_app.  See Note [zapOccInfo]
1776            ; env'' <- simplNonRecX env' b' arg
1777            ; bind_args env'' bs' args }
1778
1779     bind_args _ _ _ =
1780       pprPanic "bind_args" $ ppr dc $$ ppr bs $$ ppr the_args $$
1781                              text "scrut:" <+> ppr scrut
1782 \end{code}
1783
1784
1785 %************************************************************************
1786 %*                                                                      *
1787 \subsection{Duplicating continuations}
1788 %*                                                                      *
1789 %************************************************************************
1790
1791 \begin{code}
1792 prepareCaseCont :: SimplEnv
1793                 -> [InAlt] -> SimplCont
1794                 -> SimplM (SimplEnv, SimplCont,SimplCont)
1795                         -- Return a duplicatable continuation, a non-duplicable part
1796                         -- plus some extra bindings (that scope over the entire
1797                         -- continunation)
1798
1799         -- No need to make it duplicatable if there's only one alternative
1800 prepareCaseCont env [_] cont = return (env, cont, mkBoringStop)
1801 prepareCaseCont env _   cont = mkDupableCont env cont
1802 \end{code}
1803
1804 \begin{code}
1805 mkDupableCont :: SimplEnv -> SimplCont
1806               -> SimplM (SimplEnv, SimplCont, SimplCont)
1807
1808 mkDupableCont env cont
1809   | contIsDupable cont
1810   = return (env, cont, mkBoringStop)
1811
1812 mkDupableCont _   (Stop {}) = panic "mkDupableCont"     -- Handled by previous eqn
1813
1814 mkDupableCont env (CoerceIt ty cont)
1815   = do  { (env', dup, nodup) <- mkDupableCont env cont
1816         ; return (env', CoerceIt ty dup, nodup) }
1817
1818 mkDupableCont env cont@(StrictBind {})
1819   =  return (env, mkBoringStop, cont)
1820         -- See Note [Duplicating strict continuations]
1821
1822 mkDupableCont env cont@(StrictArg {})
1823   =  return (env, mkBoringStop, cont)
1824         -- See Note [Duplicating strict continuations]
1825
1826 mkDupableCont env (ApplyTo _ arg se cont)
1827   =     -- e.g.         [...hole...] (...arg...)
1828         --      ==>
1829         --              let a = ...arg...
1830         --              in [...hole...] a
1831     do  { (env', dup_cont, nodup_cont) <- mkDupableCont env cont
1832         ; arg' <- simplExpr (se `setInScope` env') arg
1833         ; (env'', arg'') <- makeTrivial env' arg'
1834         ; let app_cont = ApplyTo OkToDup arg'' (zapSubstEnv env'') dup_cont
1835         ; return (env'', app_cont, nodup_cont) }
1836
1837 mkDupableCont env cont@(Select _ case_bndr [(_, bs, _rhs)] _ _)
1838 --  See Note [Single-alternative case]
1839 --  | not (exprIsDupable rhs && contIsDupable case_cont)
1840 --  | not (isDeadBinder case_bndr)
1841   | all isDeadBinder bs  -- InIds
1842     && not (isUnLiftedType (idType case_bndr))
1843     -- Note [Single-alternative-unlifted]
1844   = return (env, mkBoringStop, cont)
1845
1846 mkDupableCont env (Select _ case_bndr alts se cont)
1847   =     -- e.g.         (case [...hole...] of { pi -> ei })
1848         --      ===>
1849         --              let ji = \xij -> ei
1850         --              in case [...hole...] of { pi -> ji xij }
1851     do  { tick (CaseOfCase case_bndr)
1852         ; (env', dup_cont, nodup_cont) <- mkDupableCont env cont
1853                 -- NB: call mkDupableCont here, *not* prepareCaseCont
1854                 -- We must make a duplicable continuation, whereas prepareCaseCont
1855                 -- doesn't when there is a single case branch
1856
1857         ; let alt_env = se `setInScope` env'
1858         ; (alt_env', case_bndr') <- simplBinder alt_env case_bndr
1859         ; alts' <- mapM (simplAlt alt_env' [] case_bndr' dup_cont) alts
1860         -- Safe to say that there are no handled-cons for the DEFAULT case
1861                 -- NB: simplBinder does not zap deadness occ-info, so
1862                 -- a dead case_bndr' will still advertise its deadness
1863                 -- This is really important because in
1864                 --      case e of b { (# p,q #) -> ... }
1865                 -- b is always dead, and indeed we are not allowed to bind b to (# p,q #),
1866                 -- which might happen if e was an explicit unboxed pair and b wasn't marked dead.
1867                 -- In the new alts we build, we have the new case binder, so it must retain
1868                 -- its deadness.
1869         -- NB: we don't use alt_env further; it has the substEnv for
1870         --     the alternatives, and we don't want that
1871
1872         ; (env'', alts'') <- mkDupableAlts env' case_bndr' alts'
1873         ; return (env'',  -- Note [Duplicated env]
1874                   Select OkToDup case_bndr' alts'' (zapSubstEnv env'') mkBoringStop,
1875                   nodup_cont) }
1876
1877
1878 mkDupableAlts :: SimplEnv -> OutId -> [InAlt]
1879               -> SimplM (SimplEnv, [InAlt])
1880 -- Absorbs the continuation into the new alternatives
1881
1882 mkDupableAlts env case_bndr' the_alts
1883   = go env the_alts
1884   where
1885     go env0 [] = return (env0, [])
1886     go env0 (alt:alts)
1887         = do { (env1, alt') <- mkDupableAlt env0 case_bndr' alt
1888              ; (env2, alts') <- go env1 alts
1889              ; return (env2, alt' : alts' ) }
1890
1891 mkDupableAlt :: SimplEnv -> OutId -> (AltCon, [CoreBndr], CoreExpr)
1892               -> SimplM (SimplEnv, (AltCon, [CoreBndr], CoreExpr))
1893 mkDupableAlt env case_bndr1 (con, bndrs1, rhs1)
1894   | exprIsDupable rhs1  -- Note [Small alternative rhs]
1895   = return (env, (con, bndrs1, rhs1))
1896   | otherwise
1897   = do  { let abstract_over bndr
1898                   | isTyVar bndr = True -- Abstract over all type variables just in case
1899                   | otherwise    = not (isDeadBinder bndr)
1900                         -- The deadness info on the new Ids is preserved by simplBinders
1901
1902               inst_tys1 = tyConAppArgs (idType case_bndr1)
1903               con_app dc = mkConApp dc (map Type inst_tys1 ++ varsToCoreExprs bndrs1)
1904
1905               (rhs2, final_bndrs)   -- See Note [Passing the case binder to join points]
1906                  | isDeadBinder case_bndr1
1907                  = (rhs1, filter abstract_over bndrs1)
1908                  | opt_PassCaseBndrToJoinPoints, not (null bndrs1)
1909                  = (rhs1, (case_bndr1 : filter abstract_over bndrs1))
1910                  | otherwise
1911                  = case con of
1912                      DataAlt dc -> (Let (NonRec case_bndr1 (con_app dc)) rhs1, bndrs1)
1913                      LitAlt lit -> ASSERT( null bndrs1 ) (Let (NonRec case_bndr1 (Lit lit)) rhs1, [])
1914                      DEFAULT    -> ASSERT( null bndrs1 ) (rhs1, [case_bndr1])
1915
1916         ; (final_bndrs1, final_args)    -- Note [Join point abstraction]
1917                 <- if (any isId final_bndrs)
1918                    then return (final_bndrs, varsToCoreExprs final_bndrs)
1919                     else do { rw_id <- newId (fsLit "w") realWorldStatePrimTy
1920                             ; return (rw_id : final_bndrs,
1921                                       Var realWorldPrimId : varsToCoreExprs final_bndrs) }
1922
1923         ; let rhs_ty1 = exprType rhs1
1924         ; join_bndr <- newId (fsLit "$j") (mkPiTypes final_bndrs1 rhs_ty1)
1925                 -- Note [Funky mkPiTypes]
1926
1927         ; let   -- We make the lambdas into one-shot-lambdas.  The
1928                 -- join point is sure to be applied at most once, and doing so
1929                 -- prevents the body of the join point being floated out by
1930                 -- the full laziness pass
1931                 really_final_bndrs     = map one_shot final_bndrs1
1932                 one_shot v | isId v    = setOneShotLambda v
1933                            | otherwise = v
1934                 join_rhs  = mkLams really_final_bndrs rhs2
1935                 join_call = mkApps (Var join_bndr) final_args
1936
1937         ; env1 <- addPolyBind NotTopLevel env (NonRec join_bndr join_rhs)
1938         ; return (env1, (con, bndrs1, join_call)) }
1939                 -- See Note [Duplicated env]
1940 \end{code}
1941
1942 Note [Passing the case binder to join points]
1943 ~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~
1944 Suppose we have
1945    case e of cb { C1 -> r1[cb]; C2 x y z -> r2[cb,x] }
1946 and we want to make join points for the two alternatives,
1947 which mention the case binder 'cb'.  Should we pass 'cb' to
1948 the join point, or reconstruct it? Here are the two alternatives
1949 for the C2 alternative:
1950
1951   Plan A(pass cb):         j2 cb x = r2[cb,x]
1952
1953   Plan B(reconstruct cb):  j2 x y z = let cb = C2 x y z in r2[cb,x]
1954
1955 The advantge of Plan B is that we can "see" the definition of cb
1956 in r2, and that may be important when we inline stuff in r2.  The
1957 disadvantage is that if this optimisation doesn't happen, we end up
1958 re-allocating C2, when it already exists.  This does happen occasionally;
1959 an example is the function nofib/spectral/cichelli/Auxil.$whinsert.
1960
1961 Plan B is always better if the constructor is nullary.
1962
1963 In both cases we don't have liveness info for cb on a branch-by-branch
1964 basis, and it's possible that 'cb' is used in some branches but not
1965 others.  Well, the absence analyser will find that out later, so it's
1966 not too bad.
1967
1968 Sadly, at the time of writing, neither choice seems an unequivocal
1969 win. Here are nofib results, for adding -fpass-case-bndr-to-join-points
1970 (all others are zero effect):
1971
1972         Program           Size    Allocs   Runtime   Elapsed
1973 --------------------------------------------------------------------------------
1974        cichelli          +0.0%     -4.4%      0.13      0.13
1975             pic          +0.0%     -0.7%      0.01      0.04
1976       transform          -0.0%     +2.8%     -0.4%     -9.1%
1977       wave4main          +0.0%    +10.5%     +3.1%     +3.4%
1978 --------------------------------------------------------------------------------
1979             Min          -0.0%     -4.4%     -7.0%    -31.9%
1980             Max          +0.1%    +10.5%     +3.1%    +15.0%
1981  Geometric Mean          +0.0%     +0.1%     -1.7%     -6.1%
1982
1983
1984 Note [Duplicated env]
1985 ~~~~~~~~~~~~~~~~~~~~~
1986 Some of the alternatives are simplified, but have not been turned into a join point
1987 So they *must* have an zapped subst-env.  So we can't use completeNonRecX to
1988 bind the join point, because it might to do PostInlineUnconditionally, and
1989 we'd lose that when zapping the subst-env.  We could have a per-alt subst-env,
1990 but zapping it (as we do in mkDupableCont, the Select case) is safe, and
1991 at worst delays the join-point inlining.
1992
1993 Note [Small alterantive rhs]
1994 ~~~~~~~~~~~~~~~~~~~~~~~~~~~~
1995 It is worth checking for a small RHS because otherwise we
1996 get extra let bindings that may cause an extra iteration of the simplifier to
1997 inline back in place.  Quite often the rhs is just a variable or constructor.
1998 The Ord instance of Maybe in PrelMaybe.lhs, for example, took several extra
1999 iterations because the version with the let bindings looked big, and so wasn't
2000 inlined, but after the join points had been inlined it looked smaller, and so
2001 was inlined.
2002
2003 NB: we have to check the size of rhs', not rhs.
2004 Duplicating a small InAlt might invalidate occurrence information
2005 However, if it *is* dupable, we return the *un* simplified alternative,
2006 because otherwise we'd need to pair it up with an empty subst-env....
2007 but we only have one env shared between all the alts.
2008 (Remember we must zap the subst-env before re-simplifying something).
2009 Rather than do this we simply agree to re-simplify the original (small) thing later.
2010
2011 Note [Funky mkPiTypes]
2012 ~~~~~~~~~~~~~~~~~~~~~~
2013 Notice the funky mkPiTypes.  If the contructor has existentials
2014 it's possible that the join point will be abstracted over
2015 type varaibles as well as term variables.
2016  Example:  Suppose we have
2017         data T = forall t.  C [t]
2018  Then faced with
2019         case (case e of ...) of
2020             C t xs::[t] -> rhs
2021  We get the join point
2022         let j :: forall t. [t] -> ...
2023             j = /\t \xs::[t] -> rhs
2024         in
2025         case (case e of ...) of
2026             C t xs::[t] -> j t xs
2027
2028 Note [Join point abstaction]
2029 ~~~~~~~~~~~~~~~~~~~~~~~~~~~~
2030 If we try to lift a primitive-typed something out
2031 for let-binding-purposes, we will *caseify* it (!),
2032 with potentially-disastrous strictness results.  So
2033 instead we turn it into a function: \v -> e
2034 where v::State# RealWorld#.  The value passed to this function
2035 is realworld#, which generates (almost) no code.
2036
2037 There's a slight infelicity here: we pass the overall
2038 case_bndr to all the join points if it's used in *any* RHS,
2039 because we don't know its usage in each RHS separately
2040
2041 We used to say "&& isUnLiftedType rhs_ty'" here, but now
2042 we make the join point into a function whenever used_bndrs'
2043 is empty.  This makes the join-point more CPR friendly.
2044 Consider:       let j = if .. then I# 3 else I# 4
2045                 in case .. of { A -> j; B -> j; C -> ... }
2046
2047 Now CPR doesn't w/w j because it's a thunk, so
2048 that means that the enclosing function can't w/w either,
2049 which is a lose.  Here's the example that happened in practice:
2050         kgmod :: Int -> Int -> Int
2051         kgmod x y = if x > 0 && y < 0 || x < 0 && y > 0
2052                     then 78
2053                     else 5
2054
2055 I have seen a case alternative like this:
2056         True -> \v -> ...
2057 It's a bit silly to add the realWorld dummy arg in this case, making
2058         $j = \s v -> ...
2059            True -> $j s
2060 (the \v alone is enough to make CPR happy) but I think it's rare
2061
2062 Note [Duplicating strict continuations]
2063 ~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~
2064 Do *not* duplicate StrictBind and StritArg continuations.  We gain
2065 nothing by propagating them into the expressions, and we do lose a
2066 lot.  Here's an example:
2067         && (case x of { T -> F; F -> T }) E
2068 Now, && is strict so we end up simplifying the case with
2069 an ArgOf continuation.  If we let-bind it, we get
2070
2071         let $j = \v -> && v E
2072         in simplExpr (case x of { T -> F; F -> T })
2073                      (ArgOf (\r -> $j r)
2074 And after simplifying more we get
2075
2076         let $j = \v -> && v E
2077         in case x of { T -> $j F; F -> $j T }
2078 Which is a Very Bad Thing
2079
2080 The desire not to duplicate is the entire reason that
2081 mkDupableCont returns a pair of continuations.
2082
2083 The original plan had:
2084 e.g.    (...strict-fn...) [...hole...]
2085         ==>
2086                 let $j = \a -> ...strict-fn...
2087                 in $j [...hole...]
2088
2089 Note [Single-alternative cases]
2090 ~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~
2091 This case is just like the ArgOf case.  Here's an example:
2092         data T a = MkT !a
2093         ...(MkT (abs x))...
2094 Then we get
2095         case (case x of I# x' ->
2096               case x' <# 0# of
2097                 True  -> I# (negate# x')
2098                 False -> I# x') of y {
2099           DEFAULT -> MkT y
2100 Because the (case x) has only one alternative, we'll transform to
2101         case x of I# x' ->
2102         case (case x' <# 0# of
2103                 True  -> I# (negate# x')
2104                 False -> I# x') of y {
2105           DEFAULT -> MkT y
2106 But now we do *NOT* want to make a join point etc, giving
2107         case x of I# x' ->
2108         let $j = \y -> MkT y
2109         in case x' <# 0# of
2110                 True  -> $j (I# (negate# x'))
2111                 False -> $j (I# x')
2112 In this case the $j will inline again, but suppose there was a big
2113 strict computation enclosing the orginal call to MkT.  Then, it won't
2114 "see" the MkT any more, because it's big and won't get duplicated.
2115 And, what is worse, nothing was gained by the case-of-case transform.
2116
2117 When should use this case of mkDupableCont?
2118 However, matching on *any* single-alternative case is a *disaster*;
2119   e.g.  case (case ....) of (a,b) -> (# a,b #)
2120   We must push the outer case into the inner one!
2121 Other choices:
2122
2123    * Match [(DEFAULT,_,_)], but in the common case of Int,
2124      the alternative-filling-in code turned the outer case into
2125                 case (...) of y { I# _ -> MkT y }
2126
2127    * Match on single alternative plus (not (isDeadBinder case_bndr))
2128      Rationale: pushing the case inwards won't eliminate the construction.
2129      But there's a risk of
2130                 case (...) of y { (a,b) -> let z=(a,b) in ... }
2131      Now y looks dead, but it'll come alive again.  Still, this
2132      seems like the best option at the moment.
2133
2134    * Match on single alternative plus (all (isDeadBinder bndrs))
2135      Rationale: this is essentially  seq.
2136
2137    * Match when the rhs is *not* duplicable, and hence would lead to a
2138      join point.  This catches the disaster-case above.  We can test
2139      the *un-simplified* rhs, which is fine.  It might get bigger or
2140      smaller after simplification; if it gets smaller, this case might
2141      fire next time round.  NB also that we must test contIsDupable
2142      case_cont *btoo, because case_cont might be big!
2143
2144      HOWEVER: I found that this version doesn't work well, because
2145      we can get         let x = case (...) of { small } in ...case x...
2146      When x is inlined into its full context, we find that it was a bad
2147      idea to have pushed the outer case inside the (...) case.
2148
2149 Note [Single-alternative-unlifted]
2150 ~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~
2151 Here's another single-alternative where we really want to do case-of-case:
2152
2153 data Mk1 = Mk1 Int#
2154 data Mk1 = Mk2 Int#
2155
2156 M1.f =
2157     \r [x_s74 y_s6X]
2158         case
2159             case y_s6X of tpl_s7m {
2160               M1.Mk1 ipv_s70 -> ipv_s70;
2161               M1.Mk2 ipv_s72 -> ipv_s72;
2162             }
2163         of
2164         wild_s7c
2165         { __DEFAULT ->
2166               case
2167                   case x_s74 of tpl_s7n {
2168                     M1.Mk1 ipv_s77 -> ipv_s77;
2169                     M1.Mk2 ipv_s79 -> ipv_s79;
2170                   }
2171               of
2172               wild1_s7b
2173               { __DEFAULT -> ==# [wild1_s7b wild_s7c];
2174               };
2175         };
2176
2177 So the outer case is doing *nothing at all*, other than serving as a
2178 join-point.  In this case we really want to do case-of-case and decide
2179 whether to use a real join point or just duplicate the continuation.
2180
2181 Hence: check whether the case binder's type is unlifted, because then
2182 the outer case is *not* a seq.