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