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         -- Beta reduction
 868 simplLam env (bndr:bndrs) body (ApplyTo _ arg arg_se cont)
 869   = do  { tick (BetaReduction bndr)
 870         ; simplNonRecE env bndr (arg, arg_se) (bndrs, body) cont }
 871
 872         -- Not enough args, so there are real lambdas left to put in the result
 873 simplLam env bndrs body cont
 874   = do  { (env', bndrs') <- simplLamBndrs env bndrs
 875         ; body' <- simplExpr env' body
 876         ; new_lam <- mkLam bndrs' body'
 877         ; rebuild env' new_lam cont }
 878
 879 ------------------
 880 simplNonRecE :: SimplEnv
 881              -> InId                    -- The binder
 882              -> (InExpr, SimplEnv)      -- Rhs of binding (or arg of lambda)
 883              -> ([InBndr], InExpr)      -- Body of the let/lambda
 884                                         --      \xs.e
 885              -> SimplCont
 886              -> SimplM (SimplEnv, OutExpr)
 887
 888 -- simplNonRecE is used for
 889 --  * non-top-level non-recursive lets in expressions
 890 --  * beta reduction
 891 --
 892 -- It deals with strict bindings, via the StrictBind continuation,
 893 -- which may abort the whole process
 894 --
 895 -- The "body" of the binding comes as a pair of ([InId],InExpr)
 896 -- representing a lambda; so we recurse back to simplLam
 897 -- Why?  Because of the binder-occ-info-zapping done before
 898 --       the call to simplLam in simplExprF (Lam ...)
 899
 900         -- First deal with type applications and type lets
 901         --   (/\a. e) (Type ty)   and   (let a = Type ty in e)
 902 simplNonRecE env bndr (Type ty_arg, rhs_se) (bndrs, body) cont
 903   = ASSERT( isTyVar bndr )
 904     do  { ty_arg' <- simplType (rhs_se `setInScope` env) ty_arg
 905         ; simplLam (extendTvSubst env bndr ty_arg') bndrs body cont }
 906
 907 simplNonRecE env bndr (rhs, rhs_se) (bndrs, body) cont
 908   | preInlineUnconditionally env NotTopLevel bndr rhs
 909   = do  { tick (PreInlineUnconditionally bndr)
 910         ; simplLam (extendIdSubst env bndr (mkContEx rhs_se rhs)) bndrs body cont }
 911
 912   | isStrictId bndr
 913   = do  { simplExprF (rhs_se `setFloats` env) rhs
 914                      (StrictBind bndr bndrs body env cont) }
 915
 916   | otherwise
 917   = do  { (env1, bndr1) <- simplNonRecBndr env bndr
 918         ; let (env2, bndr2) = addBndrRules env1 bndr bndr1
 919         ; env3 <- simplLazyBind env2 NotTopLevel NonRecursive bndr bndr2 rhs rhs_se
 920         ; simplLam env3 bndrs body cont }
 921 \end{code}
 922
 923
 924 %************************************************************************
 925 %*                                                                      *
 926 \subsection{Notes}
 927 %*                                                                      *
 928 %************************************************************************
 929
 930 \begin{code}
 931 -- Hack alert: we only distinguish subsumed cost centre stacks for the
 932 -- purposes of inlining.  All other CCCSs are mapped to currentCCS.
 933 simplNote :: SimplEnv -> Note -> CoreExpr -> SimplCont
 934           -> SimplM (SimplEnv, OutExpr)
 935 simplNote env (SCC cc) e cont
 936   = do  { e' <- simplExpr (setEnclosingCC env currentCCS) e
 937         ; rebuild env (mkSCC cc e') cont }
 938
 939 -- See notes with SimplMonad.inlineMode
 940 simplNote env InlineMe e cont
 941   | Just (inside, outside) <- splitInlineCont cont  -- Boring boring continuation; see notes above
 942   = do  {                       -- Don't inline inside an INLINE expression
 943           e' <- simplExprC (setMode inlineMode env) e inside
 944         ; rebuild env (mkInlineMe e') outside }
 945
 946   | otherwise   -- Dissolve the InlineMe note if there's
 947                 -- an interesting context of any kind to combine with
 948                 -- (even a type application -- anything except Stop)
 949   = simplExprF env e cont
 950
 951 simplNote env (CoreNote s) e cont = do
 952     e' <- simplExpr env e
 953     rebuild env (Note (CoreNote s) e') cont
 954 \end{code}
 955
 956
 957 %************************************************************************
 958 %*                                                                      *
 959 \subsection{Dealing with calls}
 960 %*                                                                      *
 961 %************************************************************************
 962
 963 \begin{code}
 964 simplVar :: SimplEnv -> Id -> SimplCont -> SimplM (SimplEnv, OutExpr)
 965 simplVar env var cont
 966   = case substId env var of
 967         DoneEx e         -> simplExprF (zapSubstEnv env) e cont
 968         ContEx tvs ids e -> simplExprF (setSubstEnv env tvs ids) e cont
 969         DoneId var1      -> completeCall (zapSubstEnv env) var1 cont
 970                 -- Note [zapSubstEnv]
 971                 -- The template is already simplified, so don't re-substitute.
 972                 -- This is VITAL.  Consider
 973                 --      let x = e in
 974                 --      let y = \z -> ...x... in
 975                 --      \ x -> ...y...
 976                 -- We'll clone the inner \x, adding x->x' in the id_subst
 977                 -- Then when we inline y, we must *not* replace x by x' in
 978                 -- the inlined copy!!
 979
 980 ---------------------------------------------------------
 981 --      Dealing with a call site
 982
 983 completeCall :: SimplEnv -> Id -> SimplCont -> SimplM (SimplEnv, OutExpr)
 984 completeCall env var cont
 985   = do  { dflags <- getDOptsSmpl
 986         ; let   (args,call_cont) = contArgs cont
 987                 -- The args are OutExprs, obtained by *lazily* substituting
 988                 -- in the args found in cont.  These args are only examined
 989                 -- to limited depth (unless a rule fires).  But we must do
 990                 -- the substitution; rule matching on un-simplified args would
 991                 -- be bogus
 992
 993         ------------- First try rules ----------------
 994         -- Do this before trying inlining.  Some functions have
 995         -- rules *and* are strict; in this case, we don't want to
 996         -- inline the wrapper of the non-specialised thing; better
 997         -- to call the specialised thing instead.
 998         --
 999         -- We used to use the black-listing mechanism to ensure that inlining of
1000         -- the wrapper didn't occur for things that have specialisations till a
1001         -- later phase, so but now we just try RULES first
1002         --
1003         -- Note [Rules for recursive functions]
1004         -- ~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~
1005         -- You might think that we shouldn't apply rules for a loop breaker:
1006         -- doing so might give rise to an infinite loop, because a RULE is
1007         -- rather like an extra equation for the function:
1008         --      RULE:           f (g x) y = x+y
1009         --      Eqn:            f a     y = a-y
1010         --
1011         -- But it's too drastic to disable rules for loop breakers.
1012         -- Even the foldr/build rule would be disabled, because foldr
1013         -- is recursive, and hence a loop breaker:
1014         --      foldr k z (build g) = g k z
1015         -- So it's up to the programmer: rules can cause divergence
1016         ; rules <- getRules
1017         ; let   in_scope   = getInScope env
1018                 maybe_rule = case activeRule dflags env of
1019                                 Nothing     -> Nothing  -- No rules apply
1020                                 Just act_fn -> lookupRule act_fn in_scope
1021                                                           rules var args
1022         ; case maybe_rule of {
1023             Just (rule, rule_rhs) -> do
1024                 tick (RuleFired (ru_name rule))
1025                 (if dopt Opt_D_dump_rule_firings dflags then
1026                    pprTrace "Rule fired" (vcat [
1027                         text "Rule:" <+> ftext (ru_name rule),
1028                         text "Before:" <+> ppr var <+> sep (map pprParendExpr args),
1029                         text "After: " <+> pprCoreExpr rule_rhs,
1030                         text "Cont:  " <+> ppr call_cont])
1031                  else
1032                         id)             $
1033                  simplExprF env rule_rhs (dropArgs (ruleArity rule) cont)
1034                  -- The ruleArity says how many args the rule consumed
1035
1036           ; Nothing -> do       -- No rules
1037
1038         ------------- Next try inlining ----------------
1039         { let   arg_infos = [interestingArg arg | arg <- args, isValArg arg]
1040                 n_val_args = length arg_infos
1041                 interesting_cont = interestingCallContext call_cont
1042                 active_inline = activeInline env var
1043                 maybe_inline  = callSiteInline dflags active_inline var
1044                                                (null args) arg_infos interesting_cont
1045         ; case maybe_inline of {
1046             Just unfolding      -- There is an inlining!
1047               ->  do { tick (UnfoldingDone var)
1048                      ; (if dopt Opt_D_dump_inlinings dflags then
1049                            pprTrace ("Inlining done" ++ showSDoc (ppr var)) (vcat [
1050                                 text "Before:" <+> ppr var <+> sep (map pprParendExpr args),
1051                                 text "Inlined fn: " <+> nest 2 (ppr unfolding),
1052                                 text "Cont:  " <+> ppr call_cont])
1053                          else
1054                                 id)
1055                        simplExprF env unfolding cont }
1056
1057             ; Nothing ->                -- No inlining!
1058
1059         ------------- No inlining! ----------------
1060         -- Next, look for rules or specialisations that match
1061         --
1062         rebuildCall env (Var var)
1063                     (mkArgInfo var n_val_args call_cont) cont
1064     }}}}
1065
1066 rebuildCall :: SimplEnv
1067             -> OutExpr       -- Function
1068             -> ArgInfo
1069             -> SimplCont
1070             -> SimplM (SimplEnv, OutExpr)
1071 rebuildCall env fun (ArgInfo { ai_strs = [] }) cont
1072   -- When we run out of strictness args, it means
1073   -- that the call is definitely bottom; see SimplUtils.mkArgInfo
1074   -- Then we want to discard the entire strict continuation.  E.g.
1075   --    * case (error "hello") of { ... }
1076   --    * (error "Hello") arg
1077   --    * f (error "Hello") where f is strict
1078   --    etc
1079   -- Then, especially in the first of these cases, we'd like to discard
1080   -- the continuation, leaving just the bottoming expression.  But the
1081   -- type might not be right, so we may have to add a coerce.
1082   | not (contIsTrivial cont)     -- Only do this if there is a non-trivial
1083   = return (env, mk_coerce fun)  -- contination to discard, else we do it
1084   where                          -- again and again!
1085     fun_ty  = exprType fun
1086     cont_ty = contResultType env fun_ty cont
1087     co      = mkUnsafeCoercion fun_ty cont_ty
1088     mk_coerce expr | cont_ty `coreEqType` fun_ty = expr
1089                    | otherwise = mkCoerce co expr
1090
1091 rebuildCall env fun info (ApplyTo _ (Type arg_ty) se cont)
1092   = do  { ty' <- simplType (se `setInScope` env) arg_ty
1093         ; rebuildCall env (fun `App` Type ty') info cont }
1094
1095 rebuildCall env fun
1096            (ArgInfo { ai_rules = has_rules, ai_strs = str:strs, ai_discs = disc:discs })
1097            (ApplyTo _ arg arg_se cont)
1098   | str                 -- Strict argument
1099   = -- pprTrace "Strict Arg" (ppr arg $$ ppr (seIdSubst env) $$ ppr (seInScope env)) $
1100     simplExprF (arg_se `setFloats` env) arg
1101                (StrictArg fun cci arg_info' cont)
1102                 -- Note [Shadowing]
1103
1104   | otherwise                           -- Lazy argument
1105         -- DO NOT float anything outside, hence simplExprC
1106         -- There is no benefit (unlike in a let-binding), and we'd
1107         -- have to be very careful about bogus strictness through
1108         -- floating a demanded let.
1109   = do  { arg' <- simplExprC (arg_se `setInScope` env) arg
1110                              (mkLazyArgStop cci)
1111         ; rebuildCall env (fun `App` arg') arg_info' cont }
1112   where
1113     arg_info' = ArgInfo { ai_rules = has_rules, ai_strs = strs, ai_discs = discs }
1114     cci | has_rules || disc > 0 = ArgCtxt has_rules disc  -- Be keener here
1115         | otherwise             = BoringCtxt              -- Nothing interesting
1116
1117 rebuildCall env fun _ cont
1118   = rebuild env fun cont
1119 \end{code}
1120
1121 Note [Shadowing]
1122 ~~~~~~~~~~~~~~~~
1123 This part of the simplifier may break the no-shadowing invariant
1124 Consider
1125         f (...(\a -> e)...) (case y of (a,b) -> e')
1126 where f is strict in its second arg
1127 If we simplify the innermost one first we get (...(\a -> e)...)
1128 Simplifying the second arg makes us float the case out, so we end up with
1129         case y of (a,b) -> f (...(\a -> e)...) e'
1130 So the output does not have the no-shadowing invariant.  However, there is
1131 no danger of getting name-capture, because when the first arg was simplified
1132 we used an in-scope set that at least mentioned all the variables free in its
1133 static environment, and that is enough.
1134
1135 We can't just do innermost first, or we'd end up with a dual problem:
1136         case x of (a,b) -> f e (...(\a -> e')...)
1137
1138 I spent hours trying to recover the no-shadowing invariant, but I just could
1139 not think of an elegant way to do it.  The simplifier is already knee-deep in
1140 continuations.  We have to keep the right in-scope set around; AND we have
1141 to get the effect that finding (error "foo") in a strict arg position will
1142 discard the entire application and replace it with (error "foo").  Getting
1143 all this at once is TOO HARD!
1144
1145 %************************************************************************
1146 %*                                                                      *
1147                 Rebuilding a cse expression
1148 %*                                                                      *
1149 %************************************************************************
1150
1151 Blob of helper functions for the "case-of-something-else" situation.
1152
1153 \begin{code}
1154 ---------------------------------------------------------
1155 --      Eliminate the case if possible
1156
1157 rebuildCase :: SimplEnv
1158             -> OutExpr          -- Scrutinee
1159             -> InId             -- Case binder
1160             -> [InAlt]          -- Alternatives (inceasing order)
1161             -> SimplCont
1162             -> SimplM (SimplEnv, OutExpr)
1163
1164 --------------------------------------------------
1165 --      1. Eliminate the case if there's a known constructor
1166 --------------------------------------------------
1167
1168 rebuildCase env scrut case_bndr alts cont
1169   | Just (con,args) <- exprIsConApp_maybe scrut
1170         -- Works when the scrutinee is a variable with a known unfolding
1171         -- as well as when it's an explicit constructor application
1172   = knownCon env scrut (DataAlt con) args case_bndr alts cont
1173
1174   | Lit lit <- scrut    -- No need for same treatment as constructors
1175                         -- because literals are inlined more vigorously
1176   = knownCon env scrut (LitAlt lit) [] case_bndr alts cont
1177
1178
1179 --------------------------------------------------
1180 --      2. Eliminate the case if scrutinee is evaluated
1181 --------------------------------------------------
1182
1183 rebuildCase env scrut case_bndr [(_, bndrs, rhs)] cont
1184   -- See if we can get rid of the case altogether
1185   -- See the extensive notes on case-elimination above
1186   -- mkCase made sure that if all the alternatives are equal,
1187   -- then there is now only one (DEFAULT) rhs
1188  | all isDeadBinder bndrs       -- bndrs are [InId]
1189
1190         -- Check that the scrutinee can be let-bound instead of case-bound
1191  , exprOkForSpeculation scrut
1192                 -- OK not to evaluate it
1193                 -- This includes things like (==# a# b#)::Bool
1194                 -- so that we simplify
1195                 --      case ==# a# b# of { True -> x; False -> x }
1196                 -- to just
1197                 --      x
1198                 -- This particular example shows up in default methods for
1199                 -- comparision operations (e.g. in (>=) for Int.Int32)
1200         || exprIsHNF scrut                      -- It's already evaluated
1201         || var_demanded_later scrut             -- It'll be demanded later
1202
1203 --      || not opt_SimplPedanticBottoms)        -- Or we don't care!
1204 --      We used to allow improving termination by discarding cases, unless -fpedantic-bottoms was on,
1205 --      but that breaks badly for the dataToTag# primop, which relies on a case to evaluate
1206 --      its argument:  case x of { y -> dataToTag# y }
1207 --      Here we must *not* discard the case, because dataToTag# just fetches the tag from
1208 --      the info pointer.  So we'll be pedantic all the time, and see if that gives any
1209 --      other problems
1210 --      Also we don't want to discard 'seq's
1211   = do  { tick (CaseElim case_bndr)
1212         ; env' <- simplNonRecX env case_bndr scrut
1213         ; simplExprF env' rhs cont }
1214   where
1215         -- The case binder is going to be evaluated later,
1216         -- and the scrutinee is a simple variable
1217     var_demanded_later (Var v) = isStrictDmd (idNewDemandInfo case_bndr)
1218                                  && not (isTickBoxOp v)
1219                                     -- ugly hack; covering this case is what
1220                                     -- exprOkForSpeculation was intended for.
1221     var_demanded_later _       = False
1222
1223
1224 --------------------------------------------------
1225 --      3. Catch-all case
1226 --------------------------------------------------
1227
1228 rebuildCase env scrut case_bndr alts cont
1229   = do  {       -- Prepare the continuation;
1230                 -- The new subst_env is in place
1231           (env', dup_cont, nodup_cont) <- prepareCaseCont env alts cont
1232
1233         -- Simplify the alternatives
1234         ; (scrut', case_bndr', alts') <- simplAlts env' scrut case_bndr alts dup_cont
1235
1236         -- Check for empty alternatives
1237         ; if null alts' then
1238                 -- This isn't strictly an error, although it is unusual.
1239                 -- It's possible that the simplifer might "see" that
1240                 -- an inner case has no accessible alternatives before
1241                 -- it "sees" that the entire branch of an outer case is
1242                 -- inaccessible.  So we simply put an error case here instead.
1243             pprTrace "mkCase: null alts" (ppr case_bndr <+> ppr scrut) $
1244             let res_ty' = contResultType env' (substTy env' (coreAltsType alts)) dup_cont
1245                 lit = Lit (mkStringLit "Impossible alternative")
1246             in return (env', mkApps (Var rUNTIME_ERROR_ID) [Type res_ty', lit])
1247
1248           else do
1249         { case_expr <- mkCase scrut' case_bndr' alts'
1250
1251         -- Notice that rebuild gets the in-scope set from env, not alt_env
1252         -- The case binder *not* scope over the whole returned case-expression
1253         ; rebuild env' case_expr nodup_cont } }
1254 \end{code}
1255
1256 simplCaseBinder checks whether the scrutinee is a variable, v.  If so,
1257 try to eliminate uses of v in the RHSs in favour of case_bndr; that
1258 way, there's a chance that v will now only be used once, and hence
1259 inlined.
1260
1261 Note [no-case-of-case]
1262 ~~~~~~~~~~~~~~~~~~~~~~
1263 We *used* to suppress the binder-swap in case expressoins when
1264 -fno-case-of-case is on.  Old remarks:
1265     "This happens in the first simplifier pass,
1266     and enhances full laziness.  Here's the bad case:
1267             f = \ y -> ...(case x of I# v -> ...(case x of ...) ... )
1268     If we eliminate the inner case, we trap it inside the I# v -> arm,
1269     which might prevent some full laziness happening.  I've seen this
1270     in action in spectral/cichelli/Prog.hs:
1271              [(m,n) | m <- [1..max], n <- [1..max]]
1272     Hence the check for NoCaseOfCase."
1273 However, now the full-laziness pass itself reverses the binder-swap, so this
1274 check is no longer necessary.
1275
1276 Note [Suppressing the case binder-swap]
1277 ~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~
1278 There is another situation when it might make sense to suppress the
1279 case-expression binde-swap. If we have
1280
1281     case x of w1 { DEFAULT -> case x of w2 { A -> e1; B -> e2 }
1282                    ...other cases .... }
1283
1284 We'll perform the binder-swap for the outer case, giving
1285
1286     case x of w1 { DEFAULT -> case w1 of w2 { A -> e1; B -> e2 }
1287                    ...other cases .... }
1288
1289 But there is no point in doing it for the inner case, because w1 can't
1290 be inlined anyway.  Furthermore, doing the case-swapping involves
1291 zapping w2's occurrence info (see paragraphs that follow), and that
1292 forces us to bind w2 when doing case merging.  So we get
1293
1294     case x of w1 { A -> let w2 = w1 in e1
1295                    B -> let w2 = w1 in e2
1296                    ...other cases .... }
1297
1298 This is plain silly in the common case where w2 is dead.
1299
1300 Even so, I can't see a good way to implement this idea.  I tried
1301 not doing the binder-swap if the scrutinee was already evaluated
1302 but that failed big-time:
1303
1304         data T = MkT !Int
1305
1306         case v of w  { MkT x ->
1307         case x of x1 { I# y1 ->
1308         case x of x2 { I# y2 -> ...
1309
1310 Notice that because MkT is strict, x is marked "evaluated".  But to
1311 eliminate the last case, we must either make sure that x (as well as
1312 x1) has unfolding MkT y1.  THe straightforward thing to do is to do
1313 the binder-swap.  So this whole note is a no-op.
1314
1315 Note [zapOccInfo]
1316 ~~~~~~~~~~~~~~~~~
1317 If we replace the scrutinee, v, by tbe case binder, then we have to nuke
1318 any occurrence info (eg IAmDead) in the case binder, because the
1319 case-binder now effectively occurs whenever v does.  AND we have to do
1320 the same for the pattern-bound variables!  Example:
1321
1322         (case x of { (a,b) -> a }) (case x of { (p,q) -> q })
1323
1324 Here, b and p are dead.  But when we move the argment inside the first
1325 case RHS, and eliminate the second case, we get
1326
1327         case x of { (a,b) -> a b }
1328
1329 Urk! b is alive!  Reason: the scrutinee was a variable, and case elimination
1330 happened.
1331
1332 Indeed, this can happen anytime the case binder isn't dead:
1333         case <any> of x { (a,b) ->
1334         case x of { (p,q) -> p } }
1335 Here (a,b) both look dead, but come alive after the inner case is eliminated.
1336 The point is that we bring into the envt a binding
1337         let x = (a,b)
1338 after the outer case, and that makes (a,b) alive.  At least we do unless
1339 the case binder is guaranteed dead.
1340
1341 Note [Case of cast]
1342 ~~~~~~~~~~~~~~~~~~~
1343 Consider        case (v `cast` co) of x { I# ->
1344                 ... (case (v `cast` co) of {...}) ...
1345 We'd like to eliminate the inner case.  We can get this neatly by
1346 arranging that inside the outer case we add the unfolding
1347         v |-> x `cast` (sym co)
1348 to v.  Then we should inline v at the inner case, cancel the casts, and away we go
1349
1350 Note [Improving seq]
1351 ~~~~~~~~~~~~~~~~~~~
1352 Consider
1353         type family F :: * -> *
1354         type instance F Int = Int
1355
1356         ... case e of x { DEFAULT -> rhs } ...
1357
1358 where x::F Int.  Then we'd like to rewrite (F Int) to Int, getting
1359
1360         case e `cast` co of x'::Int
1361            I# x# -> let x = x' `cast` sym co
1362                     in rhs
1363
1364 so that 'rhs' can take advantage of the form of x'.  Notice that Note
1365 [Case of cast] may then apply to the result.
1366
1367 This showed up in Roman's experiments.  Example:
1368   foo :: F Int -> Int -> Int
1369   foo t n = t `seq` bar n
1370      where
1371        bar 0 = 0
1372        bar n = bar (n - case t of TI i -> i)
1373 Here we'd like to avoid repeated evaluating t inside the loop, by
1374 taking advantage of the `seq`.
1375
1376 At one point I did transformation in LiberateCase, but it's more robust here.
1377 (Otherwise, there's a danger that we'll simply drop the 'seq' altogether, before
1378 LiberateCase gets to see it.)
1379
1380 Note [Case elimination]
1381 ~~~~~~~~~~~~~~~~~~~~~~~
1382 The case-elimination transformation discards redundant case expressions.
1383 Start with a simple situation:
1384
1385         case x# of      ===>   e[x#/y#]
1386           y# -> e
1387
1388 (when x#, y# are of primitive type, of course).  We can't (in general)
1389 do this for algebraic cases, because we might turn bottom into
1390 non-bottom!
1391
1392 The code in SimplUtils.prepareAlts has the effect of generalise this
1393 idea to look for a case where we're scrutinising a variable, and we
1394 know that only the default case can match.  For example:
1395
1396         case x of
1397           0#      -> ...
1398           DEFAULT -> ...(case x of
1399                          0#      -> ...
1400                          DEFAULT -> ...) ...
1401
1402 Here the inner case is first trimmed to have only one alternative, the
1403 DEFAULT, after which it's an instance of the previous case.  This
1404 really only shows up in eliminating error-checking code.
1405
1406 We also make sure that we deal with this very common case:
1407
1408         case e of
1409           x -> ...x...
1410
1411 Here we are using the case as a strict let; if x is used only once
1412 then we want to inline it.  We have to be careful that this doesn't
1413 make the program terminate when it would have diverged before, so we
1414 check that
1415         - e is already evaluated (it may so if e is a variable)
1416         - x is used strictly, or
1417
1418 Lastly, the code in SimplUtils.mkCase combines identical RHSs.  So
1419
1420         case e of       ===> case e of DEFAULT -> r
1421            True  -> r
1422            False -> r
1423
1424 Now again the case may be elminated by the CaseElim transformation.
1425
1426
1427 Further notes about case elimination
1428 ~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~
1429 Consider:       test :: Integer -> IO ()
1430                 test = print
1431
1432 Turns out that this compiles to:
1433     Print.test
1434       = \ eta :: Integer
1435           eta1 :: State# RealWorld ->
1436           case PrelNum.< eta PrelNum.zeroInteger of wild { __DEFAULT ->
1437           case hPutStr stdout
1438                  (PrelNum.jtos eta ($w[] @ Char))
1439                  eta1
1440           of wild1 { (# new_s, a4 #) -> PrelIO.lvl23 new_s  }}
1441
1442 Notice the strange '<' which has no effect at all. This is a funny one.
1443 It started like this:
1444
1445 f x y = if x < 0 then jtos x
1446           else if y==0 then "" else jtos x
1447
1448 At a particular call site we have (f v 1).  So we inline to get
1449
1450         if v < 0 then jtos x
1451         else if 1==0 then "" else jtos x
1452
1453 Now simplify the 1==0 conditional:
1454
1455         if v<0 then jtos v else jtos v
1456
1457 Now common-up the two branches of the case:
1458
1459         case (v<0) of DEFAULT -> jtos v
1460
1461 Why don't we drop the case?  Because it's strict in v.  It's technically
1462 wrong to drop even unnecessary evaluations, and in practice they
1463 may be a result of 'seq' so we *definitely* don't want to drop those.
1464 I don't really know how to improve this situation.
1465
1466
1467 \begin{code}
1468 simplCaseBinder :: SimplEnv -> OutExpr -> OutId -> [InAlt]
1469                 -> SimplM (SimplEnv, OutExpr, OutId)
1470 simplCaseBinder env0 scrut0 case_bndr0 alts
1471   = do  { (env1, case_bndr1) <- simplBinder env0 case_bndr0
1472
1473         ; fam_envs <- getFamEnvs
1474         ; (env2, scrut2, case_bndr2) <- improve_seq fam_envs env1 scrut0
1475                                                 case_bndr0 case_bndr1 alts
1476                         -- Note [Improving seq]
1477
1478         ; let (env3, case_bndr3) = improve_case_bndr env2 scrut2 case_bndr2
1479                         -- Note [Case of cast]
1480
1481         ; return (env3, scrut2, case_bndr3) }
1482   where
1483
1484     improve_seq fam_envs env scrut case_bndr case_bndr1 [(DEFAULT,_,_)]
1485         | Just (co, ty2) <- topNormaliseType fam_envs (idType case_bndr1)
1486         =  do { case_bndr2 <- newId (fsLit "nt") ty2
1487               ; let rhs  = DoneEx (Var case_bndr2 `Cast` mkSymCoercion co)
1488                     env2 = extendIdSubst env case_bndr rhs
1489               ; return (env2, scrut `Cast` co, case_bndr2) }
1490
1491     improve_seq _ env scrut _ case_bndr1 _
1492         = return (env, scrut, case_bndr1)
1493
1494
1495     improve_case_bndr env scrut case_bndr
1496         -- See Note [no-case-of-case]
1497         --  | switchIsOn (getSwitchChecker env) NoCaseOfCase
1498         --  = (env, case_bndr)
1499
1500         | otherwise     -- Failed try; see Note [Suppressing the case binder-swap]
1501                         --     not (isEvaldUnfolding (idUnfolding v))
1502         = case scrut of
1503             Var v -> (modifyInScope env1 v case_bndr', case_bndr')
1504                 -- Note about using modifyInScope for v here
1505                 -- We could extend the substitution instead, but it would be
1506                 -- a hack because then the substitution wouldn't be idempotent
1507                 -- any more (v is an OutId).  And this does just as well.
1508
1509             Cast (Var v) co -> (addBinderUnfolding env1 v rhs, case_bndr')
1510                             where
1511                                 rhs = Cast (Var case_bndr') (mkSymCoercion co)
1512
1513             _ -> (env, case_bndr)
1514         where
1515           case_bndr' = zapOccInfo case_bndr
1516           env1       = modifyInScope env case_bndr case_bndr'
1517
1518
1519 zapOccInfo :: InId -> InId      -- See Note [zapOccInfo]
1520 zapOccInfo b = b `setIdOccInfo` NoOccInfo
1521 \end{code}
1522
1523
1524 simplAlts does two things:
1525
1526 1.  Eliminate alternatives that cannot match, including the
1527     DEFAULT alternative.
1528
1529 2.  If the DEFAULT alternative can match only one possible constructor,
1530     then make that constructor explicit.
1531     e.g.
1532         case e of x { DEFAULT -> rhs }
1533      ===>
1534         case e of x { (a,b) -> rhs }
1535     where the type is a single constructor type.  This gives better code
1536     when rhs also scrutinises x or e.
1537
1538 Here "cannot match" includes knowledge from GADTs
1539
1540 It's a good idea do do this stuff before simplifying the alternatives, to
1541 avoid simplifying alternatives we know can't happen, and to come up with
1542 the list of constructors that are handled, to put into the IdInfo of the
1543 case binder, for use when simplifying the alternatives.
1544
1545 Eliminating the default alternative in (1) isn't so obvious, but it can
1546 happen:
1547
1548 data Colour = Red | Green | Blue
1549
1550 f x = case x of
1551         Red -> ..
1552         Green -> ..
1553         DEFAULT -> h x
1554
1555 h y = case y of
1556         Blue -> ..
1557         DEFAULT -> [ case y of ... ]
1558
1559 If we inline h into f, the default case of the inlined h can't happen.
1560 If we don't notice this, we may end up filtering out *all* the cases
1561 of the inner case y, which give us nowhere to go!
1562
1563
1564 \begin{code}
1565 simplAlts :: SimplEnv
1566           -> OutExpr
1567           -> InId                       -- Case binder
1568           -> [InAlt]                    -- Non-empty
1569           -> SimplCont
1570           -> SimplM (OutExpr, OutId, [OutAlt])  -- Includes the continuation
1571 -- Like simplExpr, this just returns the simplified alternatives;
1572 -- it not return an environment
1573
1574 simplAlts env scrut case_bndr alts cont'
1575   = -- pprTrace "simplAlts" (ppr alts $$ ppr (seIdSubst env)) $
1576     do  { let alt_env = zapFloats env
1577         ; (alt_env', scrut', case_bndr') <- simplCaseBinder alt_env scrut case_bndr alts
1578
1579         ; (imposs_deflt_cons, in_alts) <- prepareAlts alt_env' scrut case_bndr' alts
1580
1581         ; alts' <- mapM (simplAlt alt_env' imposs_deflt_cons case_bndr' cont') in_alts
1582         ; return (scrut', case_bndr', alts') }
1583
1584 ------------------------------------
1585 simplAlt :: SimplEnv
1586          -> [AltCon]    -- These constructors can't be present when
1587                         -- matching the DEFAULT alternative
1588          -> OutId       -- The case binder
1589          -> SimplCont
1590          -> InAlt
1591          -> SimplM OutAlt
1592
1593 simplAlt env imposs_deflt_cons case_bndr' cont' (DEFAULT, bndrs, rhs)
1594   = ASSERT( null bndrs )
1595     do  { let env' = addBinderOtherCon env case_bndr' imposs_deflt_cons
1596                 -- Record the constructors that the case-binder *can't* be.
1597         ; rhs' <- simplExprC env' rhs cont'
1598         ; return (DEFAULT, [], rhs') }
1599
1600 simplAlt env _ case_bndr' cont' (LitAlt lit, bndrs, rhs)
1601   = ASSERT( null bndrs )
1602     do  { let env' = addBinderUnfolding env case_bndr' (Lit lit)
1603         ; rhs' <- simplExprC env' rhs cont'
1604         ; return (LitAlt lit, [], rhs') }
1605
1606 simplAlt env _ case_bndr' cont' (DataAlt con, vs, rhs)
1607   = do  {       -- Deal with the pattern-bound variables
1608                 -- Mark the ones that are in ! positions in the
1609                 -- data constructor as certainly-evaluated.
1610                 -- NB: simplLamBinders preserves this eval info
1611           let vs_with_evals = add_evals (dataConRepStrictness con)
1612         ; (env', vs') <- simplLamBndrs env vs_with_evals
1613
1614                 -- Bind the case-binder to (con args)
1615         ; let inst_tys' = tyConAppArgs (idType case_bndr')
1616               con_args  = map Type inst_tys' ++ varsToCoreExprs vs'
1617               env''     = addBinderUnfolding env' case_bndr'
1618                                              (mkConApp con con_args)
1619
1620         ; rhs' <- simplExprC env'' rhs cont'
1621         ; return (DataAlt con, vs', rhs') }
1622   where
1623         -- add_evals records the evaluated-ness of the bound variables of
1624         -- a case pattern.  This is *important*.  Consider
1625         --      data T = T !Int !Int
1626         --
1627         --      case x of { T a b -> T (a+1) b }
1628         --
1629         -- We really must record that b is already evaluated so that we don't
1630         -- go and re-evaluate it when constructing the result.
1631         -- See Note [Data-con worker strictness] in MkId.lhs
1632     add_evals the_strs
1633         = go vs the_strs
1634         where
1635           go [] [] = []
1636           go (v:vs') strs | isTyVar v = v : go vs' strs
1637           go (v:vs') (str:strs)
1638             | isMarkedStrict str = evald_v  : go vs' strs
1639             | otherwise          = zapped_v : go vs' strs
1640             where
1641               zapped_v = zap_occ_info v
1642               evald_v  = zapped_v `setIdUnfolding` evaldUnfolding
1643           go _ _ = pprPanic "cat_evals" (ppr con $$ ppr vs $$ ppr the_strs)
1644
1645         -- zap_occ_info: if the case binder is alive, then we add the unfolding
1646         --      case_bndr = C vs
1647         -- to the envt; so vs are now very much alive
1648         -- Note [Aug06] I can't see why this actually matters, but it's neater
1649         --        case e of t { (a,b) -> ...(case t of (p,q) -> p)... }
1650         --   ==>  case e of t { (a,b) -> ...(a)... }
1651         -- Look, Ma, a is alive now.
1652     zap_occ_info | isDeadBinder case_bndr' = \ident -> ident
1653                  | otherwise               = zapOccInfo
1654
1655 addBinderUnfolding :: SimplEnv -> Id -> CoreExpr -> SimplEnv
1656 addBinderUnfolding env bndr rhs
1657   = modifyInScope env bndr (bndr `setIdUnfolding` mkUnfolding False rhs)
1658
1659 addBinderOtherCon :: SimplEnv -> Id -> [AltCon] -> SimplEnv
1660 addBinderOtherCon env bndr cons
1661   = modifyInScope env bndr (bndr `setIdUnfolding` mkOtherCon cons)
1662 \end{code}
1663
1664
1665 %************************************************************************
1666 %*                                                                      *
1667 \subsection{Known constructor}
1668 %*                                                                      *
1669 %************************************************************************
1670
1671 We are a bit careful with occurrence info.  Here's an example
1672
1673         (\x* -> case x of (a*, b) -> f a) (h v, e)
1674
1675 where the * means "occurs once".  This effectively becomes
1676         case (h v, e) of (a*, b) -> f a)
1677 and then
1678         let a* = h v; b = e in f a
1679 and then
1680         f (h v)
1681
1682 All this should happen in one sweep.
1683
1684 \begin{code}
1685 knownCon :: SimplEnv -> OutExpr -> AltCon
1686          -> [OutExpr]           -- Args *including* the universal args
1687          -> InId -> [InAlt] -> SimplCont
1688          -> SimplM (SimplEnv, OutExpr)
1689
1690 knownCon env scrut con args bndr alts cont
1691   = do  { tick (KnownBranch bndr)
1692         ; knownAlt env scrut args bndr (findAlt con alts) cont }
1693
1694 knownAlt :: SimplEnv -> OutExpr -> [OutExpr]
1695          -> InId -> (AltCon, [CoreBndr], InExpr) -> SimplCont
1696          -> SimplM (SimplEnv, OutExpr)
1697 knownAlt env scrut _ bndr (DEFAULT, bs, rhs) cont
1698   = ASSERT( null bs )
1699     do  { env' <- simplNonRecX env bndr scrut
1700                 -- This might give rise to a binding with non-atomic args
1701                 -- like x = Node (f x) (g x)
1702                 -- but simplNonRecX will atomic-ify it
1703         ; simplExprF env' rhs cont }
1704
1705 knownAlt env scrut _ bndr (LitAlt _, bs, rhs) cont
1706   = ASSERT( null bs )
1707     do  { env' <- simplNonRecX env bndr scrut
1708         ; simplExprF env' rhs cont }
1709
1710 knownAlt env scrut the_args bndr (DataAlt dc, bs, rhs) cont
1711   = do  { let dead_bndr  = isDeadBinder bndr    -- bndr is an InId
1712               n_drop_tys = length (dataConUnivTyVars dc)
1713         ; env' <- bind_args env dead_bndr bs (drop n_drop_tys the_args)
1714         ; let
1715                 -- It's useful to bind bndr to scrut, rather than to a fresh
1716                 -- binding      x = Con arg1 .. argn
1717                 -- because very often the scrut is a variable, so we avoid
1718                 -- creating, and then subsequently eliminating, a let-binding
1719                 -- BUT, if scrut is a not a variable, we must be careful
1720                 -- about duplicating the arg redexes; in that case, make
1721                 -- a new con-app from the args
1722                 bndr_rhs  = case scrut of
1723                                 Var _ -> scrut
1724                                 _     -> con_app
1725                 con_app = mkConApp dc (take n_drop_tys the_args ++ con_args)
1726                 con_args = [substExpr env' (varToCoreExpr b) | b <- bs]
1727                                 -- args are aready OutExprs, but bs are InIds
1728
1729         ; env'' <- simplNonRecX env' bndr bndr_rhs
1730         ; -- pprTrace "knownCon2" (ppr bs $$ ppr rhs $$ ppr (seIdSubst env'')) $
1731           simplExprF env'' rhs cont }
1732   where
1733     -- Ugh!
1734     bind_args env' _ [] _  = return env'
1735
1736     bind_args env' dead_bndr (b:bs') (Type ty : args)
1737       = ASSERT( isTyVar b )
1738         bind_args (extendTvSubst env' b ty) dead_bndr bs' args
1739
1740     bind_args env' dead_bndr (b:bs') (arg : args)
1741       = ASSERT( isId b )
1742         do { let b' = if dead_bndr then b else zapOccInfo b
1743              -- Note that the binder might be "dead", because it doesn't
1744              -- occur in the RHS; and simplNonRecX may therefore discard
1745              -- it via postInlineUnconditionally.
1746              -- Nevertheless we must keep it if the case-binder is alive,
1747              -- because it may be used in the con_app.  See Note [zapOccInfo]
1748            ; env'' <- simplNonRecX env' b' arg
1749            ; bind_args env'' dead_bndr bs' args }
1750
1751     bind_args _ _ _ _ =
1752       pprPanic "bind_args" $ ppr dc $$ ppr bs $$ ppr the_args $$
1753                              text "scrut:" <+> ppr scrut
1754 \end{code}
1755
1756
1757 %************************************************************************
1758 %*                                                                      *
1759 \subsection{Duplicating continuations}
1760 %*                                                                      *
1761 %************************************************************************
1762
1763 \begin{code}
1764 prepareCaseCont :: SimplEnv
1765                 -> [InAlt] -> SimplCont
1766                 -> SimplM (SimplEnv, SimplCont,SimplCont)
1767                         -- Return a duplicatable continuation, a non-duplicable part
1768                         -- plus some extra bindings (that scope over the entire
1769                         -- continunation)
1770
1771         -- No need to make it duplicatable if there's only one alternative
1772 prepareCaseCont env [_] cont = return (env, cont, mkBoringStop)
1773 prepareCaseCont env _   cont = mkDupableCont env cont
1774 \end{code}
1775
1776 \begin{code}
1777 mkDupableCont :: SimplEnv -> SimplCont
1778               -> SimplM (SimplEnv, SimplCont, SimplCont)
1779
1780 mkDupableCont env cont
1781   | contIsDupable cont
1782   = return (env, cont, mkBoringStop)
1783
1784 mkDupableCont _   (Stop {}) = panic "mkDupableCont"     -- Handled by previous eqn
1785
1786 mkDupableCont env (CoerceIt ty cont)
1787   = do  { (env', dup, nodup) <- mkDupableCont env cont
1788         ; return (env', CoerceIt ty dup, nodup) }
1789
1790 mkDupableCont env cont@(StrictBind {})
1791   =  return (env, mkBoringStop, cont)
1792         -- See Note [Duplicating strict continuations]
1793
1794 mkDupableCont env cont@(StrictArg {})
1795   =  return (env, mkBoringStop, cont)
1796         -- See Note [Duplicating strict continuations]
1797
1798 mkDupableCont env (ApplyTo _ arg se cont)
1799   =     -- e.g.         [...hole...] (...arg...)
1800         --      ==>
1801         --              let a = ...arg...
1802         --              in [...hole...] a
1803     do  { (env', dup_cont, nodup_cont) <- mkDupableCont env cont
1804         ; arg' <- simplExpr (se `setInScope` env') arg
1805         ; (env'', arg'') <- makeTrivial env' arg'
1806         ; let app_cont = ApplyTo OkToDup arg'' (zapSubstEnv env') dup_cont
1807         ; return (env'', app_cont, nodup_cont) }
1808
1809 mkDupableCont env cont@(Select _ _ [(_, bs, _rhs)] _ _)
1810 --  See Note [Single-alternative case]
1811 --  | not (exprIsDupable rhs && contIsDupable case_cont)
1812 --  | not (isDeadBinder case_bndr)
1813   | all isDeadBinder bs         -- InIds
1814   = return (env, mkBoringStop, cont)
1815
1816 mkDupableCont env (Select _ case_bndr alts se cont)
1817   =     -- e.g.         (case [...hole...] of { pi -> ei })
1818         --      ===>
1819         --              let ji = \xij -> ei
1820         --              in case [...hole...] of { pi -> ji xij }
1821     do  { tick (CaseOfCase case_bndr)
1822         ; (env', dup_cont, nodup_cont) <- mkDupableCont env cont
1823                 -- NB: call mkDupableCont here, *not* prepareCaseCont
1824                 -- We must make a duplicable continuation, whereas prepareCaseCont
1825                 -- doesn't when there is a single case branch
1826
1827         ; let alt_env = se `setInScope` env'
1828         ; (alt_env', case_bndr') <- simplBinder alt_env case_bndr
1829         ; alts' <- mapM (simplAlt alt_env' [] case_bndr' dup_cont) alts
1830         -- Safe to say that there are no handled-cons for the DEFAULT case
1831                 -- NB: simplBinder does not zap deadness occ-info, so
1832                 -- a dead case_bndr' will still advertise its deadness
1833                 -- This is really important because in
1834                 --      case e of b { (# p,q #) -> ... }
1835                 -- b is always dead, and indeed we are not allowed to bind b to (# p,q #),
1836                 -- which might happen if e was an explicit unboxed pair and b wasn't marked dead.
1837                 -- In the new alts we build, we have the new case binder, so it must retain
1838                 -- its deadness.
1839         -- NB: we don't use alt_env further; it has the substEnv for
1840         --     the alternatives, and we don't want that
1841
1842         ; (env'', alts'') <- mkDupableAlts env' case_bndr' alts'
1843         ; return (env'',  -- Note [Duplicated env]
1844                   Select OkToDup case_bndr' alts'' (zapSubstEnv env'') mkBoringStop,
1845                   nodup_cont) }
1846
1847
1848 mkDupableAlts :: SimplEnv -> OutId -> [InAlt]
1849               -> SimplM (SimplEnv, [InAlt])
1850 -- Absorbs the continuation into the new alternatives
1851
1852 mkDupableAlts env case_bndr' the_alts
1853   = go env the_alts
1854   where
1855     go env0 [] = return (env0, [])
1856     go env0 (alt:alts)
1857         = do { (env1, alt') <- mkDupableAlt env0 case_bndr' alt
1858              ; (env2, alts') <- go env1 alts
1859              ; return (env2, alt' : alts' ) }
1860
1861 mkDupableAlt :: SimplEnv -> OutId -> (AltCon, [CoreBndr], CoreExpr)
1862               -> SimplM (SimplEnv, (AltCon, [CoreBndr], CoreExpr))
1863 mkDupableAlt env case_bndr' (con, bndrs', rhs')
1864   | exprIsDupable rhs'  -- Note [Small alternative rhs]
1865   = return (env, (con, bndrs', rhs'))
1866   | otherwise
1867   = do  { let rhs_ty'     = exprType rhs'
1868               used_bndrs' = filter abstract_over (case_bndr' : bndrs')
1869               abstract_over bndr
1870                   | isTyVar bndr = True -- Abstract over all type variables just in case
1871                   | otherwise    = not (isDeadBinder bndr)
1872                         -- The deadness info on the new Ids is preserved by simplBinders
1873
1874         ; (final_bndrs', final_args)    -- Note [Join point abstraction]
1875                 <- if (any isId used_bndrs')
1876                    then return (used_bndrs', varsToCoreExprs used_bndrs')
1877                     else do { rw_id <- newId (fsLit "w") realWorldStatePrimTy
1878                             ; return ([rw_id], [Var realWorldPrimId]) }
1879
1880         ; join_bndr <- newId (fsLit "$j") (mkPiTypes final_bndrs' rhs_ty')
1881                 -- Note [Funky mkPiTypes]
1882
1883         ; let   -- We make the lambdas into one-shot-lambdas.  The
1884                 -- join point is sure to be applied at most once, and doing so
1885                 -- prevents the body of the join point being floated out by
1886                 -- the full laziness pass
1887                 really_final_bndrs     = map one_shot final_bndrs'
1888                 one_shot v | isId v    = setOneShotLambda v
1889                            | otherwise = v
1890                 join_rhs  = mkLams really_final_bndrs rhs'
1891                 join_call = mkApps (Var join_bndr) final_args
1892
1893         ; return (addNonRec env join_bndr join_rhs, (con, bndrs', join_call)) }
1894                 -- See Note [Duplicated env]
1895 \end{code}
1896
1897 Note [Duplicated env]
1898 ~~~~~~~~~~~~~~~~~~~~~
1899 Some of the alternatives are simplified, but have not been turned into a join point
1900 So they *must* have an zapped subst-env.  So we can't use completeNonRecX to
1901 bind the join point, because it might to do PostInlineUnconditionally, and
1902 we'd lose that when zapping the subst-env.  We could have a per-alt subst-env,
1903 but zapping it (as we do in mkDupableCont, the Select case) is safe, and
1904 at worst delays the join-point inlining.
1905
1906 Note [Small alterantive rhs]
1907 ~~~~~~~~~~~~~~~~~~~~~~~~~~~~
1908 It is worth checking for a small RHS because otherwise we
1909 get extra let bindings that may cause an extra iteration of the simplifier to
1910 inline back in place.  Quite often the rhs is just a variable or constructor.
1911 The Ord instance of Maybe in PrelMaybe.lhs, for example, took several extra
1912 iterations because the version with the let bindings looked big, and so wasn't
1913 inlined, but after the join points had been inlined it looked smaller, and so
1914 was inlined.
1915
1916 NB: we have to check the size of rhs', not rhs.
1917 Duplicating a small InAlt might invalidate occurrence information
1918 However, if it *is* dupable, we return the *un* simplified alternative,
1919 because otherwise we'd need to pair it up with an empty subst-env....
1920 but we only have one env shared between all the alts.
1921 (Remember we must zap the subst-env before re-simplifying something).
1922 Rather than do this we simply agree to re-simplify the original (small) thing later.
1923
1924 Note [Funky mkPiTypes]
1925 ~~~~~~~~~~~~~~~~~~~~~~
1926 Notice the funky mkPiTypes.  If the contructor has existentials
1927 it's possible that the join point will be abstracted over
1928 type varaibles as well as term variables.
1929  Example:  Suppose we have
1930         data T = forall t.  C [t]
1931  Then faced with
1932         case (case e of ...) of
1933             C t xs::[t] -> rhs
1934  We get the join point
1935         let j :: forall t. [t] -> ...
1936             j = /\t \xs::[t] -> rhs
1937         in
1938         case (case e of ...) of
1939             C t xs::[t] -> j t xs
1940
1941 Note [Join point abstaction]
1942 ~~~~~~~~~~~~~~~~~~~~~~~~~~~~
1943 If we try to lift a primitive-typed something out
1944 for let-binding-purposes, we will *caseify* it (!),
1945 with potentially-disastrous strictness results.  So
1946 instead we turn it into a function: \v -> e
1947 where v::State# RealWorld#.  The value passed to this function
1948 is realworld#, which generates (almost) no code.
1949
1950 There's a slight infelicity here: we pass the overall
1951 case_bndr to all the join points if it's used in *any* RHS,
1952 because we don't know its usage in each RHS separately
1953
1954 We used to say "&& isUnLiftedType rhs_ty'" here, but now
1955 we make the join point into a function whenever used_bndrs'
1956 is empty.  This makes the join-point more CPR friendly.
1957 Consider:       let j = if .. then I# 3 else I# 4
1958                 in case .. of { A -> j; B -> j; C -> ... }
1959
1960 Now CPR doesn't w/w j because it's a thunk, so
1961 that means that the enclosing function can't w/w either,
1962 which is a lose.  Here's the example that happened in practice:
1963         kgmod :: Int -> Int -> Int
1964         kgmod x y = if x > 0 && y < 0 || x < 0 && y > 0
1965                     then 78
1966                     else 5
1967
1968 I have seen a case alternative like this:
1969         True -> \v -> ...
1970 It's a bit silly to add the realWorld dummy arg in this case, making
1971         $j = \s v -> ...
1972            True -> $j s
1973 (the \v alone is enough to make CPR happy) but I think it's rare
1974
1975 Note [Duplicating strict continuations]
1976 ~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~
1977 Do *not* duplicate StrictBind and StritArg continuations.  We gain
1978 nothing by propagating them into the expressions, and we do lose a
1979 lot.  Here's an example:
1980         && (case x of { T -> F; F -> T }) E
1981 Now, && is strict so we end up simplifying the case with
1982 an ArgOf continuation.  If we let-bind it, we get
1983
1984         let $j = \v -> && v E
1985         in simplExpr (case x of { T -> F; F -> T })
1986                      (ArgOf (\r -> $j r)
1987 And after simplifying more we get
1988
1989         let $j = \v -> && v E
1990         in case x of { T -> $j F; F -> $j T }
1991 Which is a Very Bad Thing
1992
1993 The desire not to duplicate is the entire reason that
1994 mkDupableCont returns a pair of continuations.
1995
1996 The original plan had:
1997 e.g.    (...strict-fn...) [...hole...]
1998         ==>
1999                 let $j = \a -> ...strict-fn...
2000                 in $j [...hole...]
2001
2002 Note [Single-alternative cases]
2003 ~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~
2004 This case is just like the ArgOf case.  Here's an example:
2005         data T a = MkT !a
2006         ...(MkT (abs x))...
2007 Then we get
2008         case (case x of I# x' ->
2009               case x' <# 0# of
2010                 True  -> I# (negate# x')
2011                 False -> I# x') of y {
2012           DEFAULT -> MkT y
2013 Because the (case x) has only one alternative, we'll transform to
2014         case x of I# x' ->
2015         case (case x' <# 0# of
2016                 True  -> I# (negate# x')
2017                 False -> I# x') of y {
2018           DEFAULT -> MkT y
2019 But now we do *NOT* want to make a join point etc, giving
2020         case x of I# x' ->
2021         let $j = \y -> MkT y
2022         in case x' <# 0# of
2023                 True  -> $j (I# (negate# x'))
2024                 False -> $j (I# x')
2025 In this case the $j will inline again, but suppose there was a big
2026 strict computation enclosing the orginal call to MkT.  Then, it won't
2027 "see" the MkT any more, because it's big and won't get duplicated.
2028 And, what is worse, nothing was gained by the case-of-case transform.
2029
2030 When should use this case of mkDupableCont?
2031 However, matching on *any* single-alternative case is a *disaster*;
2032   e.g.  case (case ....) of (a,b) -> (# a,b #)
2033   We must push the outer case into the inner one!
2034 Other choices:
2035
2036    * Match [(DEFAULT,_,_)], but in the common case of Int,
2037      the alternative-filling-in code turned the outer case into
2038                 case (...) of y { I# _ -> MkT y }
2039
2040    * Match on single alternative plus (not (isDeadBinder case_bndr))
2041      Rationale: pushing the case inwards won't eliminate the construction.
2042      But there's a risk of
2043                 case (...) of y { (a,b) -> let z=(a,b) in ... }
2044      Now y looks dead, but it'll come alive again.  Still, this
2045      seems like the best option at the moment.
2046
2047    * Match on single alternative plus (all (isDeadBinder bndrs))
2048      Rationale: this is essentially  seq.
2049
2050    * Match when the rhs is *not* duplicable, and hence would lead to a
2051      join point.  This catches the disaster-case above.  We can test
2052      the *un-simplified* rhs, which is fine.  It might get bigger or
2053      smaller after simplification; if it gets smaller, this case might
2054      fire next time round.  NB also that we must test contIsDupable
2055      case_cont *btoo, because case_cont might be big!
2056
2057      HOWEVER: I found that this version doesn't work well, because
2058      we can get         let x = case (...) of { small } in ...case x...
2059      When x is inlined into its full context, we find that it was a bad
2060      idea to have pushed the outer case inside the (...) case.
2061