ghc/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 CmdLineOpts      ( dopt, DynFlag(Opt_D_dump_inlinings),
  12                           SimplifierSwitch(..)
  13                         )
  14 import SimplMonad
  15 import SimplUtils       ( mkCase, mkLam, newId,
  16                           simplBinder, simplBinders, simplLamBndrs, simplRecBndrs, simplLetBndr,
  17                           simplTopBndrs, SimplCont(..), DupFlag(..), LetRhsFlag(..),
  18                           mkStop, mkBoringStop,  pushContArgs,
  19                           contResultType, countArgs, contIsDupable, contIsRhsOrArg,
  20                           getContArgs, interestingCallContext, interestingArg, isStrictType
  21                         )
  22 import Var              ( mustHaveLocalBinding )
  23 import VarEnv
  24 import Id               ( Id, idType, idInfo, idArity, isDataConId,
  25                           idUnfolding, setIdUnfolding, isDeadBinder,
  26                           idNewDemandInfo, setIdInfo,
  27                           setIdOccInfo, isLocalId,
  28                           zapLamIdInfo, setOneShotLambda,
  29                         )
  30 import IdInfo           ( OccInfo(..), isLoopBreaker,
  31                           setArityInfo,
  32                           setUnfoldingInfo,
  33                           occInfo
  34                         )
  35 import NewDemand        ( isStrictDmd )
  36 import DataCon          ( dataConNumInstArgs, dataConRepStrictness )
  37 import CoreSyn
  38 import PprCore          ( pprParendExpr, pprCoreExpr )
  39 import CoreUnfold       ( mkOtherCon, mkUnfolding, otherCons, callSiteInline )
  40 import CoreUtils        ( exprIsDupable, exprIsTrivial, needsCaseBinding,
  41                           exprIsConApp_maybe, mkPiType, findAlt, findDefault,
  42                           exprType, coreAltsType, exprIsValue,
  43                           exprOkForSpeculation, exprArity,
  44                           mkCoerce, mkSCC, mkInlineMe, mkAltExpr
  45                         )
  46 import Rules            ( lookupRule )
  47 import BasicTypes       ( isMarkedStrict )
  48 import CostCentre       ( currentCCS )
  49 import Type             ( isUnLiftedType, seqType, mkFunTy, tyConAppArgs,
  50                           funResultTy, splitFunTy_maybe, splitFunTy, eqType
  51                         )
  52 import Subst            ( mkSubst, substTy, substExpr,
  53                           isInScope, lookupIdSubst, simplIdInfo
  54                         )
  55 import TysPrim          ( realWorldStatePrimTy )
  56 import PrelInfo         ( realWorldPrimId )
  57 import BasicTypes       ( TopLevelFlag(..), isTopLevel, isNotTopLevel,
  58                           RecFlag(..), isNonRec
  59                         )
  60 import OrdList
  61 import Maybe            ( Maybe )
  62 import Outputable
  63 \end{code}
  64
  65
  66 The guts of the simplifier is in this module, but the driver loop for
  67 the simplifier is in SimplCore.lhs.
  68
  69
  70 -----------------------------------------
  71         *** IMPORTANT NOTE ***
  72 -----------------------------------------
  73 The simplifier used to guarantee that the output had no shadowing, but
  74 it does not do so any more.   (Actually, it never did!)  The reason is
  75 documented with simplifyArgs.
  76
  77
  78 -----------------------------------------
  79         *** IMPORTANT NOTE ***
  80 -----------------------------------------
  81 Many parts of the simplifier return a bunch of "floats" as well as an
  82 expression. This is wrapped as a datatype SimplUtils.FloatsWith.
  83
  84 All "floats" are let-binds, not case-binds, but some non-rec lets may
  85 be unlifted (with RHS ok-for-speculation).
  86
  87
  88
  89 -----------------------------------------
  90         ORGANISATION OF FUNCTIONS
  91 -----------------------------------------
  92 simplTopBinds
  93   - simplify all top-level binders
  94   - for NonRec, call simplRecOrTopPair
  95   - for Rec,    call simplRecBind
  96
  97
  98         ------------------------------
  99 simplExpr (applied lambda)      ==> simplNonRecBind
 100 simplExpr (Let (NonRec ...) ..) ==> simplNonRecBind
 101 simplExpr (Let (Rec ...)    ..) ==> simplify binders; simplRecBind
 102
 103         ------------------------------
 104 simplRecBind    [binders already simplfied]
 105   - use simplRecOrTopPair on each pair in turn
 106
 107 simplRecOrTopPair [binder already simplified]
 108   Used for: recursive bindings (top level and nested)
 109             top-level non-recursive bindings
 110   Returns:
 111   - check for PreInlineUnconditionally
 112   - simplLazyBind
 113
 114 simplNonRecBind
 115   Used for: non-top-level non-recursive bindings
 116             beta reductions (which amount to the same thing)
 117   Because it can deal with strict arts, it takes a
 118         "thing-inside" and returns an expression
 119
 120   - check for PreInlineUnconditionally
 121   - simplify binder, including its IdInfo
 122   - if strict binding
 123         simplStrictArg
 124         mkAtomicArgs
 125         completeNonRecX
 126     else
 127         simplLazyBind
 128         addFloats
 129
 130 simplNonRecX:   [given a *simplified* RHS, but an *unsimplified* binder]
 131   Used for: binding case-binder and constr args in a known-constructor case
 132   - check for PreInLineUnconditionally
 133   - simplify binder
 134   - completeNonRecX
 135
 136         ------------------------------
 137 simplLazyBind:  [binder already simplified, RHS not]
 138   Used for: recursive bindings (top level and nested)
 139             top-level non-recursive bindings
 140             non-top-level, but *lazy* non-recursive bindings
 141         [must not be strict or unboxed]
 142   Returns floats + an augmented environment, not an expression
 143   - substituteIdInfo and add result to in-scope
 144         [so that rules are available in rec rhs]
 145   - simplify rhs
 146   - mkAtomicArgs
 147   - float if exposes constructor or PAP
 148   - completeLazyBind
 149
 150
 151 completeNonRecX:        [binder and rhs both simplified]
 152   - if the the thing needs case binding (unlifted and not ok-for-spec)
 153         build a Case
 154    else
 155         completeLazyBind
 156         addFloats
 157
 158 completeLazyBind:       [given a simplified RHS]
 159         [used for both rec and non-rec bindings, top level and not]
 160   - try PostInlineUnconditionally
 161   - add unfolding [this is the only place we add an unfolding]
 162   - add arity
 163
 164
 165
 166 Right hand sides and arguments
 167 ~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~
 168 In many ways we want to treat
 169         (a) the right hand side of a let(rec), and
 170         (b) a function argument
 171 in the same way.  But not always!  In particular, we would
 172 like to leave these arguments exactly as they are, so they
 173 will match a RULE more easily.
 174
 175         f (g x, h x)
 176         g (+ x)
 177
 178 It's harder to make the rule match if we ANF-ise the constructor,
 179 or eta-expand the PAP:
 180
 181         f (let { a = g x; b = h x } in (a,b))
 182         g (\y. + x y)
 183
 184 On the other hand if we see the let-defns
 185
 186         p = (g x, h x)
 187         q = + x
 188
 189 then we *do* want to ANF-ise and eta-expand, so that p and q
 190 can be safely inlined.
 191
 192 Even floating lets out is a bit dubious.  For let RHS's we float lets
 193 out if that exposes a value, so that the value can be inlined more vigorously.
 194 For example
 195
 196         r = let x = e in (x,x)
 197
 198 Here, if we float the let out we'll expose a nice constructor. We did experiments
 199 that showed this to be a generally good thing.  But it was a bad thing to float
 200 lets out unconditionally, because that meant they got allocated more often.
 201
 202 For function arguments, there's less reason to expose a constructor (it won't
 203 get inlined).  Just possibly it might make a rule match, but I'm pretty skeptical.
 204 So for the moment we don't float lets out of function arguments either.
 205
 206
 207 Eta expansion
 208 ~~~~~~~~~~~~~~
 209 For eta expansion, we want to catch things like
 210
 211         case e of (a,b) -> \x -> case a of (p,q) -> \y -> r
 212
 213 If the \x was on the RHS of a let, we'd eta expand to bring the two
 214 lambdas together.  And in general that's a good thing to do.  Perhaps
 215 we should eta expand wherever we find a (value) lambda?  Then the eta
 216 expansion at a let RHS can concentrate solely on the PAP case.
 217
 218
 219 %************************************************************************
 220 %*                                                                      *
 221 \subsection{Bindings}
 222 %*                                                                      *
 223 %************************************************************************
 224
 225 \begin{code}
 226 simplTopBinds :: SimplEnv -> [InBind] -> SimplM [OutBind]
 227
 228 simplTopBinds env binds
 229   =     -- Put all the top-level binders into scope at the start
 230         -- so that if a transformation rule has unexpectedly brought
 231         -- anything into scope, then we don't get a complaint about that.
 232         -- It's rather as if the top-level binders were imported.
 233     simplTopBndrs env (bindersOfBinds binds)    `thenSmpl` \ (env, bndrs') ->
 234     simpl_binds env binds bndrs'                `thenSmpl` \ (floats, _) ->
 235     freeTick SimplifierDone                     `thenSmpl_`
 236     returnSmpl (floatBinds floats)
 237   where
 238         -- We need to track the zapped top-level binders, because
 239         -- they should have their fragile IdInfo zapped (notably occurrence info)
 240         -- That's why we run down binds and bndrs' simultaneously.
 241     simpl_binds :: SimplEnv -> [InBind] -> [OutId] -> SimplM (FloatsWith ())
 242     simpl_binds env []           bs = ASSERT( null bs ) returnSmpl (emptyFloats env, ())
 243     simpl_binds env (bind:binds) bs = simpl_bind env bind bs            `thenSmpl` \ (floats,env) ->
 244                                       addFloats env floats              $ \env ->
 245                                       simpl_binds env binds (drop_bs bind bs)
 246
 247     drop_bs (NonRec _ _) (_ : bs) = bs
 248     drop_bs (Rec prs)    bs       = drop (length prs) bs
 249
 250     simpl_bind env (NonRec b r) (b':_) = simplRecOrTopPair env TopLevel b b' r
 251     simpl_bind env (Rec pairs)  bs'    = simplRecBind      env TopLevel pairs bs'
 252 \end{code}
 253
 254
 255 %************************************************************************
 256 %*                                                                      *
 257 \subsection{simplNonRec}
 258 %*                                                                      *
 259 %************************************************************************
 260
 261 simplNonRecBind is used for
 262   * non-top-level non-recursive lets in expressions
 263   * beta reduction
 264
 265 It takes
 266   * An unsimplified (binder, rhs) pair
 267   * The env for the RHS.  It may not be the same as the
 268         current env because the bind might occur via (\x.E) arg
 269
 270 It uses the CPS form because the binding might be strict, in which
 271 case we might discard the continuation:
 272         let x* = error "foo" in (...x...)
 273
 274 It needs to turn unlifted bindings into a @case@.  They can arise
 275 from, say:      (\x -> e) (4# + 3#)
 276
 277 \begin{code}
 278 simplNonRecBind :: SimplEnv
 279                 -> InId                                 -- Binder
 280                 -> InExpr -> SimplEnv                   -- Arg, with its subst-env
 281                 -> OutType                              -- Type of thing computed by the context
 282                 -> (SimplEnv -> SimplM FloatsWithExpr)  -- The body
 283                 -> SimplM FloatsWithExpr
 284 #ifdef DEBUG
 285 simplNonRecBind env bndr rhs rhs_se cont_ty thing_inside
 286   | isTyVar bndr
 287   = pprPanic "simplNonRecBind" (ppr bndr <+> ppr rhs)
 288 #endif
 289
 290 simplNonRecBind env bndr rhs rhs_se cont_ty thing_inside
 291   | preInlineUnconditionally env NotTopLevel bndr
 292   = tick (PreInlineUnconditionally bndr)                `thenSmpl_`
 293     thing_inside (extendSubst env bndr (ContEx (getSubstEnv rhs_se) rhs))
 294
 295
 296   | isStrictDmd (idNewDemandInfo bndr) || isStrictType (idType bndr)    -- A strict let
 297   =     -- Don't use simplBinder because that doesn't keep
 298         -- fragile occurrence in the substitution
 299     simplLetBndr env bndr                               `thenSmpl` \ (env, bndr') ->
 300     simplStrictArg env AnRhs rhs rhs_se cont_ty $ \ env rhs1 ->
 301
 302         -- Now complete the binding and simplify the body
 303     completeNonRecX env True {- strict -} bndr bndr' rhs1 thing_inside
 304
 305   | otherwise                                                   -- Normal, lazy case
 306   =     -- Don't use simplBinder because that doesn't keep
 307         -- fragile occurrence in the substitution
 308     simplLetBndr env bndr                               `thenSmpl` \ (env, bndr') ->
 309     simplLazyBind env NotTopLevel NonRecursive
 310                   bndr bndr' rhs rhs_se                 `thenSmpl` \ (floats, env) ->
 311     addFloats env floats thing_inside
 312 \end{code}
 313
 314 A specialised variant of simplNonRec used when the RHS is already simplified, notably
 315 in knownCon.  It uses case-binding where necessary.
 316
 317 \begin{code}
 318 simplNonRecX :: SimplEnv
 319              -> InId            -- Old binder
 320              -> OutExpr         -- Simplified RHS
 321              -> (SimplEnv -> SimplM FloatsWithExpr)
 322              -> SimplM FloatsWithExpr
 323
 324 simplNonRecX env bndr new_rhs thing_inside
 325   | preInlineUnconditionally env NotTopLevel  bndr
 326         -- This happens; for example, the case_bndr during case of
 327         -- known constructor:  case (a,b) of x { (p,q) -> ... }
 328         -- Here x isn't mentioned in the RHS, so we don't want to
 329         -- create the (dead) let-binding  let x = (a,b) in ...
 330         --
 331         -- Similarly, single occurrences can be inlined vigourously
 332         -- e.g.  case (f x, g y) of (a,b) -> ....
 333         -- If a,b occur once we can avoid constructing the let binding for them.
 334   = thing_inside (extendSubst env bndr (ContEx emptySubstEnv new_rhs))
 335
 336   | otherwise
 337   = simplBinder env bndr        `thenSmpl` \ (env, bndr') ->
 338     completeNonRecX env False {- Non-strict; pessimistic -}
 339                     bndr bndr' new_rhs thing_inside
 340
 341 completeNonRecX env is_strict old_bndr new_bndr new_rhs thing_inside
 342   | needsCaseBinding (idType new_bndr) new_rhs
 343   = thing_inside env                    `thenSmpl` \ (floats, body) ->
 344     returnSmpl (emptyFloats env, Case new_rhs new_bndr [(DEFAULT, [], wrapFloats floats body)])
 345
 346   | otherwise
 347   = mkAtomicArgs is_strict
 348                  True {- OK to float unlifted -}
 349                  new_rhs                        `thenSmpl` \ (aux_binds, rhs2) ->
 350
 351         -- Make the arguments atomic if necessary,
 352         -- adding suitable bindings
 353     addAtomicBindsE env aux_binds               $ \ env ->
 354     completeLazyBind env NotTopLevel
 355                      old_bndr new_bndr rhs2     `thenSmpl` \ (floats, env) ->
 356     addFloats env floats thing_inside
 357 \end{code}
 358
 359
 360 %************************************************************************
 361 %*                                                                      *
 362 \subsection{Lazy bindings}
 363 %*                                                                      *
 364 %************************************************************************
 365
 366 simplRecBind is used for
 367         * recursive bindings only
 368
 369 \begin{code}
 370 simplRecBind :: SimplEnv -> TopLevelFlag
 371              -> [(InId, InExpr)] -> [OutId]
 372              -> SimplM (FloatsWith SimplEnv)
 373 simplRecBind env top_lvl pairs bndrs'
 374   = go env pairs bndrs'         `thenSmpl` \ (floats, env) ->
 375     returnSmpl (flattenFloats floats, env)
 376   where
 377     go env [] _ = returnSmpl (emptyFloats env, env)
 378
 379     go env ((bndr, rhs) : pairs) (bndr' : bndrs')
 380         = simplRecOrTopPair env top_lvl bndr bndr' rhs  `thenSmpl` \ (floats, env) ->
 381           addFloats env floats (\env -> go env pairs bndrs')
 382 \end{code}
 383
 384
 385 simplRecOrTopPair is used for
 386         * recursive bindings (whether top level or not)
 387         * top-level non-recursive bindings
 388
 389 It assumes the binder has already been simplified, but not its IdInfo.
 390
 391 \begin{code}
 392 simplRecOrTopPair :: SimplEnv
 393                   -> TopLevelFlag
 394                   -> InId -> OutId              -- Binder, both pre-and post simpl
 395                   -> InExpr                     -- The RHS and its environment
 396                   -> SimplM (FloatsWith SimplEnv)
 397
 398 simplRecOrTopPair env top_lvl bndr bndr' rhs
 399   | preInlineUnconditionally env top_lvl bndr   -- Check for unconditional inline
 400   = tick (PreInlineUnconditionally bndr)        `thenSmpl_`
 401     returnSmpl (emptyFloats env, extendSubst env bndr (ContEx (getSubstEnv env) rhs))
 402
 403   | otherwise
 404   = simplLazyBind env top_lvl Recursive bndr bndr' rhs env
 405         -- May not actually be recursive, but it doesn't matter
 406 \end{code}
 407
 408
 409 simplLazyBind is used for
 410         * recursive bindings (whether top level or not)
 411         * top-level non-recursive bindings
 412         * non-top-level *lazy* non-recursive bindings
 413
 414 [Thus it deals with the lazy cases from simplNonRecBind, and all cases
 415 from SimplRecOrTopBind]
 416
 417 Nota bene:
 418     1. It assumes that the binder is *already* simplified,
 419        and is in scope, but not its IdInfo
 420
 421     2. It assumes that the binder type is lifted.
 422
 423     3. It does not check for pre-inline-unconditionallly;
 424        that should have been done already.
 425
 426 \begin{code}
 427 simplLazyBind :: SimplEnv
 428               -> TopLevelFlag -> RecFlag
 429               -> InId -> OutId          -- Binder, both pre-and post simpl
 430               -> InExpr -> SimplEnv     -- The RHS and its environment
 431               -> SimplM (FloatsWith SimplEnv)
 432
 433 simplLazyBind env top_lvl is_rec bndr bndr' rhs rhs_se
 434   =     -- Substitute IdInfo on binder, in the light of earlier
 435         -- substitutions in this very letrec, and extend the
 436         -- in-scope env, so that the IdInfo for this binder extends
 437         -- over the RHS for the binder itself.
 438         --
 439         -- This is important.  Manuel found cases where he really, really
 440         -- wanted a RULE for a recursive function to apply in that function's
 441         -- own right-hand side.
 442         --
 443         -- NB: does no harm for non-recursive bindings
 444     let
 445         bndr_ty'          = idType bndr'
 446         bndr''            = simplIdInfo (getSubst rhs_se) (idInfo bndr) bndr'
 447         env1              = modifyInScope env bndr'' bndr''
 448         rhs_env           = setInScope rhs_se env1
 449         ok_float_unlifted = isNotTopLevel top_lvl && isNonRec is_rec
 450         rhs_cont          = mkStop bndr_ty' AnRhs
 451     in
 452         -- Simplify the RHS; note the mkStop, which tells
 453         -- the simplifier that this is the RHS of a let.
 454     simplExprF rhs_env rhs rhs_cont             `thenSmpl` \ (floats, rhs1) ->
 455
 456         -- If any of the floats can't be floated, give up now
 457         -- (The allLifted predicate says True for empty floats.)
 458     if (not ok_float_unlifted && not (allLifted floats)) then
 459         completeLazyBind env1 top_lvl bndr bndr''
 460                          (wrapFloats floats rhs1)
 461     else
 462
 463         -- ANF-ise a constructor or PAP rhs
 464     mkAtomicArgs False {- Not strict -}
 465                  ok_float_unlifted rhs1                 `thenSmpl` \ (aux_binds, rhs2) ->
 466
 467         -- If the result is a PAP, float the floats out, else wrap them
 468         -- By this time it's already been ANF-ised (if necessary)
 469     if isEmptyFloats floats && null aux_binds then      -- Shortcut a common case
 470         completeLazyBind env1 top_lvl bndr bndr'' rhs2
 471
 472         -- We use exprIsTrivial here because we want to reveal lone variables.
 473         -- E.g.  let { x = letrec { y = E } in y } in ...
 474         -- Here we definitely want to float the y=E defn.
 475         -- exprIsValue definitely isn't right for that.
 476         --
 477         -- BUT we can't use "exprIsCheap", because that causes a strictness bug.
 478         --         x = let y* = E in case (scc y) of { T -> F; F -> T}
 479         -- The case expression is 'cheap', but it's wrong to transform to
 480         --         y* = E; x = case (scc y) of {...}
 481         -- Either we must be careful not to float demanded non-values, or
 482         -- we must use exprIsValue for the test, which ensures that the
 483         -- thing is non-strict.  I think.  The WARN below tests for this
 484     else if exprIsTrivial rhs2 || exprIsValue rhs2 then
 485                 -- There's a subtlety here.  There may be a binding (x* = e) in the
 486                 -- floats, where the '*' means 'will be demanded'.  So is it safe
 487                 -- to float it out?  Answer no, but it won't matter because
 488                 -- we only float if arg' is a WHNF,
 489                 -- and so there can't be any 'will be demanded' bindings in the floats.
 490                 -- Hence the assert
 491         WARN( any demanded_float (floatBinds floats),
 492               ppr (filter demanded_float (floatBinds floats)) )
 493
 494         tick LetFloatFromLet                    `thenSmpl_` (
 495         addFloats env1 floats                   $ \ env2 ->
 496         addAtomicBinds env2 aux_binds           $ \ env3 ->
 497         completeLazyBind env3 top_lvl bndr bndr'' rhs2)
 498
 499     else
 500         completeLazyBind env1 top_lvl bndr bndr'' (wrapFloats floats rhs1)
 501
 502 #ifdef DEBUG
 503 demanded_float (NonRec b r) = isStrictDmd (idNewDemandInfo b) && not (isUnLiftedType (idType b))
 504                 -- Unlifted-type (cheap-eagerness) lets may well have a demanded flag on them
 505 demanded_float (Rec _)      = False
 506 #endif
 507 \end{code}
 508
 509
 510 %************************************************************************
 511 %*                                                                      *
 512 \subsection{Completing a lazy binding}
 513 %*                                                                      *
 514 %************************************************************************
 515
 516 completeLazyBind
 517         * deals only with Ids, not TyVars
 518         * takes an already-simplified binder and RHS
 519         * is used for both recursive and non-recursive bindings
 520         * is used for both top-level and non-top-level bindings
 521
 522 It does the following:
 523   - tries discarding a dead binding
 524   - tries PostInlineUnconditionally
 525   - add unfolding [this is the only place we add an unfolding]
 526   - add arity
 527
 528 It does *not* attempt to do let-to-case.  Why?  Because it is used for
 529         - top-level bindings (when let-to-case is impossible)
 530         - many situations where the "rhs" is known to be a WHNF
 531                 (so let-to-case is inappropriate).
 532
 533 \begin{code}
 534 completeLazyBind :: SimplEnv
 535                  -> TopLevelFlag        -- Flag stuck into unfolding
 536                  -> InId                -- Old binder
 537                  -> OutId               -- New binder
 538                  -> OutExpr             -- Simplified RHS
 539                  -> SimplM (FloatsWith SimplEnv)
 540 -- We return a new SimplEnv, because completeLazyBind may choose to do its work
 541 -- by extending the substitution (e.g. let x = y in ...)
 542 -- The new binding (if any) is returned as part of the floats.
 543 -- NB: the returned SimplEnv has the right SubstEnv, but you should
 544 --     (as usual) use the in-scope-env from the floats
 545
 546 completeLazyBind env top_lvl old_bndr new_bndr new_rhs
 547   | postInlineUnconditionally env new_bndr loop_breaker new_rhs
 548   =             -- Drop the binding
 549     tick (PostInlineUnconditionally old_bndr)   `thenSmpl_`
 550     returnSmpl (emptyFloats env, extendSubst env old_bndr (DoneEx new_rhs))
 551                 -- Use the substitution to make quite, quite sure that the substitution
 552                 -- will happen, since we are going to discard the binding
 553
 554   |  otherwise
 555   = let
 556                 -- Add arity info
 557         new_bndr_info = idInfo new_bndr `setArityInfo` exprArity new_rhs
 558
 559                 -- Add the unfolding *only* for non-loop-breakers
 560                 -- Making loop breakers not have an unfolding at all
 561                 -- means that we can avoid tests in exprIsConApp, for example.
 562                 -- This is important: if exprIsConApp says 'yes' for a recursive
 563                 -- thing, then we can get into an infinite loop
 564         info_w_unf | loop_breaker = new_bndr_info
 565                    | otherwise    = new_bndr_info `setUnfoldingInfo` unfolding
 566         unfolding = mkUnfolding (isTopLevel top_lvl) new_rhs
 567
 568         final_id = new_bndr `setIdInfo` info_w_unf
 569     in
 570                 -- These seqs forces the Id, and hence its IdInfo,
 571                 -- and hence any inner substitutions
 572     final_id                                    `seq`
 573     returnSmpl (unitFloat env final_id new_rhs, env)
 574
 575   where
 576     loop_breaker = isLoopBreaker occ_info
 577     old_info     = idInfo old_bndr
 578     occ_info     = occInfo old_info
 579 \end{code}
 580
 581
 582
 583 %************************************************************************
 584 %*                                                                      *
 585 \subsection[Simplify-simplExpr]{The main function: simplExpr}
 586 %*                                                                      *
 587 %************************************************************************
 588
 589 The reason for this OutExprStuff stuff is that we want to float *after*
 590 simplifying a RHS, not before.  If we do so naively we get quadratic
 591 behaviour as things float out.
 592
 593 To see why it's important to do it after, consider this (real) example:
 594
 595         let t = f x
 596         in fst t
 597 ==>
 598         let t = let a = e1
 599                     b = e2
 600                 in (a,b)
 601         in fst t
 602 ==>
 603         let a = e1
 604             b = e2
 605             t = (a,b)
 606         in
 607         a       -- Can't inline a this round, cos it appears twice
 608 ==>
 609         e1
 610
 611 Each of the ==> steps is a round of simplification.  We'd save a
 612 whole round if we float first.  This can cascade.  Consider
 613
 614         let f = g d
 615         in \x -> ...f...
 616 ==>
 617         let f = let d1 = ..d.. in \y -> e
 618         in \x -> ...f...
 619 ==>
 620         let d1 = ..d..
 621         in \x -> ...(\y ->e)...
 622
 623 Only in this second round can the \y be applied, and it
 624 might do the same again.
 625
 626
 627 \begin{code}
 628 simplExpr :: SimplEnv -> CoreExpr -> SimplM CoreExpr
 629 simplExpr env expr = simplExprC env expr (mkBoringStop expr_ty')
 630                    where
 631                      expr_ty' = substTy (getSubst env) (exprType expr)
 632         -- The type in the Stop continuation, expr_ty', is usually not used
 633         -- It's only needed when discarding continuations after finding
 634         -- a function that returns bottom.
 635         -- Hence the lazy substitution
 636
 637
 638 simplExprC :: SimplEnv -> CoreExpr -> SimplCont -> SimplM CoreExpr
 639         -- Simplify an expression, given a continuation
 640 simplExprC env expr cont
 641   = simplExprF env expr cont    `thenSmpl` \ (floats, expr) ->
 642     returnSmpl (wrapFloats floats expr)
 643
 644 simplExprF :: SimplEnv -> InExpr -> SimplCont -> SimplM FloatsWithExpr
 645         -- Simplify an expression, returning floated binds
 646
 647 simplExprF env (Var v)          cont = simplVar env v cont
 648 simplExprF env (Lit lit)        cont = rebuild env (Lit lit) cont
 649 simplExprF env expr@(Lam _ _)   cont = simplLam env expr cont
 650 simplExprF env (Note note expr) cont = simplNote env note expr cont
 651 simplExprF env (App fun arg)    cont = simplExprF env fun (ApplyTo NoDup arg env cont)
 652
 653 simplExprF env (Type ty) cont
 654   = ASSERT( contIsRhsOrArg cont )
 655     simplType env ty                    `thenSmpl` \ ty' ->
 656     rebuild env (Type ty') cont
 657
 658 simplExprF env (Case scrut bndr alts) cont
 659   | not (switchIsOn (getSwitchChecker env) NoCaseOfCase)
 660   =     -- Simplify the scrutinee with a Select continuation
 661     simplExprF env scrut (Select NoDup bndr alts env cont)
 662
 663   | otherwise
 664   =     -- If case-of-case is off, simply simplify the case expression
 665         -- in a vanilla Stop context, and rebuild the result around it
 666     simplExprC env scrut case_cont      `thenSmpl` \ case_expr' ->
 667     rebuild env case_expr' cont
 668   where
 669     case_cont = Select NoDup bndr alts env (mkBoringStop (contResultType cont))
 670
 671 simplExprF env (Let (Rec pairs) body) cont
 672   = simplRecBndrs env (map fst pairs)           `thenSmpl` \ (env, bndrs') ->
 673         -- NB: bndrs' don't have unfoldings or spec-envs
 674         -- We add them as we go down, using simplPrags
 675
 676     simplRecBind env NotTopLevel pairs bndrs'   `thenSmpl` \ (floats, env) ->
 677     addFloats env floats                        $ \ env ->
 678     simplExprF env body cont
 679
 680 -- A non-recursive let is dealt with by simplNonRecBind
 681 simplExprF env (Let (NonRec bndr rhs) body) cont
 682   = simplNonRecBind env bndr rhs env (contResultType cont)      $ \ env ->
 683     simplExprF env body cont
 684
 685
 686 ---------------------------------
 687 simplType :: SimplEnv -> InType -> SimplM OutType
 688         -- Kept monadic just so we can do the seqType
 689 simplType env ty
 690   = seqType new_ty   `seq`   returnSmpl new_ty
 691   where
 692     new_ty = substTy (getSubst env) ty
 693 \end{code}
 694
 695
 696 %************************************************************************
 697 %*                                                                      *
 698 \subsection{Lambdas}
 699 %*                                                                      *
 700 %************************************************************************
 701
 702 \begin{code}
 703 simplLam env fun cont
 704   = go env fun cont
 705   where
 706     zap_it  = mkLamBndrZapper fun (countArgs cont)
 707     cont_ty = contResultType cont
 708
 709         -- Type-beta reduction
 710     go env (Lam bndr body) (ApplyTo _ (Type ty_arg) arg_se body_cont)
 711       = ASSERT( isTyVar bndr )
 712         tick (BetaReduction bndr)                       `thenSmpl_`
 713         simplType (setInScope arg_se env) ty_arg        `thenSmpl` \ ty_arg' ->
 714         go (extendSubst env bndr (DoneTy ty_arg')) body body_cont
 715
 716         -- Ordinary beta reduction
 717     go env (Lam bndr body) cont@(ApplyTo _ arg arg_se body_cont)
 718       = tick (BetaReduction bndr)                               `thenSmpl_`
 719         simplNonRecBind env (zap_it bndr) arg arg_se cont_ty    $ \ env ->
 720         go env body body_cont
 721
 722         -- Not enough args, so there are real lambdas left to put in the result
 723     go env lam@(Lam _ _) cont
 724       = simplLamBndrs env bndrs         `thenSmpl` \ (env, bndrs') ->
 725         simplExpr env body              `thenSmpl` \ body' ->
 726         mkLam env bndrs' body' cont     `thenSmpl` \ (floats, new_lam) ->
 727         addFloats env floats            $ \ env ->
 728         rebuild env new_lam cont
 729       where
 730         (bndrs,body) = collectBinders lam
 731
 732         -- Exactly enough args
 733     go env expr cont = simplExprF env expr cont
 734
 735 mkLamBndrZapper :: CoreExpr     -- Function
 736                 -> Int          -- Number of args supplied, *including* type args
 737                 -> Id -> Id     -- Use this to zap the binders
 738 mkLamBndrZapper fun n_args
 739   | n_args >= n_params fun = \b -> b            -- Enough args
 740   | otherwise              = \b -> zapLamIdInfo b
 741   where
 742         -- NB: we count all the args incl type args
 743         -- so we must count all the binders (incl type lambdas)
 744     n_params (Note _ e) = n_params e
 745     n_params (Lam b e)  = 1 + n_params e
 746     n_params other      = 0::Int
 747 \end{code}
 748
 749
 750 %************************************************************************
 751 %*                                                                      *
 752 \subsection{Notes}
 753 %*                                                                      *
 754 %************************************************************************
 755
 756 \begin{code}
 757 simplNote env (Coerce to from) body cont
 758   = let
 759         in_scope = getInScope env
 760
 761         addCoerce s1 k1 (CoerceIt t1 cont)
 762                 --      coerce T1 S1 (coerce S1 K1 e)
 763                 -- ==>
 764                 --      e,                      if T1=K1
 765                 --      coerce T1 K1 e,         otherwise
 766                 --
 767                 -- For example, in the initial form of a worker
 768                 -- we may find  (coerce T (coerce S (\x.e))) y
 769                 -- and we'd like it to simplify to e[y/x] in one round
 770                 -- of simplification
 771           | t1 `eqType` k1  = cont              -- The coerces cancel out
 772           | otherwise       = CoerceIt t1 cont  -- They don't cancel, but
 773                                                 -- the inner one is redundant
 774
 775         addCoerce t1t2 s1s2 (ApplyTo dup arg arg_se cont)
 776           | Just (s1, s2) <- splitFunTy_maybe s1s2
 777                 --      (coerce (T1->T2) (S1->S2) F) E
 778                 -- ===>
 779                 --      coerce T2 S2 (F (coerce S1 T1 E))
 780                 --
 781                 -- t1t2 must be a function type, T1->T2
 782                 -- but s1s2 might conceivably not be
 783                 --
 784                 -- When we build the ApplyTo we can't mix the out-types
 785                 -- with the InExpr in the argument, so we simply substitute
 786                 -- to make it all consistent.  It's a bit messy.
 787                 -- But it isn't a common case.
 788           = let
 789                 (t1,t2) = splitFunTy t1t2
 790                 new_arg = mkCoerce s1 t1 (substExpr (mkSubst in_scope (getSubstEnv arg_se)) arg)
 791             in
 792             ApplyTo dup new_arg (zapSubstEnv env) (addCoerce t2 s2 cont)
 793
 794         addCoerce to' _ cont = CoerceIt to' cont
 795     in
 796     simplType env to            `thenSmpl` \ to' ->
 797     simplType env from          `thenSmpl` \ from' ->
 798     simplExprF env body (addCoerce to' from' cont)
 799
 800
 801 -- Hack: we only distinguish subsumed cost centre stacks for the purposes of
 802 -- inlining.  All other CCCSs are mapped to currentCCS.
 803 simplNote env (SCC cc) e cont
 804   = simplExpr (setEnclosingCC env currentCCS) e         `thenSmpl` \ e' ->
 805     rebuild env (mkSCC cc e') cont
 806
 807 simplNote env InlineCall e cont
 808   = simplExprF env e (InlinePlease cont)
 809
 810 -- See notes with SimplMonad.inlineMode
 811 simplNote env InlineMe e cont
 812   | contIsRhsOrArg cont         -- Totally boring continuation; see notes above
 813   =                             -- Don't inline inside an INLINE expression
 814     simplExpr (setMode inlineMode env )  e      `thenSmpl` \ e' ->
 815     rebuild env (mkInlineMe e') cont
 816
 817   | otherwise   -- Dissolve the InlineMe note if there's
 818                 -- an interesting context of any kind to combine with
 819                 -- (even a type application -- anything except Stop)
 820   = simplExprF env e cont
 821 \end{code}
 822
 823
 824 %************************************************************************
 825 %*                                                                      *
 826 \subsection{Dealing with calls}
 827 %*                                                                      *
 828 %************************************************************************
 829
 830 \begin{code}
 831 simplVar env var cont
 832   = case lookupIdSubst (getSubst env) var of
 833         DoneEx e        -> simplExprF (zapSubstEnv env) e cont
 834         ContEx se e     -> simplExprF (setSubstEnv env se) e cont
 835         DoneId var1 occ -> WARN( not (isInScope var1 (getSubst env)) && mustHaveLocalBinding var1,
 836                                  text "simplVar:" <+> ppr var )
 837                            completeCall (zapSubstEnv env) var1 occ cont
 838                 -- The template is already simplified, so don't re-substitute.
 839                 -- This is VITAL.  Consider
 840                 --      let x = e in
 841                 --      let y = \z -> ...x... in
 842                 --      \ x -> ...y...
 843                 -- We'll clone the inner \x, adding x->x' in the id_subst
 844                 -- Then when we inline y, we must *not* replace x by x' in
 845                 -- the inlined copy!!
 846
 847 ---------------------------------------------------------
 848 --      Dealing with a call site
 849
 850 completeCall env var occ_info cont
 851   =     -- Simplify the arguments
 852     getDOptsSmpl                                        `thenSmpl` \ dflags ->
 853     let
 854         chkr                           = getSwitchChecker env
 855         (args, call_cont, inline_call) = getContArgs chkr var cont
 856     in
 857     simplifyArgs env args (contResultType call_cont)    $ \ env args ->
 858
 859         -- Next, look for rules or specialisations that match
 860         --
 861         -- It's important to simplify the args first, because the rule-matcher
 862         -- doesn't do substitution as it goes.  We don't want to use subst_args
 863         -- (defined in the 'where') because that throws away useful occurrence info,
 864         -- and perhaps-very-important specialisations.
 865         --
 866         -- Some functions have specialisations *and* are strict; in this case,
 867         -- we don't want to inline the wrapper of the non-specialised thing; better
 868         -- to call the specialised thing instead.
 869         -- We used to use the black-listing mechanism to ensure that inlining of
 870         -- the wrapper didn't occur for things that have specialisations till a
 871         -- later phase, so but now we just try RULES first
 872         --
 873         -- You might think that we shouldn't apply rules for a loop breaker:
 874         -- doing so might give rise to an infinite loop, because a RULE is
 875         -- rather like an extra equation for the function:
 876         --      RULE:           f (g x) y = x+y
 877         --      Eqn:            f a     y = a-y
 878         --
 879         -- But it's too drastic to disable rules for loop breakers.
 880         -- Even the foldr/build rule would be disabled, because foldr
 881         -- is recursive, and hence a loop breaker:
 882         --      foldr k z (build g) = g k z
 883         -- So it's up to the programmer: rules can cause divergence
 884
 885     let
 886         in_scope   = getInScope env
 887         maybe_rule = case activeRule env of
 888                         Nothing     -> Nothing  -- No rules apply
 889                         Just act_fn -> lookupRule act_fn in_scope var args
 890     in
 891     case maybe_rule of {
 892         Just (rule_name, rule_rhs) ->
 893                 tick (RuleFired rule_name)                      `thenSmpl_`
 894                 (if dopt Opt_D_dump_inlinings dflags then
 895                    pprTrace "Rule fired" (vcat [
 896                         text "Rule:" <+> ptext rule_name,
 897                         text "Before:" <+> ppr var <+> sep (map pprParendExpr args),
 898                         text "After: " <+> pprCoreExpr rule_rhs])
 899                  else
 900                         id)             $
 901                 simplExprF env rule_rhs call_cont ;
 902
 903         Nothing ->              -- No rules
 904
 905         -- Next, look for an inlining
 906     let
 907         arg_infos = [ interestingArg arg | arg <- args, isValArg arg]
 908
 909         interesting_cont = interestingCallContext (not (null args))
 910                                                   (not (null arg_infos))
 911                                                   call_cont
 912
 913         active_inline = activeInline env var
 914         maybe_inline  = callSiteInline dflags active_inline inline_call occ_info
 915                                        var arg_infos interesting_cont
 916     in
 917     case maybe_inline of {
 918         Just unfolding          -- There is an inlining!
 919           ->  tick (UnfoldingDone var)          `thenSmpl_`
 920               makeThatCall env var unfolding args call_cont
 921
 922         ;
 923         Nothing ->              -- No inlining!
 924
 925         -- Done
 926     rebuild env (mkApps (Var var) args) call_cont
 927     }}
 928
 929 makeThatCall :: SimplEnv
 930              -> Id
 931              -> InExpr          -- Inlined function rhs
 932              -> [OutExpr]       -- Arguments, already simplified
 933              -> SimplCont       -- After the call
 934              -> SimplM FloatsWithExpr
 935 -- Similar to simplLam, but this time
 936 -- the arguments are already simplified
 937 makeThatCall orig_env var fun@(Lam _ _) args cont
 938   = go orig_env fun args
 939   where
 940     zap_it = mkLamBndrZapper fun (length args)
 941
 942         -- Type-beta reduction
 943     go env (Lam bndr body) (Type ty_arg : args)
 944       = ASSERT( isTyVar bndr )
 945         tick (BetaReduction bndr)                       `thenSmpl_`
 946         go (extendSubst env bndr (DoneTy ty_arg)) body args
 947
 948         -- Ordinary beta reduction
 949     go env (Lam bndr body) (arg : args)
 950       = tick (BetaReduction bndr)                       `thenSmpl_`
 951         simplNonRecX env (zap_it bndr) arg              $ \ env ->
 952         go env body args
 953
 954         -- Not enough args, so there are real lambdas left to put in the result
 955     go env fun args
 956       = simplExprF env fun (pushContArgs orig_env args cont)
 957         -- NB: orig_env; the correct environment to capture with
 958         -- the arguments.... env has been augmented with substitutions
 959         -- from the beta reductions.
 960
 961 makeThatCall env var fun args cont
 962   = simplExprF env fun (pushContArgs env args cont)
 963 \end{code}
 964
 965
 966 %************************************************************************
 967 %*                                                                      *
 968 \subsection{Arguments}
 969 %*                                                                      *
 970 %************************************************************************
 971
 972 \begin{code}
 973 ---------------------------------------------------------
 974 --      Simplifying the arguments of a call
 975
 976 simplifyArgs :: SimplEnv
 977              -> [(InExpr, SimplEnv, Bool)]      -- Details of the arguments
 978              -> OutType                         -- Type of the continuation
 979              -> (SimplEnv -> [OutExpr] -> SimplM FloatsWithExpr)
 980              -> SimplM FloatsWithExpr
 981
 982 -- [CPS-like because of strict arguments]
 983
 984 -- Simplify the arguments to a call.
 985 -- This part of the simplifier may break the no-shadowing invariant
 986 -- Consider
 987 --      f (...(\a -> e)...) (case y of (a,b) -> e')
 988 -- where f is strict in its second arg
 989 -- If we simplify the innermost one first we get (...(\a -> e)...)
 990 -- Simplifying the second arg makes us float the case out, so we end up with
 991 --      case y of (a,b) -> f (...(\a -> e)...) e'
 992 -- So the output does not have the no-shadowing invariant.  However, there is
 993 -- no danger of getting name-capture, because when the first arg was simplified
 994 -- we used an in-scope set that at least mentioned all the variables free in its
 995 -- static environment, and that is enough.
 996 --
 997 -- We can't just do innermost first, or we'd end up with a dual problem:
 998 --      case x of (a,b) -> f e (...(\a -> e')...)
 999 --
1000 -- I spent hours trying to recover the no-shadowing invariant, but I just could
1001 -- not think of an elegant way to do it.  The simplifier is already knee-deep in
1002 -- continuations.  We have to keep the right in-scope set around; AND we have
1003 -- to get the effect that finding (error "foo") in a strict arg position will
1004 -- discard the entire application and replace it with (error "foo").  Getting
1005 -- all this at once is TOO HARD!
1006
1007 simplifyArgs env args cont_ty thing_inside
1008   = go env args thing_inside
1009   where
1010     go env []         thing_inside = thing_inside env []
1011     go env (arg:args) thing_inside = simplifyArg env arg cont_ty        $ \ env arg' ->
1012                                      go env args                        $ \ env args' ->
1013                                      thing_inside env (arg':args')
1014
1015 simplifyArg env (Type ty_arg, se, _) cont_ty thing_inside
1016   = simplType (setInScope se env) ty_arg        `thenSmpl` \ new_ty_arg ->
1017     thing_inside env (Type new_ty_arg)
1018
1019 simplifyArg env (val_arg, arg_se, is_strict) cont_ty thing_inside
1020   | is_strict
1021   = simplStrictArg env AnArg val_arg arg_se cont_ty thing_inside
1022
1023   | otherwise
1024   = let
1025         arg_env = setInScope arg_se env
1026     in
1027     simplType arg_env (exprType val_arg)                `thenSmpl` \ arg_ty ->
1028     simplExprF arg_env val_arg (mkStop arg_ty AnArg)    `thenSmpl` \ (floats, arg1) ->
1029     addFloats env floats                                $ \ env ->
1030     thing_inside env arg1
1031
1032
1033 simplStrictArg :: SimplEnv              -- The env of the call
1034                 -> LetRhsFlag
1035                 -> InExpr -> SimplEnv   -- The arg plus its env
1036                 -> OutType              -- cont_ty: Type of thing computed by the context
1037                 -> (SimplEnv -> OutExpr -> SimplM FloatsWithExpr)
1038                                         -- Takes an expression of type rhs_ty,
1039                                         -- returns an expression of type cont_ty
1040                                         -- The env passed to this continuation is the
1041                                         -- env of the call, plus any new in-scope variables
1042                 -> SimplM FloatsWithExpr        -- An expression of type cont_ty
1043
1044 simplStrictArg call_env is_rhs arg arg_env cont_ty thing_inside
1045   = simplExprF (setInScope arg_env call_env) arg
1046                (ArgOf NoDup is_rhs cont_ty (\ new_env -> thing_inside (setInScope call_env new_env)))
1047   -- Notice the way we use arg_env (augmented with in-scope vars from call_env)
1048   --    to simplify the argument
1049   -- and call-env (augmented with in-scope vars from the arg) to pass to the continuation
1050 \end{code}
1051
1052
1053 %************************************************************************
1054 %*                                                                      *
1055 \subsection{mkAtomicArgs}
1056 %*                                                                      *
1057 %************************************************************************
1058
1059 mkAtomicArgs takes a putative RHS, checks whether it's a PAP or
1060 constructor application and, if so, converts it to ANF, so that the
1061 resulting thing can be inlined more easily.  Thus
1062         x = (f a, g b)
1063 becomes
1064         t1 = f a
1065         t2 = g b
1066         x = (t1,t2)
1067
1068 There are three sorts of binding context, specified by the two
1069 boolean arguments
1070
1071 Strict
1072    OK-unlifted
1073
1074 N  N    Top-level or recursive                  Only bind args of lifted type
1075
1076 N  Y    Non-top-level and non-recursive,        Bind args of lifted type, or
1077                 but lazy                        unlifted-and-ok-for-speculation
1078
1079 Y  Y    Non-top-level, non-recursive,           Bind all args
1080                  and strict (demanded)
1081
1082
1083 For example, given
1084
1085         x = MkC (y div# z)
1086
1087 there is no point in transforming to
1088
1089         x = case (y div# z) of r -> MkC r
1090
1091 because the (y div# z) can't float out of the let. But if it was
1092 a *strict* let, then it would be a good thing to do.  Hence the
1093 context information.
1094
1095 \begin{code}
1096 mkAtomicArgs :: Bool    -- A strict binding
1097              -> Bool    -- OK to float unlifted args
1098              -> OutExpr
1099              -> SimplM ([(OutId,OutExpr)],      -- The floats (unusually) may include
1100                         OutExpr)                -- things that need case-binding,
1101                                                 -- if the strict-binding flag is on
1102
1103 mkAtomicArgs is_strict ok_float_unlifted rhs
1104   = mk_atomic_args rhs          `thenSmpl` \ maybe_stuff ->
1105     case maybe_stuff of
1106         Nothing               -> returnSmpl ([],              rhs)
1107         Just (ol_binds, rhs') -> returnSmpl (fromOL ol_binds, rhs')
1108
1109   where
1110     mk_atomic_args :: OutExpr -> SimplM (Maybe (OrdList (Id,OutExpr), OutExpr))
1111         -- Nothing => no change
1112     mk_atomic_args rhs
1113       | (Var fun, args) <- collectArgs rhs,                     -- It's an application
1114         isDataConId fun || valArgCount args < idArity fun       -- And it's a constructor or PAP
1115       =         -- Worth a try
1116         go nilOL [] args        `thenSmpl` \ maybe_stuff ->
1117         case maybe_stuff of
1118           Nothing                 -> returnSmpl Nothing
1119           Just (aux_binds, args') -> returnSmpl (Just (aux_binds, mkApps (Var fun) args'))
1120
1121      | otherwise
1122      = returnSmpl Nothing
1123
1124     go binds rev_args []
1125         = returnSmpl (Just (binds, reverse rev_args))
1126     go binds rev_args (arg : args)
1127         |  exprIsTrivial arg    -- Easy case
1128         = go binds (arg:rev_args) args
1129
1130         | not can_float_arg     -- Can't make this arg atomic
1131         = returnSmpl Nothing    -- ... so give up
1132
1133         | otherwise     -- Don't forget to do it recursively
1134                         -- E.g.  x = a:b:c:[]
1135         =  mk_atomic_args arg                                   `thenSmpl` \ maybe_anf ->
1136            case maybe_anf of {
1137              Nothing -> returnSmpl Nothing ;
1138              Just (arg_binds,arg') ->
1139
1140            newId SLIT("a") arg_ty                               `thenSmpl` \ arg_id ->
1141            go ((arg_binds `snocOL` (arg_id,arg')) `appOL` binds)
1142               (Var arg_id : rev_args) args
1143            }
1144         where
1145           arg_ty        = exprType arg
1146           can_float_arg =  is_strict
1147                         || not (isUnLiftedType arg_ty)
1148                         || (ok_float_unlifted && exprOkForSpeculation arg)
1149
1150 addAtomicBinds :: SimplEnv -> [(OutId,OutExpr)]
1151                -> (SimplEnv -> SimplM (FloatsWith a))
1152                -> SimplM (FloatsWith a)
1153 addAtomicBinds env []         thing_inside = thing_inside env
1154 addAtomicBinds env ((v,r):bs) thing_inside = addAuxiliaryBind env (NonRec v r) $ \ env ->
1155                                              addAtomicBinds env bs thing_inside
1156
1157 addAtomicBindsE :: SimplEnv -> [(OutId,OutExpr)]
1158                 -> (SimplEnv -> SimplM FloatsWithExpr)
1159                 -> SimplM FloatsWithExpr
1160 -- Same again, but this time we're in an expression context,
1161 -- and may need to do some case bindings
1162
1163 addAtomicBindsE env [] thing_inside
1164   = thing_inside env
1165 addAtomicBindsE env ((v,r):bs) thing_inside
1166   | needsCaseBinding (idType v) r
1167   = addAtomicBindsE (addNewInScopeIds env [v]) bs thing_inside  `thenSmpl` \ (floats, expr) ->
1168     WARN( exprIsTrivial expr, ppr v <+> pprCoreExpr expr )
1169     returnSmpl (emptyFloats env, Case r v [(DEFAULT,[], wrapFloats floats expr)])
1170
1171   | otherwise
1172   = addAuxiliaryBind env (NonRec v r)   $ \ env ->
1173     addAtomicBindsE env bs thing_inside
1174 \end{code}
1175
1176
1177 %************************************************************************
1178 %*                                                                      *
1179 \subsection{The main rebuilder}
1180 %*                                                                      *
1181 %************************************************************************
1182
1183 \begin{code}
1184 rebuild :: SimplEnv -> OutExpr -> SimplCont -> SimplM FloatsWithExpr
1185
1186 rebuild env expr (Stop _ _ _)                 = rebuildDone env expr
1187 rebuild env expr (ArgOf _ _ _ cont_fn)        = cont_fn env expr
1188 rebuild env expr (CoerceIt to_ty cont)        = rebuild env (mkCoerce to_ty (exprType expr) expr) cont
1189 rebuild env expr (InlinePlease cont)          = rebuild env (Note InlineCall expr) cont
1190 rebuild env expr (Select _ bndr alts se cont) = rebuildCase (setInScope se env) expr bndr alts cont
1191 rebuild env expr (ApplyTo _ arg se cont)      = rebuildApp  (setInScope se env) expr arg cont
1192
1193 rebuildApp env fun arg cont
1194   = simplExpr env arg   `thenSmpl` \ arg' ->
1195     rebuild env (App fun arg') cont
1196
1197 rebuildDone env expr = returnSmpl (emptyFloats env, expr)
1198 \end{code}
1199
1200
1201 %************************************************************************
1202 %*                                                                      *
1203 \subsection{Functions dealing with a case}
1204 %*                                                                      *
1205 %************************************************************************
1206
1207 Blob of helper functions for the "case-of-something-else" situation.
1208
1209 \begin{code}
1210 ---------------------------------------------------------
1211 --      Eliminate the case if possible
1212
1213 rebuildCase :: SimplEnv
1214             -> OutExpr          -- Scrutinee
1215             -> InId             -- Case binder
1216             -> [InAlt]          -- Alternatives
1217             -> SimplCont
1218             -> SimplM FloatsWithExpr
1219
1220 rebuildCase env scrut case_bndr alts cont
1221   | Just (con,args) <- exprIsConApp_maybe scrut
1222         -- Works when the scrutinee is a variable with a known unfolding
1223         -- as well as when it's an explicit constructor application
1224   = knownCon env (DataAlt con) args case_bndr alts cont
1225
1226   | Lit lit <- scrut    -- No need for same treatment as constructors
1227                         -- because literals are inlined more vigorously
1228   = knownCon env (LitAlt lit) [] case_bndr alts cont
1229
1230   | otherwise
1231   =     -- Prepare case alternatives
1232         -- Filter out alternatives that can't possibly match
1233     let
1234         impossible_cons = case scrut of
1235                             Var v -> otherCons (idUnfolding v)
1236                             other -> []
1237         better_alts = case impossible_cons of
1238                         []    -> alts
1239                         other -> [alt | alt@(con,_,_) <- alts,
1240                                         not (con `elem` impossible_cons)]
1241     in
1242
1243         -- Deal with the case binder, and prepare the continuation;
1244         -- The new subst_env is in place
1245     prepareCaseCont env better_alts cont                `thenSmpl` \ (floats, cont') ->
1246     addFloats env floats                                $ \ env ->
1247
1248         -- Deal with variable scrutinee
1249     simplCaseBinder env scrut case_bndr                 `thenSmpl` \ (alt_env, case_bndr', zap_occ_info) ->
1250
1251         -- Deal with the case alternatives
1252     simplAlts alt_env zap_occ_info impossible_cons
1253               case_bndr' better_alts cont'              `thenSmpl` \ alts' ->
1254
1255         -- Put the case back together
1256     mkCase scrut case_bndr' alts'                       `thenSmpl` \ case_expr ->
1257
1258         -- Notice that rebuildDone returns the in-scope set from env, not alt_env
1259         -- The case binder *not* scope over the whole returned case-expression
1260     rebuildDone env case_expr
1261 \end{code}
1262
1263 simplCaseBinder checks whether the scrutinee is a variable, v.  If so,
1264 try to eliminate uses of v in the RHSs in favour of case_bndr; that
1265 way, there's a chance that v will now only be used once, and hence
1266 inlined.
1267
1268 Note 1
1269 ~~~~~~
1270 There is a time we *don't* want to do that, namely when
1271 -fno-case-of-case is on.  This happens in the first simplifier pass,
1272 and enhances full laziness.  Here's the bad case:
1273         f = \ y -> ...(case x of I# v -> ...(case x of ...) ... )
1274 If we eliminate the inner case, we trap it inside the I# v -> arm,
1275 which might prevent some full laziness happening.  I've seen this
1276 in action in spectral/cichelli/Prog.hs:
1277          [(m,n) | m <- [1..max], n <- [1..max]]
1278 Hence the check for NoCaseOfCase.
1279
1280 Note 2
1281 ~~~~~~
1282 There is another situation when we don't want to do it.  If we have
1283
1284     case x of w1 { DEFAULT -> case x of w2 { A -> e1; B -> e2 }
1285                    ...other cases .... }
1286
1287 We'll perform the binder-swap for the outer case, giving
1288
1289     case x of w1 { DEFAULT -> case w1 of w2 { A -> e1; B -> e2 }
1290                    ...other cases .... }
1291
1292 But there is no point in doing it for the inner case,
1293 because w1 can't be inlined anyway.   Furthermore, doing the case-swapping
1294 involves zapping w2's occurrence info (see paragraphs that follow),
1295 and that forces us to bind w2 when doing case merging.  So we get
1296
1297     case x of w1 { A -> let w2 = w1 in e1
1298                    B -> let w2 = w1 in e2
1299                    ...other cases .... }
1300
1301 This is plain silly in the common case where w2 is dead.
1302
1303 Even so, I can't see a good way to implement this idea.  I tried
1304 not doing the binder-swap if the scrutinee was already evaluated
1305 but that failed big-time:
1306
1307         data T = MkT !Int
1308
1309         case v of w  { MkT x ->
1310         case x of x1 { I# y1 ->
1311         case x of x2 { I# y2 -> ...
1312
1313 Notice that because MkT is strict, x is marked "evaluated".  But to
1314 eliminate the last case, we must either make sure that x (as well as
1315 x1) has unfolding MkT y1.  THe straightforward thing to do is to do
1316 the binder-swap.  So this whole note is a no-op.
1317
1318 Note 3
1319 ~~~~~~
1320 If we replace the scrutinee, v, by tbe case binder, then we have to nuke
1321 any occurrence info (eg IAmDead) in the case binder, because the
1322 case-binder now effectively occurs whenever v does.  AND we have to do
1323 the same for the pattern-bound variables!  Example:
1324
1325         (case x of { (a,b) -> a }) (case x of { (p,q) -> q })
1326
1327 Here, b and p are dead.  But when we move the argment inside the first
1328 case RHS, and eliminate the second case, we get
1329
1330         case x or { (a,b) -> a b }
1331
1332 Urk! b is alive!  Reason: the scrutinee was a variable, and case elimination
1333 happened.  Hence the zap_occ_info function returned by simplCaseBinder
1334
1335 \begin{code}
1336 simplCaseBinder env (Var v) case_bndr
1337   | not (switchIsOn (getSwitchChecker env) NoCaseOfCase)
1338
1339 -- Failed try [see Note 2 above]
1340 --     not (isEvaldUnfolding (idUnfolding v))
1341
1342   = simplBinder env (zap case_bndr)             `thenSmpl` \ (env, case_bndr') ->
1343     returnSmpl (modifyInScope env v case_bndr', case_bndr', zap)
1344         -- We could extend the substitution instead, but it would be
1345         -- a hack because then the substitution wouldn't be idempotent
1346         -- any more (v is an OutId).  And this just just as well.
1347   where
1348     zap b = b `setIdOccInfo` NoOccInfo
1349
1350 simplCaseBinder env other_scrut case_bndr
1351   = simplBinder env case_bndr           `thenSmpl` \ (env, case_bndr') ->
1352     returnSmpl (env, case_bndr', \ bndr -> bndr)        -- NoOp on bndr
1353 \end{code}
1354
1355
1356
1357 \begin{code}
1358 simplAlts :: SimplEnv
1359           -> (InId -> InId)             -- Occ-info zapper
1360           -> [AltCon]                   -- Alternatives the scrutinee can't be
1361           -> OutId                      -- Case binder
1362           -> [InAlt] -> SimplCont
1363           -> SimplM [OutAlt]            -- Includes the continuation
1364
1365 simplAlts env zap_occ_info impossible_cons case_bndr' alts cont'
1366   = mapSmpl simpl_alt alts
1367   where
1368     inst_tys' = tyConAppArgs (idType case_bndr')
1369
1370         -- handled_cons is all the constructors that are dealt
1371         -- with, either by being impossible, or by there being an alternative
1372     (con_alts,_) = findDefault alts
1373     handled_cons = impossible_cons ++ [con | (con,_,_) <- con_alts]
1374
1375     simpl_alt (DEFAULT, _, rhs)
1376         = let
1377                 -- In the default case we record the constructors that the
1378                 -- case-binder *can't* be.
1379                 -- We take advantage of any OtherCon info in the case scrutinee
1380                 case_bndr_w_unf = case_bndr' `setIdUnfolding` mkOtherCon handled_cons
1381                 env_with_unf    = modifyInScope env case_bndr' case_bndr_w_unf
1382           in
1383           simplExprC env_with_unf rhs cont'     `thenSmpl` \ rhs' ->
1384           returnSmpl (DEFAULT, [], rhs')
1385
1386     simpl_alt (con, vs, rhs)
1387         =       -- Deal with the pattern-bound variables
1388                 -- Mark the ones that are in ! positions in the data constructor
1389                 -- as certainly-evaluated.
1390                 -- NB: it happens that simplBinders does *not* erase the OtherCon
1391                 --     form of unfolding, so it's ok to add this info before
1392                 --     doing simplBinders
1393           simplBinders env (add_evals con vs)           `thenSmpl` \ (env, vs') ->
1394
1395                 -- Bind the case-binder to (con args)
1396           let
1397                 unfolding    = mkUnfolding False (mkAltExpr con vs' inst_tys')
1398                 env_with_unf = modifyInScope env case_bndr' (case_bndr' `setIdUnfolding` unfolding)
1399           in
1400           simplExprC env_with_unf rhs cont'             `thenSmpl` \ rhs' ->
1401           returnSmpl (con, vs', rhs')
1402
1403
1404         -- add_evals records the evaluated-ness of the bound variables of
1405         -- a case pattern.  This is *important*.  Consider
1406         --      data T = T !Int !Int
1407         --
1408         --      case x of { T a b -> T (a+1) b }
1409         --
1410         -- We really must record that b is already evaluated so that we don't
1411         -- go and re-evaluate it when constructing the result.
1412
1413     add_evals (DataAlt dc) vs = cat_evals vs (dataConRepStrictness dc)
1414     add_evals other_con    vs = vs
1415
1416     cat_evals [] [] = []
1417     cat_evals (v:vs) (str:strs)
1418         | isTyVar v          = v        : cat_evals vs (str:strs)
1419         | isMarkedStrict str = evald_v  : cat_evals vs strs
1420         | otherwise          = zapped_v : cat_evals vs strs
1421         where
1422           zapped_v = zap_occ_info v
1423           evald_v  = zapped_v `setIdUnfolding` mkOtherCon []
1424 \end{code}
1425
1426
1427 %************************************************************************
1428 %*                                                                      *
1429 \subsection{Known constructor}
1430 %*                                                                      *
1431 %************************************************************************
1432
1433 We are a bit careful with occurrence info.  Here's an example
1434
1435         (\x* -> case x of (a*, b) -> f a) (h v, e)
1436
1437 where the * means "occurs once".  This effectively becomes
1438         case (h v, e) of (a*, b) -> f a)
1439 and then
1440         let a* = h v; b = e in f a
1441 and then
1442         f (h v)
1443
1444 All this should happen in one sweep.
1445
1446 \begin{code}
1447 knownCon :: SimplEnv -> AltCon -> [OutExpr]
1448          -> InId -> [InAlt] -> SimplCont
1449          -> SimplM FloatsWithExpr
1450
1451 knownCon env con args bndr alts cont
1452   = tick (KnownBranch bndr)     `thenSmpl_`
1453     case findAlt con alts of
1454         (DEFAULT, bs, rhs)     -> ASSERT( null bs )
1455                                   simplNonRecX env bndr scrut   $ \ env ->
1456                                         -- This might give rise to a binding with non-atomic args
1457                                         -- like x = Node (f x) (g x)
1458                                         -- but no harm will be done
1459                                   simplExprF env rhs cont
1460                                 where
1461                                   scrut = case con of
1462                                             LitAlt lit -> Lit lit
1463                                             DataAlt dc -> mkConApp dc args
1464
1465         (LitAlt lit, bs, rhs) ->  ASSERT( null bs )
1466                                   simplNonRecX env bndr (Lit lit)       $ \ env ->
1467                                   simplExprF env rhs cont
1468
1469         (DataAlt dc, bs, rhs)  -> ASSERT( length bs + n_tys == length args )
1470                                   bind_args env bs (drop n_tys args)    $ \ env ->
1471                                   let
1472                                     con_app  = mkConApp dc (take n_tys args ++ con_args)
1473                                     con_args = [substExpr (getSubst env) (varToCoreExpr b) | b <- bs]
1474                                         -- args are aready OutExprs, but bs are InIds
1475                                   in
1476                                   simplNonRecX env bndr con_app         $ \ env ->
1477                                   simplExprF env rhs cont
1478                                where
1479                                   n_tys = dataConNumInstArgs dc -- Non-existential type args
1480 -- Ugh!
1481 bind_args env [] _ thing_inside = thing_inside env
1482
1483 bind_args env (b:bs) (Type ty : args) thing_inside
1484   = bind_args (extendSubst env b (DoneTy ty)) bs args thing_inside
1485
1486 bind_args env (b:bs) (arg : args) thing_inside
1487   = simplNonRecX env b arg      $ \ env ->
1488     bind_args env bs args thing_inside
1489 \end{code}
1490
1491
1492 %************************************************************************
1493 %*                                                                      *
1494 \subsection{Duplicating continuations}
1495 %*                                                                      *
1496 %************************************************************************
1497
1498 \begin{code}
1499 prepareCaseCont :: SimplEnv
1500                 -> [InAlt] -> SimplCont
1501                 -> SimplM (FloatsWith SimplCont)        -- Return a duplicatable continuation,
1502                                                         -- plus some extra bindings
1503
1504 prepareCaseCont env [alt] cont = returnSmpl (emptyFloats env, cont)
1505         -- No need to make it duplicatable if there's only one alternative
1506
1507 prepareCaseCont env alts  cont = simplType env (coreAltsType alts)      `thenSmpl` \ alts_ty ->
1508                                  mkDupableCont env alts_ty cont
1509         -- At one time I passed in the un-simplified type, and simplified
1510         -- it only if we needed to construct a join binder, but that
1511         -- didn't work because we have to decompse function types
1512         -- (using funResultTy) in mkDupableCont.
1513 \end{code}
1514
1515 \begin{code}
1516 mkDupableCont :: SimplEnv
1517               -> OutType                -- Type of the thing to be given to the continuation
1518               -> SimplCont
1519               -> SimplM (FloatsWith SimplCont)  -- Return a duplicatable continuation,
1520                                                 -- plus some extra bindings
1521
1522 mkDupableCont env ty cont
1523   | contIsDupable cont
1524   = returnSmpl (emptyFloats env, cont)
1525
1526 mkDupableCont env _ (CoerceIt ty cont)
1527   = mkDupableCont env ty cont           `thenSmpl` \ (floats, cont') ->
1528     returnSmpl (floats, CoerceIt ty cont')
1529
1530 mkDupableCont env ty (InlinePlease cont)
1531   = mkDupableCont env ty cont           `thenSmpl` \ (floats, cont') ->
1532     returnSmpl (floats, InlinePlease cont')
1533
1534 mkDupableCont env join_arg_ty (ArgOf _ is_rhs cont_ty cont_fn)
1535   =     -- e.g.         (...strict-fn...) [...hole...]
1536         --      ==>
1537         --              let $j = \a -> ...strict-fn...
1538         --              in $j [...hole...]
1539
1540         -- Build the join Id and continuation
1541         -- We give it a "$j" name just so that for later amusement
1542         -- we can identify any join points that don't end up as let-no-escapes
1543         -- [NOTE: the type used to be exprType join_rhs, but this seems more elegant.]
1544     newId SLIT("$j") (mkFunTy join_arg_ty cont_ty)              `thenSmpl` \ join_id ->
1545     newId SLIT("a") join_arg_ty                                 `thenSmpl` \ arg_id ->
1546
1547     cont_fn (addNewInScopeIds env [arg_id]) (Var arg_id)        `thenSmpl` \ (floats, rhs) ->
1548     let
1549         cont_fn env arg' = rebuildDone env (App (Var join_id) arg')
1550         join_rhs         = Lam (setOneShotLambda arg_id) (wrapFloats floats rhs)
1551     in
1552
1553     tick (CaseOfCase join_id)                                           `thenSmpl_`
1554         -- Want to tick here so that we go round again,
1555         -- and maybe copy or inline the code;
1556         -- not strictly CaseOf Case
1557
1558     returnSmpl (unitFloat env join_id join_rhs,
1559                 ArgOf OkToDup is_rhs cont_ty cont_fn)
1560
1561 mkDupableCont env ty (ApplyTo _ arg se cont)
1562   =     -- e.g.         [...hole...] (...arg...)
1563         --      ==>
1564         --              let a = ...arg...
1565         --              in [...hole...] a
1566     mkDupableCont env (funResultTy ty) cont             `thenSmpl` \ (floats, cont') ->
1567     addFloats env floats                                $ \ env ->
1568
1569     simplExpr (setInScope se env) arg                   `thenSmpl` \ arg' ->
1570     if exprIsDupable arg' then
1571         returnSmpl (emptyFloats env, ApplyTo OkToDup arg' (zapSubstEnv se) cont')
1572     else
1573     newId SLIT("a") (exprType arg')                     `thenSmpl` \ arg_id ->
1574
1575     tick (CaseOfCase arg_id)                            `thenSmpl_`
1576         -- Want to tick here so that we go round again,
1577         -- and maybe copy or inline the code.
1578         -- Not strictly CaseOfCase, but never mind
1579
1580     returnSmpl (unitFloat env arg_id arg',
1581                 ApplyTo OkToDup (Var arg_id) (zapSubstEnv se) cont')
1582         -- But what if the arg should be case-bound?
1583         -- This has been this way for a long time, so I'll leave it,
1584         -- but I can't convince myself that it's right.
1585
1586
1587 mkDupableCont env ty (Select _ case_bndr alts se cont)
1588   =     -- e.g.         (case [...hole...] of { pi -> ei })
1589         --      ===>
1590         --              let ji = \xij -> ei
1591         --              in case [...hole...] of { pi -> ji xij }
1592     tick (CaseOfCase case_bndr)                                 `thenSmpl_`
1593     let
1594         alt_env = setInScope se env
1595     in
1596     prepareCaseCont alt_env alts cont                           `thenSmpl` \ (floats1, dupable_cont) ->
1597     addFloats alt_env floats1                                   $ \ alt_env ->
1598
1599     simplBinder alt_env case_bndr                               `thenSmpl` \ (alt_env, case_bndr') ->
1600         -- NB: simplBinder does not zap deadness occ-info, so
1601         -- a dead case_bndr' will still advertise its deadness
1602         -- This is really important because in
1603         --      case e of b { (# a,b #) -> ... }
1604         -- b is always dead, and indeed we are not allowed to bind b to (# a,b #),
1605         -- which might happen if e was an explicit unboxed pair and b wasn't marked dead.
1606         -- In the new alts we build, we have the new case binder, so it must retain
1607         -- its deadness.
1608
1609     mkDupableAlts alt_env case_bndr' alts dupable_cont  `thenSmpl` \ (floats2, alts') ->
1610     addFloats alt_env floats2                           $ \ alt_env ->
1611     returnSmpl (emptyFloats alt_env, Select OkToDup case_bndr' alts' (zapSubstEnv se)
1612                                             (mkBoringStop (contResultType cont)))
1613
1614 mkDupableAlts :: SimplEnv -> OutId -> [InAlt] -> SimplCont
1615               -> SimplM (FloatsWith [InAlt])
1616 -- Absorbs the continuation into the new alternatives
1617
1618 mkDupableAlts env case_bndr' alts dupable_cont
1619   = go env alts
1620   where
1621     go env [] = returnSmpl (emptyFloats env, [])
1622     go env (alt:alts)
1623         = mkDupableAlt env case_bndr' dupable_cont alt  `thenSmpl` \ (floats1, alt') ->
1624           addFloats env floats1                         $ \ env ->
1625           go env alts                                   `thenSmpl` \ (floats2, alts') ->
1626           returnSmpl (floats2, alt' : alts')
1627
1628 mkDupableAlt env case_bndr' cont alt@(con, bndrs, rhs)
1629   = simplBinders env bndrs                              `thenSmpl` \ (env, bndrs') ->
1630     simplExprC env rhs cont                             `thenSmpl` \ rhs' ->
1631
1632     if exprIsDupable rhs' then
1633         returnSmpl (emptyFloats env, (con, bndrs', rhs'))
1634         -- It is worth checking for a small RHS because otherwise we
1635         -- get extra let bindings that may cause an extra iteration of the simplifier to
1636         -- inline back in place.  Quite often the rhs is just a variable or constructor.
1637         -- The Ord instance of Maybe in PrelMaybe.lhs, for example, took several extra
1638         -- iterations because the version with the let bindings looked big, and so wasn't
1639         -- inlined, but after the join points had been inlined it looked smaller, and so
1640         -- was inlined.
1641         --
1642         -- NB: we have to check the size of rhs', not rhs.
1643         -- Duplicating a small InAlt might invalidate occurrence information
1644         -- However, if it *is* dupable, we return the *un* simplified alternative,
1645         -- because otherwise we'd need to pair it up with an empty subst-env....
1646         -- but we only have one env shared between all the alts.
1647         -- (Remember we must zap the subst-env before re-simplifying something).
1648         -- Rather than do this we simply agree to re-simplify the original (small) thing later.
1649
1650     else
1651     let
1652         rhs_ty'     = exprType rhs'
1653         used_bndrs' = filter (not . isDeadBinder) (case_bndr' : bndrs')
1654                 -- The deadness info on the new binders is unscathed
1655     in
1656         -- If we try to lift a primitive-typed something out
1657         -- for let-binding-purposes, we will *caseify* it (!),
1658         -- with potentially-disastrous strictness results.  So
1659         -- instead we turn it into a function: \v -> e
1660         -- where v::State# RealWorld#.  The value passed to this function
1661         -- is realworld#, which generates (almost) no code.
1662
1663         -- There's a slight infelicity here: we pass the overall
1664         -- case_bndr to all the join points if it's used in *any* RHS,
1665         -- because we don't know its usage in each RHS separately
1666
1667         -- We used to say "&& isUnLiftedType rhs_ty'" here, but now
1668         -- we make the join point into a function whenever used_bndrs'
1669         -- is empty.  This makes the join-point more CPR friendly.
1670         -- Consider:    let j = if .. then I# 3 else I# 4
1671         --              in case .. of { A -> j; B -> j; C -> ... }
1672         --
1673         -- Now CPR doesn't w/w j because it's a thunk, so
1674         -- that means that the enclosing function can't w/w either,
1675         -- which is a lose.  Here's the example that happened in practice:
1676         --      kgmod :: Int -> Int -> Int
1677         --      kgmod x y = if x > 0 && y < 0 || x < 0 && y > 0
1678         --                  then 78
1679         --                  else 5
1680         --
1681         -- I have seen a case alternative like this:
1682         --      True -> \v -> ...
1683         -- It's a bit silly to add the realWorld dummy arg in this case, making
1684         --      $j = \s v -> ...
1685         --         True -> $j s
1686         -- (the \v alone is enough to make CPR happy) but I think it's rare
1687
1688     ( if null used_bndrs'
1689         then newId SLIT("w") realWorldStatePrimTy       `thenSmpl` \ rw_id ->
1690              returnSmpl ([rw_id], [Var realWorldPrimId])
1691         else
1692              returnSmpl (used_bndrs', map varToCoreExpr used_bndrs')
1693     )                                                   `thenSmpl` \ (final_bndrs', final_args) ->
1694
1695         -- See comment about "$j" name above
1696     newId SLIT("$j") (foldr mkPiType rhs_ty' final_bndrs')      `thenSmpl` \ join_bndr ->
1697         -- Notice the funky mkPiType.  If the contructor has existentials
1698         -- it's possible that the join point will be abstracted over
1699         -- type varaibles as well as term variables.
1700         --  Example:  Suppose we have
1701         --      data T = forall t.  C [t]
1702         --  Then faced with
1703         --      case (case e of ...) of
1704         --          C t xs::[t] -> rhs
1705         --  We get the join point
1706         --      let j :: forall t. [t] -> ...
1707         --          j = /\t \xs::[t] -> rhs
1708         --      in
1709         --      case (case e of ...) of
1710         --          C t xs::[t] -> j t xs
1711     let
1712         -- We make the lambdas into one-shot-lambdas.  The
1713         -- join point is sure to be applied at most once, and doing so
1714         -- prevents the body of the join point being floated out by
1715         -- the full laziness pass
1716         really_final_bndrs     = map one_shot final_bndrs'
1717         one_shot v | isId v    = setOneShotLambda v
1718                    | otherwise = v
1719         join_rhs  = mkLams really_final_bndrs rhs'
1720         join_call = mkApps (Var join_bndr) final_args
1721     in
1722     returnSmpl (unitFloat env join_bndr join_rhs, (con, bndrs', join_call))
1723 \end{code}