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