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