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