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