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                 -- Don't fiddle with the IdInfo of a constructor
 569                 -- wrapper or other GlobalId.
 570         final_id | isLocalId new_bndr = new_bndr `setIdInfo` info_w_unf
 571                  | otherwise          = new_bndr
 572     in
 573                 -- These seqs forces the Id, and hence its IdInfo,
 574                 -- and hence any inner substitutions
 575     final_id                                    `seq`
 576     returnSmpl (unitFloat env final_id new_rhs, env)
 577
 578   where
 579     loop_breaker = isLoopBreaker occ_info
 580     old_info     = idInfo old_bndr
 581     occ_info     = occInfo old_info
 582 \end{code}
 583
 584
 585
 586 %************************************************************************
 587 %*                                                                      *
 588 \subsection[Simplify-simplExpr]{The main function: simplExpr}
 589 %*                                                                      *
 590 %************************************************************************
 591
 592 The reason for this OutExprStuff stuff is that we want to float *after*
 593 simplifying a RHS, not before.  If we do so naively we get quadratic
 594 behaviour as things float out.
 595
 596 To see why it's important to do it after, consider this (real) example:
 597
 598         let t = f x
 599         in fst t
 600 ==>
 601         let t = let a = e1
 602                     b = e2
 603                 in (a,b)
 604         in fst t
 605 ==>
 606         let a = e1
 607             b = e2
 608             t = (a,b)
 609         in
 610         a       -- Can't inline a this round, cos it appears twice
 611 ==>
 612         e1
 613
 614 Each of the ==> steps is a round of simplification.  We'd save a
 615 whole round if we float first.  This can cascade.  Consider
 616
 617         let f = g d
 618         in \x -> ...f...
 619 ==>
 620         let f = let d1 = ..d.. in \y -> e
 621         in \x -> ...f...
 622 ==>
 623         let d1 = ..d..
 624         in \x -> ...(\y ->e)...
 625
 626 Only in this second round can the \y be applied, and it
 627 might do the same again.
 628
 629
 630 \begin{code}
 631 simplExpr :: SimplEnv -> CoreExpr -> SimplM CoreExpr
 632 simplExpr env expr = simplExprC env expr (mkBoringStop expr_ty')
 633                    where
 634                      expr_ty' = substTy (getSubst env) (exprType expr)
 635         -- The type in the Stop continuation, expr_ty', is usually not used
 636         -- It's only needed when discarding continuations after finding
 637         -- a function that returns bottom.
 638         -- Hence the lazy substitution
 639
 640
 641 simplExprC :: SimplEnv -> CoreExpr -> SimplCont -> SimplM CoreExpr
 642         -- Simplify an expression, given a continuation
 643 simplExprC env expr cont
 644   = simplExprF env expr cont    `thenSmpl` \ (floats, expr) ->
 645     returnSmpl (wrapFloats floats expr)
 646
 647 simplExprF :: SimplEnv -> InExpr -> SimplCont -> SimplM FloatsWithExpr
 648         -- Simplify an expression, returning floated binds
 649
 650 simplExprF env (Var v)          cont = simplVar env v cont
 651 simplExprF env (Lit lit)        cont = rebuild env (Lit lit) cont
 652 simplExprF env expr@(Lam _ _)   cont = simplLam env expr cont
 653 simplExprF env (Note note expr) cont = simplNote env note expr cont
 654 simplExprF env (App fun arg)    cont = simplExprF env fun (ApplyTo NoDup arg env cont)
 655
 656 simplExprF env (Type ty) cont
 657   = ASSERT( contIsRhsOrArg cont )
 658     simplType env ty                    `thenSmpl` \ ty' ->
 659     rebuild env (Type ty') cont
 660
 661 simplExprF env (Case scrut bndr alts) cont
 662   | not (switchIsOn (getSwitchChecker env) NoCaseOfCase)
 663   =     -- Simplify the scrutinee with a Select continuation
 664     simplExprF env scrut (Select NoDup bndr alts env cont)
 665
 666   | otherwise
 667   =     -- If case-of-case is off, simply simplify the case expression
 668         -- in a vanilla Stop context, and rebuild the result around it
 669     simplExprC env scrut case_cont      `thenSmpl` \ case_expr' ->
 670     rebuild env case_expr' cont
 671   where
 672     case_cont = Select NoDup bndr alts env (mkBoringStop (contResultType cont))
 673
 674 simplExprF env (Let (Rec pairs) body) cont
 675   = simplRecBndrs env (map fst pairs)           `thenSmpl` \ (env, bndrs') ->
 676         -- NB: bndrs' don't have unfoldings or spec-envs
 677         -- We add them as we go down, using simplPrags
 678
 679     simplRecBind env NotTopLevel pairs bndrs'   `thenSmpl` \ (floats, env) ->
 680     addFloats env floats                        $ \ env ->
 681     simplExprF env body cont
 682
 683 -- A non-recursive let is dealt with by simplNonRecBind
 684 simplExprF env (Let (NonRec bndr rhs) body) cont
 685   = simplNonRecBind env bndr rhs env (contResultType cont)      $ \ env ->
 686     simplExprF env body cont
 687
 688
 689 ---------------------------------
 690 simplType :: SimplEnv -> InType -> SimplM OutType
 691         -- Kept monadic just so we can do the seqType
 692 simplType env ty
 693   = seqType new_ty   `seq`   returnSmpl new_ty
 694   where
 695     new_ty = substTy (getSubst env) ty
 696 \end{code}
 697
 698
 699 %************************************************************************
 700 %*                                                                      *
 701 \subsection{Lambdas}
 702 %*                                                                      *
 703 %************************************************************************
 704
 705 \begin{code}
 706 simplLam env fun cont
 707   = go env fun cont
 708   where
 709     zap_it  = mkLamBndrZapper fun (countArgs cont)
 710     cont_ty = contResultType cont
 711
 712         -- Type-beta reduction
 713     go env (Lam bndr body) (ApplyTo _ (Type ty_arg) arg_se body_cont)
 714       = ASSERT( isTyVar bndr )
 715         tick (BetaReduction bndr)                       `thenSmpl_`
 716         simplType (setInScope arg_se env) ty_arg        `thenSmpl` \ ty_arg' ->
 717         go (extendSubst env bndr (DoneTy ty_arg')) body body_cont
 718
 719         -- Ordinary beta reduction
 720     go env (Lam bndr body) cont@(ApplyTo _ arg arg_se body_cont)
 721       = tick (BetaReduction bndr)                               `thenSmpl_`
 722         simplNonRecBind env (zap_it bndr) arg arg_se cont_ty    $ \ env ->
 723         go env body body_cont
 724
 725         -- Not enough args, so there are real lambdas left to put in the result
 726     go env lam@(Lam _ _) cont
 727       = simplLamBndrs env bndrs         `thenSmpl` \ (env, bndrs') ->
 728         simplExpr env body              `thenSmpl` \ body' ->
 729         mkLam env bndrs' body' cont     `thenSmpl` \ (floats, new_lam) ->
 730         addFloats env floats            $ \ env ->
 731         rebuild env new_lam cont
 732       where
 733         (bndrs,body) = collectBinders lam
 734
 735         -- Exactly enough args
 736     go env expr cont = simplExprF env expr cont
 737
 738 mkLamBndrZapper :: CoreExpr     -- Function
 739                 -> Int          -- Number of args supplied, *including* type args
 740                 -> Id -> Id     -- Use this to zap the binders
 741 mkLamBndrZapper fun n_args
 742   | n_args >= n_params fun = \b -> b            -- Enough args
 743   | otherwise              = \b -> zapLamIdInfo b
 744   where
 745         -- NB: we count all the args incl type args
 746         -- so we must count all the binders (incl type lambdas)
 747     n_params (Note _ e) = n_params e
 748     n_params (Lam b e)  = 1 + n_params e
 749     n_params other      = 0::Int
 750 \end{code}
 751
 752
 753 %************************************************************************
 754 %*                                                                      *
 755 \subsection{Notes}
 756 %*                                                                      *
 757 %************************************************************************
 758
 759 \begin{code}
 760 simplNote env (Coerce to from) body cont
 761   = let
 762         in_scope = getInScope env
 763
 764         addCoerce s1 k1 (CoerceIt t1 cont)
 765                 --      coerce T1 S1 (coerce S1 K1 e)
 766                 -- ==>
 767                 --      e,                      if T1=K1
 768                 --      coerce T1 K1 e,         otherwise
 769                 --
 770                 -- For example, in the initial form of a worker
 771                 -- we may find  (coerce T (coerce S (\x.e))) y
 772                 -- and we'd like it to simplify to e[y/x] in one round
 773                 -- of simplification
 774           | t1 `eqType` k1  = cont              -- The coerces cancel out
 775           | otherwise       = CoerceIt t1 cont  -- They don't cancel, but
 776                                                 -- the inner one is redundant
 777
 778         addCoerce t1t2 s1s2 (ApplyTo dup arg arg_se cont)
 779           | Just (s1, s2) <- splitFunTy_maybe s1s2
 780                 --      (coerce (T1->T2) (S1->S2) F) E
 781                 -- ===>
 782                 --      coerce T2 S2 (F (coerce S1 T1 E))
 783                 --
 784                 -- t1t2 must be a function type, T1->T2
 785                 -- but s1s2 might conceivably not be
 786                 --
 787                 -- When we build the ApplyTo we can't mix the out-types
 788                 -- with the InExpr in the argument, so we simply substitute
 789                 -- to make it all consistent.  It's a bit messy.
 790                 -- But it isn't a common case.
 791           = let
 792                 (t1,t2) = splitFunTy t1t2
 793                 new_arg = mkCoerce s1 t1 (substExpr (mkSubst in_scope (getSubstEnv arg_se)) arg)
 794             in
 795             ApplyTo dup new_arg (zapSubstEnv env) (addCoerce t2 s2 cont)
 796
 797         addCoerce to' _ cont = CoerceIt to' cont
 798     in
 799     simplType env to            `thenSmpl` \ to' ->
 800     simplType env from          `thenSmpl` \ from' ->
 801     simplExprF env body (addCoerce to' from' cont)
 802
 803
 804 -- Hack: we only distinguish subsumed cost centre stacks for the purposes of
 805 -- inlining.  All other CCCSs are mapped to currentCCS.
 806 simplNote env (SCC cc) e cont
 807   = simplExpr (setEnclosingCC env currentCCS) e         `thenSmpl` \ e' ->
 808     rebuild env (mkSCC cc e') cont
 809
 810 simplNote env InlineCall e cont
 811   = simplExprF env e (InlinePlease cont)
 812
 813 -- See notes with SimplMonad.inlineMode
 814 simplNote env InlineMe e cont
 815   | contIsRhsOrArg cont         -- Totally boring continuation; see notes above
 816   =                             -- Don't inline inside an INLINE expression
 817     simplExpr (setMode inlineMode env )  e      `thenSmpl` \ e' ->
 818     rebuild env (mkInlineMe e') cont
 819
 820   | otherwise   -- Dissolve the InlineMe note if there's
 821                 -- an interesting context of any kind to combine with
 822                 -- (even a type application -- anything except Stop)
 823   = simplExprF env e cont
 824 \end{code}
 825
 826
 827 %************************************************************************
 828 %*                                                                      *
 829 \subsection{Dealing with calls}
 830 %*                                                                      *
 831 %************************************************************************
 832
 833 \begin{code}
 834 simplVar env var cont
 835   = case lookupIdSubst (getSubst env) var of
 836         DoneEx e        -> simplExprF (zapSubstEnv env) e cont
 837         ContEx se e     -> simplExprF (setSubstEnv env se) e cont
 838         DoneId var1 occ -> WARN( not (isInScope var1 (getSubst env)) && mustHaveLocalBinding var1,
 839                                  text "simplVar:" <+> ppr var )
 840                            completeCall (zapSubstEnv env) var1 occ cont
 841                 -- The template is already simplified, so don't re-substitute.
 842                 -- This is VITAL.  Consider
 843                 --      let x = e in
 844                 --      let y = \z -> ...x... in
 845                 --      \ x -> ...y...
 846                 -- We'll clone the inner \x, adding x->x' in the id_subst
 847                 -- Then when we inline y, we must *not* replace x by x' in
 848                 -- the inlined copy!!
 849
 850 ---------------------------------------------------------
 851 --      Dealing with a call site
 852
 853 completeCall env var occ_info cont
 854   =     -- Simplify the arguments
 855     getDOptsSmpl                                        `thenSmpl` \ dflags ->
 856     let
 857         chkr                           = getSwitchChecker env
 858         (args, call_cont, inline_call) = getContArgs chkr var cont
 859     in
 860     simplifyArgs env args (contResultType call_cont)    $ \ env args ->
 861
 862         -- Next, look for rules or specialisations that match
 863         --
 864         -- It's important to simplify the args first, because the rule-matcher
 865         -- doesn't do substitution as it goes.  We don't want to use subst_args
 866         -- (defined in the 'where') because that throws away useful occurrence info,
 867         -- and perhaps-very-important specialisations.
 868         --
 869         -- Some functions have specialisations *and* are strict; in this case,
 870         -- we don't want to inline the wrapper of the non-specialised thing; better
 871         -- to call the specialised thing instead.
 872         -- We used to use the black-listing mechanism to ensure that inlining of
 873         -- the wrapper didn't occur for things that have specialisations till a
 874         -- later phase, so but now we just try RULES first
 875         --
 876         -- You might think that we shouldn't apply rules for a loop breaker:
 877         -- doing so might give rise to an infinite loop, because a RULE is
 878         -- rather like an extra equation for the function:
 879         --      RULE:           f (g x) y = x+y
 880         --      Eqn:            f a     y = a-y
 881         --
 882         -- But it's too drastic to disable rules for loop breakers.
 883         -- Even the foldr/build rule would be disabled, because foldr
 884         -- is recursive, and hence a loop breaker:
 885         --      foldr k z (build g) = g k z
 886         -- So it's up to the programmer: rules can cause divergence
 887
 888     let
 889         in_scope   = getInScope env
 890         maybe_rule = case activeRule env of
 891                         Nothing     -> Nothing  -- No rules apply
 892                         Just act_fn -> lookupRule act_fn in_scope var args
 893     in
 894     case maybe_rule of {
 895         Just (rule_name, rule_rhs) ->
 896                 tick (RuleFired rule_name)                      `thenSmpl_`
 897                 (if dopt Opt_D_dump_inlinings dflags then
 898                    pprTrace "Rule fired" (vcat [
 899                         text "Rule:" <+> ptext rule_name,
 900                         text "Before:" <+> ppr var <+> sep (map pprParendExpr args),
 901                         text "After: " <+> pprCoreExpr rule_rhs])
 902                  else
 903                         id)             $
 904                 simplExprF env rule_rhs call_cont ;
 905
 906         Nothing ->              -- No rules
 907
 908         -- Next, look for an inlining
 909     let
 910         arg_infos = [ interestingArg arg | arg <- args, isValArg arg]
 911
 912         interesting_cont = interestingCallContext (not (null args))
 913                                                   (not (null arg_infos))
 914                                                   call_cont
 915
 916         active_inline = activeInline env var
 917         maybe_inline  = callSiteInline dflags active_inline inline_call occ_info
 918                                        var arg_infos interesting_cont
 919     in
 920     case maybe_inline of {
 921         Just unfolding          -- There is an inlining!
 922           ->  tick (UnfoldingDone var)          `thenSmpl_`
 923               makeThatCall env var unfolding args call_cont
 924
 925         ;
 926         Nothing ->              -- No inlining!
 927
 928         -- Done
 929     rebuild env (mkApps (Var var) args) call_cont
 930     }}
 931
 932 makeThatCall :: SimplEnv
 933              -> Id
 934              -> InExpr          -- Inlined function rhs
 935              -> [OutExpr]       -- Arguments, already simplified
 936              -> SimplCont       -- After the call
 937              -> SimplM FloatsWithExpr
 938 -- Similar to simplLam, but this time
 939 -- the arguments are already simplified
 940 makeThatCall orig_env var fun@(Lam _ _) args cont
 941   = go orig_env fun args
 942   where
 943     zap_it = mkLamBndrZapper fun (length args)
 944
 945         -- Type-beta reduction
 946     go env (Lam bndr body) (Type ty_arg : args)
 947       = ASSERT( isTyVar bndr )
 948         tick (BetaReduction bndr)                       `thenSmpl_`
 949         go (extendSubst env bndr (DoneTy ty_arg)) body args
 950
 951         -- Ordinary beta reduction
 952     go env (Lam bndr body) (arg : args)
 953       = tick (BetaReduction bndr)                       `thenSmpl_`
 954         simplNonRecX env (zap_it bndr) arg              $ \ env ->
 955         go env body args
 956
 957         -- Not enough args, so there are real lambdas left to put in the result
 958     go env fun args
 959       = simplExprF env fun (pushContArgs orig_env args cont)
 960         -- NB: orig_env; the correct environment to capture with
 961         -- the arguments.... env has been augmented with substitutions
 962         -- from the beta reductions.
 963
 964 makeThatCall env var fun args cont
 965   = simplExprF env fun (pushContArgs env args cont)
 966 \end{code}
 967
 968
 969 %************************************************************************
 970 %*                                                                      *
 971 \subsection{Arguments}
 972 %*                                                                      *
 973 %************************************************************************
 974
 975 \begin{code}
 976 ---------------------------------------------------------
 977 --      Simplifying the arguments of a call
 978
 979 simplifyArgs :: SimplEnv
 980              -> [(InExpr, SimplEnv, Bool)]      -- Details of the arguments
 981              -> OutType                         -- Type of the continuation
 982              -> (SimplEnv -> [OutExpr] -> SimplM FloatsWithExpr)
 983              -> SimplM FloatsWithExpr
 984
 985 -- [CPS-like because of strict arguments]
 986
 987 -- Simplify the arguments to a call.
 988 -- This part of the simplifier may break the no-shadowing invariant
 989 -- Consider
 990 --      f (...(\a -> e)...) (case y of (a,b) -> e')
 991 -- where f is strict in its second arg
 992 -- If we simplify the innermost one first we get (...(\a -> e)...)
 993 -- Simplifying the second arg makes us float the case out, so we end up with
 994 --      case y of (a,b) -> f (...(\a -> e)...) e'
 995 -- So the output does not have the no-shadowing invariant.  However, there is
 996 -- no danger of getting name-capture, because when the first arg was simplified
 997 -- we used an in-scope set that at least mentioned all the variables free in its
 998 -- static environment, and that is enough.
 999 --
1000 -- We can't just do innermost first, or we'd end up with a dual problem:
1001 --      case x of (a,b) -> f e (...(\a -> e')...)
1002 --
1003 -- I spent hours trying to recover the no-shadowing invariant, but I just could
1004 -- not think of an elegant way to do it.  The simplifier is already knee-deep in
1005 -- continuations.  We have to keep the right in-scope set around; AND we have
1006 -- to get the effect that finding (error "foo") in a strict arg position will
1007 -- discard the entire application and replace it with (error "foo").  Getting
1008 -- all this at once is TOO HARD!
1009
1010 simplifyArgs env args cont_ty thing_inside
1011   = go env args thing_inside
1012   where
1013     go env []         thing_inside = thing_inside env []
1014     go env (arg:args) thing_inside = simplifyArg env arg cont_ty        $ \ env arg' ->
1015                                      go env args                        $ \ env args' ->
1016                                      thing_inside env (arg':args')
1017
1018 simplifyArg env (Type ty_arg, se, _) cont_ty thing_inside
1019   = simplType (setInScope se env) ty_arg        `thenSmpl` \ new_ty_arg ->
1020     thing_inside env (Type new_ty_arg)
1021
1022 simplifyArg env (val_arg, arg_se, is_strict) cont_ty thing_inside
1023   | is_strict
1024   = simplStrictArg env AnArg val_arg arg_se cont_ty thing_inside
1025
1026   | otherwise
1027   = let
1028         arg_env = setInScope arg_se env
1029     in
1030     simplType arg_env (exprType val_arg)                `thenSmpl` \ arg_ty ->
1031     simplExprF arg_env val_arg (mkStop arg_ty AnArg)    `thenSmpl` \ (floats, arg1) ->
1032     addFloats env floats                                $ \ env ->
1033     thing_inside env arg1
1034
1035
1036 simplStrictArg :: SimplEnv              -- The env of the call
1037                 -> LetRhsFlag
1038                 -> InExpr -> SimplEnv   -- The arg plus its env
1039                 -> OutType              -- cont_ty: Type of thing computed by the context
1040                 -> (SimplEnv -> OutExpr -> SimplM FloatsWithExpr)
1041                                         -- Takes an expression of type rhs_ty,
1042                                         -- returns an expression of type cont_ty
1043                                         -- The env passed to this continuation is the
1044                                         -- env of the call, plus any new in-scope variables
1045                 -> SimplM FloatsWithExpr        -- An expression of type cont_ty
1046
1047 simplStrictArg call_env is_rhs arg arg_env cont_ty thing_inside
1048   = simplExprF (setInScope arg_env call_env) arg
1049                (ArgOf NoDup is_rhs cont_ty (\ new_env -> thing_inside (setInScope call_env new_env)))
1050   -- Notice the way we use arg_env (augmented with in-scope vars from call_env)
1051   --    to simplify the argument
1052   -- and call-env (augmented with in-scope vars from the arg) to pass to the continuation
1053 \end{code}
1054
1055
1056 %************************************************************************
1057 %*                                                                      *
1058 \subsection{mkAtomicArgs}
1059 %*                                                                      *
1060 %************************************************************************
1061
1062 mkAtomicArgs takes a putative RHS, checks whether it's a PAP or
1063 constructor application and, if so, converts it to ANF, so that the
1064 resulting thing can be inlined more easily.  Thus
1065         x = (f a, g b)
1066 becomes
1067         t1 = f a
1068         t2 = g b
1069         x = (t1,t2)
1070
1071 There are three sorts of binding context, specified by the two
1072 boolean arguments
1073
1074 Strict
1075    OK-unlifted
1076
1077 N  N    Top-level or recursive                  Only bind args of lifted type
1078
1079 N  Y    Non-top-level and non-recursive,        Bind args of lifted type, or
1080                 but lazy                        unlifted-and-ok-for-speculation
1081
1082 Y  Y    Non-top-level, non-recursive,           Bind all args
1083                  and strict (demanded)
1084
1085
1086 For example, given
1087
1088         x = MkC (y div# z)
1089
1090 there is no point in transforming to
1091
1092         x = case (y div# z) of r -> MkC r
1093
1094 because the (y div# z) can't float out of the let. But if it was
1095 a *strict* let, then it would be a good thing to do.  Hence the
1096 context information.
1097
1098 \begin{code}
1099 mkAtomicArgs :: Bool    -- A strict binding
1100              -> Bool    -- OK to float unlifted args
1101              -> OutExpr
1102              -> SimplM ([(OutId,OutExpr)],      -- The floats (unusually) may include
1103                         OutExpr)                -- things that need case-binding,
1104                                                 -- if the strict-binding flag is on
1105
1106 mkAtomicArgs is_strict ok_float_unlifted rhs
1107   = mk_atomic_args rhs          `thenSmpl` \ maybe_stuff ->
1108     case maybe_stuff of
1109         Nothing               -> returnSmpl ([],              rhs)
1110         Just (ol_binds, rhs') -> returnSmpl (fromOL ol_binds, rhs')
1111
1112   where
1113     mk_atomic_args :: OutExpr -> SimplM (Maybe (OrdList (Id,OutExpr), OutExpr))
1114         -- Nothing => no change
1115     mk_atomic_args rhs
1116       | (Var fun, args) <- collectArgs rhs,                     -- It's an application
1117         isDataConId fun || valArgCount args < idArity fun       -- And it's a constructor or PAP
1118       =         -- Worth a try
1119         go nilOL [] args        `thenSmpl` \ maybe_stuff ->
1120         case maybe_stuff of
1121           Nothing                 -> returnSmpl Nothing
1122           Just (aux_binds, args') -> returnSmpl (Just (aux_binds, mkApps (Var fun) args'))
1123
1124      | otherwise
1125      = returnSmpl Nothing
1126
1127     go binds rev_args []
1128         = returnSmpl (Just (binds, reverse rev_args))
1129     go binds rev_args (arg : args)
1130         |  exprIsTrivial arg    -- Easy case
1131         = go binds (arg:rev_args) args
1132
1133         | not can_float_arg     -- Can't make this arg atomic
1134         = returnSmpl Nothing    -- ... so give up
1135
1136         | otherwise     -- Don't forget to do it recursively
1137                         -- E.g.  x = a:b:c:[]
1138         =  mk_atomic_args arg                                   `thenSmpl` \ maybe_anf ->
1139            case maybe_anf of {
1140              Nothing -> returnSmpl Nothing ;
1141              Just (arg_binds,arg') ->
1142
1143            newId SLIT("a") arg_ty                               `thenSmpl` \ arg_id ->
1144            go ((arg_binds `snocOL` (arg_id,arg')) `appOL` binds)
1145               (Var arg_id : rev_args) args
1146            }
1147         where
1148           arg_ty        = exprType arg
1149           can_float_arg =  is_strict
1150                         || not (isUnLiftedType arg_ty)
1151                         || (ok_float_unlifted && exprOkForSpeculation arg)
1152
1153 addAtomicBinds :: SimplEnv -> [(OutId,OutExpr)]
1154                -> (SimplEnv -> SimplM (FloatsWith a))
1155                -> SimplM (FloatsWith a)
1156 addAtomicBinds env []         thing_inside = thing_inside env
1157 addAtomicBinds env ((v,r):bs) thing_inside = addAuxiliaryBind env (NonRec v r) $ \ env ->
1158                                              addAtomicBinds env bs thing_inside
1159
1160 addAtomicBindsE :: SimplEnv -> [(OutId,OutExpr)]
1161                 -> (SimplEnv -> SimplM FloatsWithExpr)
1162                 -> SimplM FloatsWithExpr
1163 -- Same again, but this time we're in an expression context,
1164 -- and may need to do some case bindings
1165
1166 addAtomicBindsE env [] thing_inside
1167   = thing_inside env
1168 addAtomicBindsE env ((v,r):bs) thing_inside
1169   | needsCaseBinding (idType v) r
1170   = addAtomicBindsE (addNewInScopeIds env [v]) bs thing_inside  `thenSmpl` \ (floats, expr) ->
1171     WARN( exprIsTrivial expr, ppr v <+> pprCoreExpr expr )
1172     returnSmpl (emptyFloats env, Case r v [(DEFAULT,[], wrapFloats floats expr)])
1173
1174   | otherwise
1175   = addAuxiliaryBind env (NonRec v r)   $ \ env ->
1176     addAtomicBindsE env bs thing_inside
1177 \end{code}
1178
1179
1180 %************************************************************************
1181 %*                                                                      *
1182 \subsection{The main rebuilder}
1183 %*                                                                      *
1184 %************************************************************************
1185
1186 \begin{code}
1187 rebuild :: SimplEnv -> OutExpr -> SimplCont -> SimplM FloatsWithExpr
1188
1189 rebuild env expr (Stop _ _ _)                 = rebuildDone env expr
1190 rebuild env expr (ArgOf _ _ _ cont_fn)        = cont_fn env expr
1191 rebuild env expr (CoerceIt to_ty cont)        = rebuild env (mkCoerce to_ty (exprType expr) expr) cont
1192 rebuild env expr (InlinePlease cont)          = rebuild env (Note InlineCall expr) cont
1193 rebuild env expr (Select _ bndr alts se cont) = rebuildCase (setInScope se env) expr bndr alts cont
1194 rebuild env expr (ApplyTo _ arg se cont)      = rebuildApp  (setInScope se env) expr arg cont
1195
1196 rebuildApp env fun arg cont
1197   = simplExpr env arg   `thenSmpl` \ arg' ->
1198     rebuild env (App fun arg') cont
1199
1200 rebuildDone env expr = returnSmpl (emptyFloats env, expr)
1201 \end{code}
1202
1203
1204 %************************************************************************
1205 %*                                                                      *
1206 \subsection{Functions dealing with a case}
1207 %*                                                                      *
1208 %************************************************************************
1209
1210 Blob of helper functions for the "case-of-something-else" situation.
1211
1212 \begin{code}
1213 ---------------------------------------------------------
1214 --      Eliminate the case if possible
1215
1216 rebuildCase :: SimplEnv
1217             -> OutExpr          -- Scrutinee
1218             -> InId             -- Case binder
1219             -> [InAlt]          -- Alternatives
1220             -> SimplCont
1221             -> SimplM FloatsWithExpr
1222
1223 rebuildCase env scrut case_bndr alts cont
1224   | Just (con,args) <- exprIsConApp_maybe scrut
1225         -- Works when the scrutinee is a variable with a known unfolding
1226         -- as well as when it's an explicit constructor application
1227   = knownCon env (DataAlt con) args case_bndr alts cont
1228
1229   | Lit lit <- scrut    -- No need for same treatment as constructors
1230                         -- because literals are inlined more vigorously
1231   = knownCon env (LitAlt lit) [] case_bndr alts cont
1232
1233   | otherwise
1234   =     -- Prepare case alternatives
1235         -- Filter out alternatives that can't possibly match
1236     let
1237         impossible_cons = case scrut of
1238                             Var v -> otherCons (idUnfolding v)
1239                             other -> []
1240         better_alts = case impossible_cons of
1241                         []    -> alts
1242                         other -> [alt | alt@(con,_,_) <- alts,
1243                                         not (con `elem` impossible_cons)]
1244     in
1245
1246         -- Deal with the case binder, and prepare the continuation;
1247         -- The new subst_env is in place
1248     prepareCaseCont env better_alts cont                `thenSmpl` \ (floats, cont') ->
1249     addFloats env floats                                $ \ env ->
1250
1251         -- Deal with variable scrutinee
1252     simplCaseBinder env scrut case_bndr                 `thenSmpl` \ (alt_env, case_bndr', zap_occ_info) ->
1253
1254         -- Deal with the case alternatives
1255     simplAlts alt_env zap_occ_info impossible_cons
1256               case_bndr' better_alts cont'              `thenSmpl` \ alts' ->
1257
1258         -- Put the case back together
1259     mkCase scrut case_bndr' alts'                       `thenSmpl` \ case_expr ->
1260
1261         -- Notice that rebuildDone returns the in-scope set from env, not alt_env
1262         -- The case binder *not* scope over the whole returned case-expression
1263     rebuildDone env case_expr
1264 \end{code}
1265
1266 simplCaseBinder checks whether the scrutinee is a variable, v.  If so,
1267 try to eliminate uses of v in the RHSs in favour of case_bndr; that
1268 way, there's a chance that v will now only be used once, and hence
1269 inlined.
1270
1271 Note 1
1272 ~~~~~~
1273 There is a time we *don't* want to do that, namely when
1274 -fno-case-of-case is on.  This happens in the first simplifier pass,
1275 and enhances full laziness.  Here's the bad case:
1276         f = \ y -> ...(case x of I# v -> ...(case x of ...) ... )
1277 If we eliminate the inner case, we trap it inside the I# v -> arm,
1278 which might prevent some full laziness happening.  I've seen this
1279 in action in spectral/cichelli/Prog.hs:
1280          [(m,n) | m <- [1..max], n <- [1..max]]
1281 Hence the check for NoCaseOfCase.
1282
1283 Note 2
1284 ~~~~~~
1285 There is another situation when we don't want to do it.  If we have
1286
1287     case x of w1 { DEFAULT -> case x of w2 { A -> e1; B -> e2 }
1288                    ...other cases .... }
1289
1290 We'll perform the binder-swap for the outer case, giving
1291
1292     case x of w1 { DEFAULT -> case w1 of w2 { A -> e1; B -> e2 }
1293                    ...other cases .... }
1294
1295 But there is no point in doing it for the inner case,
1296 because w1 can't be inlined anyway.   Furthermore, doing the case-swapping
1297 involves zapping w2's occurrence info (see paragraphs that follow),
1298 and that forces us to bind w2 when doing case merging.  So we get
1299
1300     case x of w1 { A -> let w2 = w1 in e1
1301                    B -> let w2 = w1 in e2
1302                    ...other cases .... }
1303
1304 This is plain silly in the common case where w2 is dead.
1305
1306 Even so, I can't see a good way to implement this idea.  I tried
1307 not doing the binder-swap if the scrutinee was already evaluated
1308 but that failed big-time:
1309
1310         data T = MkT !Int
1311
1312         case v of w  { MkT x ->
1313         case x of x1 { I# y1 ->
1314         case x of x2 { I# y2 -> ...
1315
1316 Notice that because MkT is strict, x is marked "evaluated".  But to
1317 eliminate the last case, we must either make sure that x (as well as
1318 x1) has unfolding MkT y1.  THe straightforward thing to do is to do
1319 the binder-swap.  So this whole note is a no-op.
1320
1321 Note 3
1322 ~~~~~~
1323 If we replace the scrutinee, v, by tbe case binder, then we have to nuke
1324 any occurrence info (eg IAmDead) in the case binder, because the
1325 case-binder now effectively occurs whenever v does.  AND we have to do
1326 the same for the pattern-bound variables!  Example:
1327
1328         (case x of { (a,b) -> a }) (case x of { (p,q) -> q })
1329
1330 Here, b and p are dead.  But when we move the argment inside the first
1331 case RHS, and eliminate the second case, we get
1332
1333         case x or { (a,b) -> a b }
1334
1335 Urk! b is alive!  Reason: the scrutinee was a variable, and case elimination
1336 happened.  Hence the zap_occ_info function returned by simplCaseBinder
1337
1338 \begin{code}
1339 simplCaseBinder env (Var v) case_bndr
1340   | not (switchIsOn (getSwitchChecker env) NoCaseOfCase)
1341
1342 -- Failed try [see Note 2 above]
1343 --     not (isEvaldUnfolding (idUnfolding v))
1344
1345   = simplBinder env (zap case_bndr)             `thenSmpl` \ (env, case_bndr') ->
1346     returnSmpl (modifyInScope env v case_bndr', case_bndr', zap)
1347         -- We could extend the substitution instead, but it would be
1348         -- a hack because then the substitution wouldn't be idempotent
1349         -- any more (v is an OutId).  And this just just as well.
1350   where
1351     zap b = b `setIdOccInfo` NoOccInfo
1352
1353 simplCaseBinder env other_scrut case_bndr
1354   = simplBinder env case_bndr           `thenSmpl` \ (env, case_bndr') ->
1355     returnSmpl (env, case_bndr', \ bndr -> bndr)        -- NoOp on bndr
1356 \end{code}
1357
1358
1359
1360 \begin{code}
1361 simplAlts :: SimplEnv
1362           -> (InId -> InId)             -- Occ-info zapper
1363           -> [AltCon]                   -- Alternatives the scrutinee can't be
1364           -> OutId                      -- Case binder
1365           -> [InAlt] -> SimplCont
1366           -> SimplM [OutAlt]            -- Includes the continuation
1367
1368 simplAlts env zap_occ_info impossible_cons case_bndr' alts cont'
1369   = mapSmpl simpl_alt alts
1370   where
1371     inst_tys' = tyConAppArgs (idType case_bndr')
1372
1373         -- handled_cons is all the constructors that are dealt
1374         -- with, either by being impossible, or by there being an alternative
1375     (con_alts,_) = findDefault alts
1376     handled_cons = impossible_cons ++ [con | (con,_,_) <- con_alts]
1377
1378     simpl_alt (DEFAULT, _, rhs)
1379         = let
1380                 -- In the default case we record the constructors that the
1381                 -- case-binder *can't* be.
1382                 -- We take advantage of any OtherCon info in the case scrutinee
1383                 case_bndr_w_unf = case_bndr' `setIdUnfolding` mkOtherCon handled_cons
1384                 env_with_unf    = modifyInScope env case_bndr' case_bndr_w_unf
1385           in
1386           simplExprC env_with_unf rhs cont'     `thenSmpl` \ rhs' ->
1387           returnSmpl (DEFAULT, [], rhs')
1388
1389     simpl_alt (con, vs, rhs)
1390         =       -- Deal with the pattern-bound variables
1391                 -- Mark the ones that are in ! positions in the data constructor
1392                 -- as certainly-evaluated.
1393                 -- NB: it happens that simplBinders does *not* erase the OtherCon
1394                 --     form of unfolding, so it's ok to add this info before
1395                 --     doing simplBinders
1396           simplBinders env (add_evals con vs)           `thenSmpl` \ (env, vs') ->
1397
1398                 -- Bind the case-binder to (con args)
1399           let
1400                 unfolding    = mkUnfolding False (mkAltExpr con vs' inst_tys')
1401                 env_with_unf = modifyInScope env case_bndr' (case_bndr' `setIdUnfolding` unfolding)
1402           in
1403           simplExprC env_with_unf rhs cont'             `thenSmpl` \ rhs' ->
1404           returnSmpl (con, vs', rhs')
1405
1406
1407         -- add_evals records the evaluated-ness of the bound variables of
1408         -- a case pattern.  This is *important*.  Consider
1409         --      data T = T !Int !Int
1410         --
1411         --      case x of { T a b -> T (a+1) b }
1412         --
1413         -- We really must record that b is already evaluated so that we don't
1414         -- go and re-evaluate it when constructing the result.
1415
1416     add_evals (DataAlt dc) vs = cat_evals vs (dataConRepStrictness dc)
1417     add_evals other_con    vs = vs
1418
1419     cat_evals [] [] = []
1420     cat_evals (v:vs) (str:strs)
1421         | isTyVar v          = v        : cat_evals vs (str:strs)
1422         | isMarkedStrict str = evald_v  : cat_evals vs strs
1423         | otherwise          = zapped_v : cat_evals vs strs
1424         where
1425           zapped_v = zap_occ_info v
1426           evald_v  = zapped_v `setIdUnfolding` mkOtherCon []
1427 \end{code}
1428
1429
1430 %************************************************************************
1431 %*                                                                      *
1432 \subsection{Known constructor}
1433 %*                                                                      *
1434 %************************************************************************
1435
1436 We are a bit careful with occurrence info.  Here's an example
1437
1438         (\x* -> case x of (a*, b) -> f a) (h v, e)
1439
1440 where the * means "occurs once".  This effectively becomes
1441         case (h v, e) of (a*, b) -> f a)
1442 and then
1443         let a* = h v; b = e in f a
1444 and then
1445         f (h v)
1446
1447 All this should happen in one sweep.
1448
1449 \begin{code}
1450 knownCon :: SimplEnv -> AltCon -> [OutExpr]
1451          -> InId -> [InAlt] -> SimplCont
1452          -> SimplM FloatsWithExpr
1453
1454 knownCon env con args bndr alts cont
1455   = tick (KnownBranch bndr)     `thenSmpl_`
1456     case findAlt con alts of
1457         (DEFAULT, bs, rhs)     -> ASSERT( null bs )
1458                                   simplNonRecX env bndr scrut   $ \ env ->
1459                                         -- This might give rise to a binding with non-atomic args
1460                                         -- like x = Node (f x) (g x)
1461                                         -- but no harm will be done
1462                                   simplExprF env rhs cont
1463                                 where
1464                                   scrut = case con of
1465                                             LitAlt lit -> Lit lit
1466                                             DataAlt dc -> mkConApp dc args
1467
1468         (LitAlt lit, bs, rhs) ->  ASSERT( null bs )
1469                                   simplNonRecX env bndr (Lit lit)       $ \ env ->
1470                                   simplExprF env rhs cont
1471
1472         (DataAlt dc, bs, rhs)  -> ASSERT( length bs + n_tys == length args )
1473                                   bind_args env bs (drop n_tys args)    $ \ env ->
1474                                   let
1475                                     con_app  = mkConApp dc (take n_tys args ++ con_args)
1476                                     con_args = [substExpr (getSubst env) (varToCoreExpr b) | b <- bs]
1477                                         -- args are aready OutExprs, but bs are InIds
1478                                   in
1479                                   simplNonRecX env bndr con_app         $ \ env ->
1480                                   simplExprF env rhs cont
1481                                where
1482                                   n_tys = dataConNumInstArgs dc -- Non-existential type args
1483 -- Ugh!
1484 bind_args env [] _ thing_inside = thing_inside env
1485
1486 bind_args env (b:bs) (Type ty : args) thing_inside
1487   = bind_args (extendSubst env b (DoneTy ty)) bs args thing_inside
1488
1489 bind_args env (b:bs) (arg : args) thing_inside
1490   = simplNonRecX env b arg      $ \ env ->
1491     bind_args env bs args thing_inside
1492 \end{code}
1493
1494
1495 %************************************************************************
1496 %*                                                                      *
1497 \subsection{Duplicating continuations}
1498 %*                                                                      *
1499 %************************************************************************
1500
1501 \begin{code}
1502 prepareCaseCont :: SimplEnv
1503                 -> [InAlt] -> SimplCont
1504                 -> SimplM (FloatsWith SimplCont)        -- Return a duplicatable continuation,
1505                                                         -- plus some extra bindings
1506
1507 prepareCaseCont env [alt] cont = returnSmpl (emptyFloats env, cont)
1508         -- No need to make it duplicatable if there's only one alternative
1509
1510 prepareCaseCont env alts  cont = simplType env (coreAltsType alts)      `thenSmpl` \ alts_ty ->
1511                                  mkDupableCont env alts_ty cont
1512         -- At one time I passed in the un-simplified type, and simplified
1513         -- it only if we needed to construct a join binder, but that
1514         -- didn't work because we have to decompse function types
1515         -- (using funResultTy) in mkDupableCont.
1516 \end{code}
1517
1518 \begin{code}
1519 mkDupableCont :: SimplEnv
1520               -> OutType                -- Type of the thing to be given to the continuation
1521               -> SimplCont
1522               -> SimplM (FloatsWith SimplCont)  -- Return a duplicatable continuation,
1523                                                 -- plus some extra bindings
1524
1525 mkDupableCont env ty cont
1526   | contIsDupable cont
1527   = returnSmpl (emptyFloats env, cont)
1528
1529 mkDupableCont env _ (CoerceIt ty cont)
1530   = mkDupableCont env ty cont           `thenSmpl` \ (floats, cont') ->
1531     returnSmpl (floats, CoerceIt ty cont')
1532
1533 mkDupableCont env ty (InlinePlease cont)
1534   = mkDupableCont env ty cont           `thenSmpl` \ (floats, cont') ->
1535     returnSmpl (floats, InlinePlease cont')
1536
1537 mkDupableCont env join_arg_ty (ArgOf _ is_rhs cont_ty cont_fn)
1538   =     -- e.g.         (...strict-fn...) [...hole...]
1539         --      ==>
1540         --              let $j = \a -> ...strict-fn...
1541         --              in $j [...hole...]
1542
1543         -- Build the join Id and continuation
1544         -- We give it a "$j" name just so that for later amusement
1545         -- we can identify any join points that don't end up as let-no-escapes
1546         -- [NOTE: the type used to be exprType join_rhs, but this seems more elegant.]
1547     newId SLIT("$j") (mkFunTy join_arg_ty cont_ty)              `thenSmpl` \ join_id ->
1548     newId SLIT("a") join_arg_ty                                 `thenSmpl` \ arg_id ->
1549
1550     cont_fn (addNewInScopeIds env [arg_id]) (Var arg_id)        `thenSmpl` \ (floats, rhs) ->
1551     let
1552         cont_fn env arg' = rebuildDone env (App (Var join_id) arg')
1553         join_rhs         = Lam (setOneShotLambda arg_id) (wrapFloats floats rhs)
1554     in
1555
1556     tick (CaseOfCase join_id)                                           `thenSmpl_`
1557         -- Want to tick here so that we go round again,
1558         -- and maybe copy or inline the code;
1559         -- not strictly CaseOf Case
1560
1561     returnSmpl (unitFloat env join_id join_rhs,
1562                 ArgOf OkToDup is_rhs cont_ty cont_fn)
1563
1564 mkDupableCont env ty (ApplyTo _ arg se cont)
1565   =     -- e.g.         [...hole...] (...arg...)
1566         --      ==>
1567         --              let a = ...arg...
1568         --              in [...hole...] a
1569     mkDupableCont env (funResultTy ty) cont             `thenSmpl` \ (floats, cont') ->
1570     addFloats env floats                                $ \ env ->
1571
1572     simplExpr (setInScope se env) arg                   `thenSmpl` \ arg' ->
1573     if exprIsDupable arg' then
1574         returnSmpl (emptyFloats env, ApplyTo OkToDup arg' (zapSubstEnv se) cont')
1575     else
1576     newId SLIT("a") (exprType arg')                     `thenSmpl` \ arg_id ->
1577
1578     tick (CaseOfCase arg_id)                            `thenSmpl_`
1579         -- Want to tick here so that we go round again,
1580         -- and maybe copy or inline the code.
1581         -- Not strictly CaseOfCase, but never mind
1582
1583     returnSmpl (unitFloat env arg_id arg',
1584                 ApplyTo OkToDup (Var arg_id) (zapSubstEnv se) cont')
1585         -- But what if the arg should be case-bound?
1586         -- This has been this way for a long time, so I'll leave it,
1587         -- but I can't convince myself that it's right.
1588
1589
1590 mkDupableCont env ty (Select _ case_bndr alts se cont)
1591   =     -- e.g.         (case [...hole...] of { pi -> ei })
1592         --      ===>
1593         --              let ji = \xij -> ei
1594         --              in case [...hole...] of { pi -> ji xij }
1595     tick (CaseOfCase case_bndr)                                 `thenSmpl_`
1596     let
1597         alt_env = setInScope se env
1598     in
1599     prepareCaseCont alt_env alts cont                           `thenSmpl` \ (floats1, dupable_cont) ->
1600     addFloats alt_env floats1                                   $ \ alt_env ->
1601
1602     simplBinder alt_env case_bndr                               `thenSmpl` \ (alt_env, case_bndr') ->
1603         -- NB: simplBinder does not zap deadness occ-info, so
1604         -- a dead case_bndr' will still advertise its deadness
1605         -- This is really important because in
1606         --      case e of b { (# a,b #) -> ... }
1607         -- b is always dead, and indeed we are not allowed to bind b to (# a,b #),
1608         -- which might happen if e was an explicit unboxed pair and b wasn't marked dead.
1609         -- In the new alts we build, we have the new case binder, so it must retain
1610         -- its deadness.
1611
1612     mkDupableAlts alt_env case_bndr' alts dupable_cont  `thenSmpl` \ (floats2, alts') ->
1613     addFloats alt_env floats2                           $ \ alt_env ->
1614     returnSmpl (emptyFloats alt_env, Select OkToDup case_bndr' alts' (zapSubstEnv se)
1615                                             (mkBoringStop (contResultType cont)))
1616
1617 mkDupableAlts :: SimplEnv -> OutId -> [InAlt] -> SimplCont
1618               -> SimplM (FloatsWith [InAlt])
1619 -- Absorbs the continuation into the new alternatives
1620
1621 mkDupableAlts env case_bndr' alts dupable_cont
1622   = go env alts
1623   where
1624     go env [] = returnSmpl (emptyFloats env, [])
1625     go env (alt:alts)
1626         = mkDupableAlt env case_bndr' dupable_cont alt  `thenSmpl` \ (floats1, alt') ->
1627           addFloats env floats1                         $ \ env ->
1628           go env alts                                   `thenSmpl` \ (floats2, alts') ->
1629           returnSmpl (floats2, alt' : alts')
1630
1631 mkDupableAlt env case_bndr' cont alt@(con, bndrs, rhs)
1632   = simplBinders env bndrs                              `thenSmpl` \ (env, bndrs') ->
1633     simplExprC env rhs cont                             `thenSmpl` \ rhs' ->
1634
1635     if exprIsDupable rhs' then
1636         returnSmpl (emptyFloats env, (con, bndrs', rhs'))
1637         -- It is worth checking for a small RHS because otherwise we
1638         -- get extra let bindings that may cause an extra iteration of the simplifier to
1639         -- inline back in place.  Quite often the rhs is just a variable or constructor.
1640         -- The Ord instance of Maybe in PrelMaybe.lhs, for example, took several extra
1641         -- iterations because the version with the let bindings looked big, and so wasn't
1642         -- inlined, but after the join points had been inlined it looked smaller, and so
1643         -- was inlined.
1644         --
1645         -- NB: we have to check the size of rhs', not rhs.
1646         -- Duplicating a small InAlt might invalidate occurrence information
1647         -- However, if it *is* dupable, we return the *un* simplified alternative,
1648         -- because otherwise we'd need to pair it up with an empty subst-env....
1649         -- but we only have one env shared between all the alts.
1650         -- (Remember we must zap the subst-env before re-simplifying something).
1651         -- Rather than do this we simply agree to re-simplify the original (small) thing later.
1652
1653     else
1654     let
1655         rhs_ty'     = exprType rhs'
1656         used_bndrs' = filter (not . isDeadBinder) (case_bndr' : bndrs')
1657                 -- The deadness info on the new binders is unscathed
1658     in
1659         -- If we try to lift a primitive-typed something out
1660         -- for let-binding-purposes, we will *caseify* it (!),
1661         -- with potentially-disastrous strictness results.  So
1662         -- instead we turn it into a function: \v -> e
1663         -- where v::State# RealWorld#.  The value passed to this function
1664         -- is realworld#, which generates (almost) no code.
1665
1666         -- There's a slight infelicity here: we pass the overall
1667         -- case_bndr to all the join points if it's used in *any* RHS,
1668         -- because we don't know its usage in each RHS separately
1669
1670         -- We used to say "&& isUnLiftedType rhs_ty'" here, but now
1671         -- we make the join point into a function whenever used_bndrs'
1672         -- is empty.  This makes the join-point more CPR friendly.
1673         -- Consider:    let j = if .. then I# 3 else I# 4
1674         --              in case .. of { A -> j; B -> j; C -> ... }
1675         --
1676         -- Now CPR doesn't w/w j because it's a thunk, so
1677         -- that means that the enclosing function can't w/w either,
1678         -- which is a lose.  Here's the example that happened in practice:
1679         --      kgmod :: Int -> Int -> Int
1680         --      kgmod x y = if x > 0 && y < 0 || x < 0 && y > 0
1681         --                  then 78
1682         --                  else 5
1683         --
1684         -- I have seen a case alternative like this:
1685         --      True -> \v -> ...
1686         -- It's a bit silly to add the realWorld dummy arg in this case, making
1687         --      $j = \s v -> ...
1688         --         True -> $j s
1689         -- (the \v alone is enough to make CPR happy) but I think it's rare
1690
1691     ( if null used_bndrs'
1692         then newId SLIT("w") realWorldStatePrimTy       `thenSmpl` \ rw_id ->
1693              returnSmpl ([rw_id], [Var realWorldPrimId])
1694         else
1695              returnSmpl (used_bndrs', map varToCoreExpr used_bndrs')
1696     )                                                   `thenSmpl` \ (final_bndrs', final_args) ->
1697
1698         -- See comment about "$j" name above
1699     newId SLIT("$j") (foldr mkPiType rhs_ty' final_bndrs')      `thenSmpl` \ join_bndr ->
1700         -- Notice the funky mkPiType.  If the contructor has existentials
1701         -- it's possible that the join point will be abstracted over
1702         -- type varaibles as well as term variables.
1703         --  Example:  Suppose we have
1704         --      data T = forall t.  C [t]
1705         --  Then faced with
1706         --      case (case e of ...) of
1707         --          C t xs::[t] -> rhs
1708         --  We get the join point
1709         --      let j :: forall t. [t] -> ...
1710         --          j = /\t \xs::[t] -> rhs
1711         --      in
1712         --      case (case e of ...) of
1713         --          C t xs::[t] -> j t xs
1714     let
1715         -- We make the lambdas into one-shot-lambdas.  The
1716         -- join point is sure to be applied at most once, and doing so
1717         -- prevents the body of the join point being floated out by
1718         -- the full laziness pass
1719         really_final_bndrs     = map one_shot final_bndrs'
1720         one_shot v | isId v    = setOneShotLambda v
1721                    | otherwise = v
1722         join_rhs  = mkLams really_final_bndrs rhs'
1723         join_call = mkApps (Var join_bndr) final_args
1724     in
1725     returnSmpl (unitFloat env join_bndr join_rhs, (con, bndrs', join_call))
1726 \end{code}