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