compiler/simplCore/Simplify.lhs

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