compiler/simplCore/Simplify.lhs

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