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 ( simplBind ) where
   8
   9 #include "HsVersions.h"
  10
  11 import CmdLineOpts      ( switchIsOn, opt_SccProfilingOn, opt_PprStyle_Debug,
  12                           opt_NoPreInlining, opt_DictsStrict, opt_D_dump_inlinings,
  13                           SimplifierSwitch(..)
  14                         )
  15 import SimplMonad
  16 import SimplUtils       ( mkCase, etaCoreExpr, etaExpandCount, findAlt, mkRhsTyLam,
  17                           simplBinder, simplBinders, simplIds, findDefault
  18                         )
  19 import Var              ( TyVar, mkSysTyVar, tyVarKind )
  20 import VarEnv
  21 import VarSet
  22 import Id               ( Id, idType,
  23                           getIdUnfolding, setIdUnfolding,
  24                           getIdSpecialisation, setIdSpecialisation,
  25                           getIdDemandInfo, setIdDemandInfo,
  26                           getIdArity, setIdArity,
  27                           getIdStrictness,
  28                           setInlinePragma, getInlinePragma, idMustBeINLINEd,
  29                           idWantsToBeINLINEd
  30                         )
  31 import IdInfo           ( InlinePragInfo(..), OccInfo(..), StrictnessInfo(..),
  32                           ArityInfo, atLeastArity, arityLowerBound, unknownArity
  33                         )
  34 import Demand           ( Demand, isStrict, wwLazy )
  35 import Const            ( isWHNFCon, conOkForAlt )
  36 import ConFold          ( tryPrimOp )
  37 import PrimOp           ( PrimOp, primOpStrictness )
  38 import DataCon          ( DataCon, dataConNumInstArgs, dataConStrictMarks, dataConSig, dataConArgTys )
  39 import Const            ( Con(..) )
  40 import MagicUFs         ( applyMagicUnfoldingFun )
  41 import Name             ( isExported, isLocallyDefined )
  42 import CoreSyn
  43 import CoreUnfold       ( Unfolding(..), UnfoldingGuidance(..),
  44                           mkUnfolding, smallEnoughToInline,
  45                           isEvaldUnfolding
  46                         )
  47 import CoreUtils        ( IdSubst, SubstCoreExpr(..),
  48                           cheapEqExpr, exprIsDupable, exprIsWHNF, exprIsTrivial,
  49                           coreExprType, coreAltsType, exprIsCheap, substExpr,
  50                           FormSummary(..), mkFormSummary, whnfOrBottom
  51                         )
  52 import SpecEnv          ( lookupSpecEnv, isEmptySpecEnv, substSpecEnv )
  53 import CostCentre       ( isSubsumedCCS, currentCCS, isEmptyCC )
  54 import Type             ( Type, mkTyVarTy, mkTyVarTys, isUnLiftedType, fullSubstTy,
  55                           mkFunTy, splitFunTys, splitTyConApp_maybe, splitFunTy_maybe,
  56                           applyTy, applyTys, funResultTy, isDictTy, isDataType
  57                         )
  58 import TyCon            ( isDataTyCon, tyConDataCons, tyConClass_maybe, tyConArity, isDataTyCon )
  59 import TysPrim          ( realWorldStatePrimTy )
  60 import PrelVals         ( realWorldPrimId )
  61 import BasicTypes       ( StrictnessMark(..) )
  62 import Maybes           ( maybeToBool )
  63 import Util             ( zipWithEqual, stretchZipEqual )
  64 import PprCore
  65 import Outputable
  66 \end{code}
  67
  68
  69 The guts of the simplifier is in this module, but the driver
  70 loop for the simplifier is in SimplPgm.lhs.
  71
  72
  73 %************************************************************************
  74 %*                                                                      *
  75 \subsection[Simplify-simplExpr]{The main function: simplExpr}
  76 %*                                                                      *
  77 %************************************************************************
  78
  79 \begin{code}
  80 addBind :: CoreBind -> OutStuff a -> OutStuff a
  81 addBind bind    (binds,  res) = (bind:binds,     res)
  82
  83 addBinds :: [CoreBind] -> OutStuff a -> OutStuff a
  84 addBinds []     stuff         = stuff
  85 addBinds binds1 (binds2, res) = (binds1++binds2, res)
  86 \end{code}
  87
  88 The reason for this OutExprStuff stuff is that we want to float *after*
  89 simplifying a RHS, not before.  If we do so naively we get quadratic
  90 behaviour as things float out.
  91
  92 To see why it's important to do it after, consider this (real) example:
  93
  94         let t = f x
  95         in fst t
  96 ==>
  97         let t = let a = e1
  98                     b = e2
  99                 in (a,b)
 100         in fst t
 101 ==>
 102         let a = e1
 103             b = e2
 104             t = (a,b)
 105         in
 106         a       -- Can't inline a this round, cos it appears twice
 107 ==>
 108         e1
 109
 110 Each of the ==> steps is a round of simplification.  We'd save a
 111 whole round if we float first.  This can cascade.  Consider
 112
 113         let f = g d
 114         in \x -> ...f...
 115 ==>
 116         let f = let d1 = ..d.. in \y -> e
 117         in \x -> ...f...
 118 ==>
 119         let d1 = ..d..
 120         in \x -> ...(\y ->e)...
 121
 122 Only in this second round can the \y be applied, and it
 123 might do the same again.
 124
 125
 126 \begin{code}
 127 simplExpr :: CoreExpr -> SimplCont -> SimplM CoreExpr
 128 simplExpr expr cont = simplExprB expr cont      `thenSmpl` \ (binds, (_, body)) ->
 129                       returnSmpl (mkLetBinds binds body)
 130
 131 simplExprB :: InExpr -> SimplCont -> SimplM OutExprStuff
 132
 133 simplExprB (Note InlineCall (Var v)) cont
 134   = simplVar True v cont
 135
 136 simplExprB (Var v) cont
 137   = simplVar False v cont
 138
 139 simplExprB expr@(Con (PrimOp op) args) cont
 140   = simplType (coreExprType expr)       `thenSmpl` \ expr_ty ->
 141     getInScope                          `thenSmpl` \ in_scope ->
 142     getSubstEnv                         `thenSmpl` \ se ->
 143     let
 144         (val_arg_demands, _) = primOpStrictness op
 145
 146         -- Main game plan: loop through the arguments, simplifying
 147         -- each of them with an ArgOf continuation.  Getting the right
 148         -- cont_ty in the ArgOf continuation is a bit of a nuisance.
 149         go []         ds     args' = rebuild_primop (reverse args')
 150         go (arg:args) ds     args'
 151            | isTypeArg arg         = setSubstEnv se (simplArg arg)      `thenSmpl` \ arg' ->
 152                                      go args ds (arg':args')
 153         go (arg:args) (d:ds) args'
 154            | not (isStrict d)      = setSubstEnv se (simplArg arg)      `thenSmpl` \ arg' ->
 155                                      go args ds (arg':args')
 156            | otherwise             = setSubstEnv se (simplExprB arg (mk_cont args ds args'))
 157
 158         cont_ty = contResultType in_scope expr_ty cont
 159         mk_cont args ds args' = ArgOf NoDup (\ arg' -> go args ds (arg':args')) cont_ty
 160     in
 161     go args val_arg_demands []
 162   where
 163
 164     rebuild_primop args'
 165       = --      Try the prim op simplification
 166         -- It's really worth trying simplExpr again if it succeeds,
 167         -- because you can find
 168         --      case (eqChar# x 'a') of ...
 169         -- ==>
 170         --      case (case x of 'a' -> True; other -> False) of ...
 171         case tryPrimOp op args' of
 172           Just e' -> zapSubstEnv (simplExprB e' cont)
 173           Nothing -> rebuild (Con (PrimOp op) args') cont
 174
 175 simplExprB (Con con@(DataCon _) args) cont
 176   = simplConArgs args           $ \ args' ->
 177     rebuild (Con con args') cont
 178
 179 simplExprB expr@(Con con@(Literal _) args) cont
 180   = ASSERT( null args )
 181     rebuild expr cont
 182
 183 simplExprB (App fun arg) cont
 184   = getSubstEnv         `thenSmpl` \ se ->
 185     simplExprB fun (ApplyTo NoDup arg se cont)
 186
 187 simplExprB (Case scrut bndr alts) cont
 188   = getSubstEnv         `thenSmpl` \ se ->
 189     simplExprB scrut (Select NoDup bndr alts se cont)
 190
 191 simplExprB (Note (Coerce to from) e) cont
 192   | to == from = simplExprB e cont
 193   | otherwise  = getSubstEnv            `thenSmpl` \ se ->
 194                  simplExprB e (CoerceIt NoDup to se cont)
 195
 196 -- hack: we only distinguish subsumed cost centre stacks for the purposes of
 197 -- inlining.  All other CCCSs are mapped to currentCCS.
 198 simplExprB (Note (SCC cc) e) cont
 199   = setEnclosingCC currentCCS $
 200     simplExpr e Stop    `thenSmpl` \ e ->
 201     rebuild (mkNote (SCC cc) e) cont
 202
 203 simplExprB (Note note e) cont
 204   = simplExpr e Stop    `thenSmpl` \ e' ->
 205     rebuild (mkNote note e') cont
 206
 207 -- A non-recursive let is dealt with by simplBeta
 208 simplExprB (Let (NonRec bndr rhs) body) cont
 209   = getSubstEnv         `thenSmpl` \ se ->
 210     simplBeta bndr rhs se body cont
 211
 212 simplExprB (Let (Rec pairs) body) cont
 213   = simplRecBind pairs (simplExprB body cont)
 214
 215 -- Type-beta reduction
 216 simplExprB expr@(Lam bndr body) cont@(ApplyTo _ (Type ty_arg) arg_se body_cont)
 217   = ASSERT( isTyVar bndr )
 218     tick BetaReduction                          `thenSmpl_`
 219     setSubstEnv arg_se (simplType ty_arg)       `thenSmpl` \ ty' ->
 220     extendTySubst bndr ty'                      $
 221     simplExprB body body_cont
 222
 223 -- Ordinary beta reduction
 224 simplExprB expr@(Lam bndr body) cont@(ApplyTo _ arg arg_se body_cont)
 225   = tick BetaReduction          `thenSmpl_`
 226     simplBeta bndr' arg arg_se body body_cont
 227   where
 228     bndr' = zapLambdaBndr bndr body body_cont
 229
 230 simplExprB (Lam bndr body) cont
 231   = simplBinder bndr                    $ \ bndr' ->
 232     simplExpr body Stop                 `thenSmpl` \ body' ->
 233     rebuild (Lam bndr' body') cont
 234
 235 simplExprB (Type ty) cont
 236   = ASSERT( case cont of { Stop -> True; ArgOf _ _ _ -> True; other -> False } )
 237     simplType ty        `thenSmpl` \ ty' ->
 238     rebuild (Type ty') cont
 239 \end{code}
 240
 241
 242 ---------------------------------
 243 \begin{code}
 244 simplArg :: InArg -> SimplM OutArg
 245 simplArg arg = simplExpr arg Stop
 246 \end{code}
 247
 248 ---------------------------------
 249 simplConArgs makes sure that the arguments all end up being atomic.
 250 That means it may generate some Lets, hence the
 251
 252 \begin{code}
 253 simplConArgs :: [InArg] -> ([OutArg] -> SimplM OutExprStuff) -> SimplM OutExprStuff
 254 simplConArgs [] thing_inside
 255   = thing_inside []
 256
 257 simplConArgs (arg:args) thing_inside
 258   = switchOffInlining (simplArg arg)    `thenSmpl` \ arg' ->
 259         -- Simplify the RHS with inlining switched off, so that
 260         -- only absolutely essential things will happen.
 261
 262     simplConArgs args                           $ \ args' ->
 263
 264         -- If the argument ain't trivial, then let-bind it
 265     if exprIsTrivial arg' then
 266         thing_inside (arg' : args')
 267     else
 268         newId (coreExprType arg')               $ \ arg_id ->
 269         thing_inside (Var arg_id : args')       `thenSmpl` \ res ->
 270         returnSmpl (addBind (NonRec arg_id arg') res)
 271 \end{code}
 272
 273
 274 ---------------------------------
 275 \begin{code}
 276 simplType :: InType -> SimplM OutType
 277 simplType ty
 278   = getTyEnv            `thenSmpl` \ (ty_subst, in_scope) ->
 279     returnSmpl (fullSubstTy ty_subst in_scope ty)
 280 \end{code}
 281
 282
 283 \begin{code}
 284 -- Find out whether the lambda is saturated,
 285 -- if not zap the over-optimistic info in the binder
 286
 287 zapLambdaBndr bndr body body_cont
 288   | isTyVar bndr || safe_info || definitely_saturated 20 body body_cont
 289         -- The "20" is to catch pathalogical cases with bazillions of arguments
 290         -- because we are using an n**2 algorithm here
 291   = bndr                -- No need to zap
 292   | otherwise
 293   = setInlinePragma (setIdDemandInfo bndr wwLazy)
 294                     safe_inline_prag
 295
 296   where
 297     inline_prag         = getInlinePragma bndr
 298     demand              = getIdDemandInfo bndr
 299
 300     safe_info           = is_safe_inline_prag && not (isStrict demand)
 301
 302     is_safe_inline_prag = case inline_prag of
 303                                 ICanSafelyBeINLINEd StrictOcc nalts -> False
 304                                 ICanSafelyBeINLINEd LazyOcc   nalts -> False
 305                                 other                               -> True
 306
 307     safe_inline_prag    = case inline_prag of
 308                                 ICanSafelyBeINLINEd _ nalts
 309                                       -> ICanSafelyBeINLINEd InsideLam nalts
 310                                 other -> inline_prag
 311
 312     definitely_saturated 0 _            _                    = False    -- Too expensive to find out
 313     definitely_saturated n (Lam _ body) (ApplyTo _ _ _ cont) = definitely_saturated (n-1) body cont
 314     definitely_saturated n (Lam _ _)    other_cont           = False
 315     definitely_saturated n _            _                    = True
 316 \end{code}
 317
 318 %************************************************************************
 319 %*                                                                      *
 320 \subsection{Variables}
 321 %*                                                                      *
 322 %************************************************************************
 323
 324 Coercions
 325 ~~~~~~~~~
 326 \begin{code}
 327 simplVar inline_call var cont
 328   = getValEnv           `thenSmpl` \ (id_subst, in_scope) ->
 329     case lookupVarEnv id_subst var of
 330         Just (Done e)
 331                 -> zapSubstEnv (simplExprB e cont)
 332
 333         Just (SubstMe e ty_subst id_subst)
 334                 -> setSubstEnv (ty_subst, id_subst) (simplExprB e cont)
 335
 336         Nothing -> let
 337                         var' = case lookupVarSet in_scope var of
 338                                  Just v' -> v'
 339                                  Nothing ->
 340 #ifdef DEBUG
 341                                             if isLocallyDefined var && not (idMustBeINLINEd var) then
 342                                                 -- Not in scope
 343                                                 pprTrace "simplVar:" (ppr var) var
 344                                             else
 345 #endif
 346                                             var
 347                    in
 348                    getSwitchChecker     `thenSmpl` \ sw_chkr ->
 349                    completeVar sw_chkr in_scope inline_call var' cont
 350
 351 completeVar sw_chkr in_scope inline_call var cont
 352
 353 {-      MAGIC UNFOLDINGS NOT USED NOW
 354   | maybeToBool maybe_magic_result
 355   = tick MagicUnfold    `thenSmpl_`
 356     magic_result
 357 -}
 358         -- Look for existing specialisations before trying inlining
 359   | maybeToBool maybe_specialisation
 360   = tick SpecialisationDone                     `thenSmpl_`
 361     setSubstEnv (spec_bindings, emptyVarEnv)    (
 362         -- See note below about zapping the substitution here
 363
 364     simplExprB spec_template remaining_cont
 365     )
 366
 367         -- Don't actually inline the scrutinee when we see
 368         --      case x of y { .... }
 369         -- and x has unfolding (C a b).  Why not?  Because
 370         -- we get a silly binding y = C a b.  If we don't
 371         -- inline knownCon can directly substitute x for y instead.
 372   | has_unfolding && var_is_case_scrutinee && unfolding_is_constr
 373   = knownCon (Var var) con con_args cont
 374
 375         -- Look for an unfolding. There's a binding for the
 376         -- thing, but perhaps we want to inline it anyway
 377   | has_unfolding && (inline_call || ok_to_inline)
 378   = getEnclosingCC      `thenSmpl` \ encl_cc ->
 379     if must_be_unfolded || costCentreOk encl_cc (coreExprCc unf_template)
 380     then        -- OK to unfold
 381
 382         tickUnfold var          `thenSmpl_` (
 383
 384         zapSubstEnv             $
 385                 -- The template is already simplified, so don't re-substitute.
 386                 -- This is VITAL.  Consider
 387                 --      let x = e in
 388                 --      let y = \z -> ...x... in
 389                 --      \ x -> ...y...
 390                 -- We'll clone the inner \x, adding x->x' in the id_subst
 391                 -- Then when we inline y, we must *not* replace x by x' in
 392                 -- the inlined copy!!
 393 #ifdef DEBUG
 394         if opt_D_dump_inlinings then
 395                 pprTrace "Inlining:" (ppr var <+> ppr unf_template) $
 396                 simplExprB unf_template cont
 397         else
 398 #endif
 399         simplExprB unf_template cont
 400         )
 401     else
 402 #ifdef DEBUG
 403         pprTrace "Inlining disallowed due to CC:\n" (ppr encl_cc <+> ppr unf_template <+> ppr (coreExprCc unf_template)) $
 404 #endif
 405         -- Can't unfold because of bad cost centre
 406         rebuild (Var var) cont
 407
 408   | inline_call         -- There was an InlineCall note, but we didn't inline!
 409   = rebuild (Note InlineCall (Var var)) cont
 410
 411   | otherwise
 412   = rebuild (Var var) cont
 413
 414   where
 415     unfolding = getIdUnfolding var
 416
 417 {-      MAGIC UNFOLDINGS NOT USED CURRENTLY
 418         ---------- Magic unfolding stuff
 419     maybe_magic_result  = case unfolding of
 420                                 MagicUnfolding _ magic_fn -> applyMagicUnfoldingFun magic_fn
 421                                                                                     cont
 422                                 other                     -> Nothing
 423     Just magic_result = maybe_magic_result
 424 -}
 425
 426         ---------- Unfolding stuff
 427     has_unfolding = case unfolding of
 428                         CoreUnfolding _ _ _ -> True
 429                         other               -> False
 430     CoreUnfolding form guidance unf_template = unfolding
 431
 432         -- overrides cost-centre business
 433     must_be_unfolded = case getInlinePragma var of
 434                           IMustBeINLINEd -> True
 435                           _              -> False
 436
 437     ok_to_inline        = okToInline sw_chkr in_scope var form guidance cont
 438     unfolding_is_constr = case unf_template of
 439                                   Con con _ -> conOkForAlt con
 440                                   other     -> False
 441     Con con con_args    = unf_template
 442
 443         ---------- Specialisation stuff
 444     ty_args                   = initial_ty_args cont
 445     remaining_cont            = drop_ty_args cont
 446     maybe_specialisation      = lookupSpecEnv (ppr var) (getIdSpecialisation var) ty_args
 447     Just (spec_bindings, spec_template) = maybe_specialisation
 448
 449     initial_ty_args (ApplyTo _ (Type ty) (ty_subst,_) cont)
 450         = fullSubstTy ty_subst in_scope ty : initial_ty_args cont
 451         -- Having to do the substitution here is a bit of a bore
 452     initial_ty_args other_cont = []
 453
 454     drop_ty_args (ApplyTo _ (Type _) _ cont) = drop_ty_args cont
 455     drop_ty_args other_cont                  = other_cont
 456
 457         ---------- Switches
 458
 459     var_is_case_scrutinee = case cont of
 460                                   Select _ _ _ _ _ -> True
 461                                   other            -> False
 462
 463 ----------- costCentreOk
 464 -- costCentreOk checks that it's ok to inline this thing
 465 -- The time it *isn't* is this:
 466 --
 467 --      f x = let y = E in
 468 --            scc "foo" (...y...)
 469 --
 470 -- Here y has a "current cost centre", and we can't inline it inside "foo",
 471 -- regardless of whether E is a WHNF or not.
 472
 473 costCentreOk ccs_encl cc_rhs
 474   =  not opt_SccProfilingOn
 475   || isSubsumedCCS ccs_encl       -- can unfold anything into a subsumed scope
 476   || not (isEmptyCC cc_rhs)       -- otherwise need a cc on the unfolding
 477 \end{code}
 478
 479
 480 %************************************************************************
 481 %*                                                                      *
 482 \subsection{Bindings}
 483 %*                                                                      *
 484 %************************************************************************
 485
 486 \begin{code}
 487 simplBind :: InBind -> SimplM (OutStuff a) -> SimplM (OutStuff a)
 488
 489 simplBind (NonRec bndr rhs) thing_inside
 490   = simplTopRhs bndr rhs        `thenSmpl` \ (binds, in_scope,  rhs', arity) ->
 491     setInScope in_scope                                                 $
 492     completeBindNonRec (bndr `setIdArity` arity) rhs' thing_inside      `thenSmpl` \ stuff ->
 493     returnSmpl (addBinds binds stuff)
 494
 495 simplBind (Rec pairs) thing_inside
 496   = simplRecBind pairs thing_inside
 497         -- The assymetry between the two cases is a bit unclean
 498
 499 simplRecBind :: [(InId, InExpr)] -> SimplM (OutStuff a) -> SimplM (OutStuff a)
 500 simplRecBind pairs thing_inside
 501   = simplIds (map fst pairs)            $ \ bndrs' ->
 502         -- NB: bndrs' don't have unfoldings or spec-envs
 503         -- We add them as we go down, using simplPrags
 504
 505     go (pairs `zip` bndrs')             `thenSmpl` \ (pairs', stuff) ->
 506     returnSmpl (addBind (Rec pairs') stuff)
 507   where
 508     go [] = thing_inside        `thenSmpl` \ stuff ->
 509             returnSmpl ([], stuff)
 510
 511     go (((bndr, rhs), bndr') : pairs)
 512         = simplTopRhs bndr rhs                          `thenSmpl` \ (rhs_binds, in_scope, rhs', arity) ->
 513           setInScope in_scope                           $
 514           completeBindRec bndr (bndr' `setIdArity` arity)
 515                           rhs' (go pairs)               `thenSmpl` \ (pairs', stuff) ->
 516           returnSmpl (flatten rhs_binds pairs', stuff)
 517
 518     flatten (NonRec b r : binds) prs  = (b,r) : flatten binds prs
 519     flatten (Rec prs1   : binds) prs2 = prs1 ++ flatten binds prs2
 520     flatten []                   prs  = prs
 521
 522
 523 completeBindRec bndr bndr' rhs' thing_inside
 524   |  postInlineUnconditionally bndr etad_rhs
 525         -- NB: a loop breaker never has postInlineUnconditionally True
 526         -- and non-loop-breakers only have *forward* references
 527         -- Hence, it's safe to discard the binding
 528   =  tick PostInlineUnconditionally             `thenSmpl_`
 529      extendIdSubst bndr (Done etad_rhs) thing_inside
 530
 531   |  otherwise
 532   =     -- Here's the only difference from completeBindNonRec: we
 533         -- don't do simplBinder first, because we've already
 534         -- done simplBinder on the recursive binders
 535      simplPrags bndr bndr' etad_rhs             `thenSmpl` \ bndr'' ->
 536      modifyInScope bndr''                       $
 537      thing_inside                               `thenSmpl` \ (pairs, res) ->
 538      returnSmpl ((bndr'', etad_rhs) : pairs, res)
 539   where
 540      etad_rhs = etaCoreExpr rhs'
 541 \end{code}
 542
 543
 544 %************************************************************************
 545 %*                                                                      *
 546 \subsection{Right hand sides}
 547 %*                                                                      *
 548 %************************************************************************
 549
 550 simplRhs basically just simplifies the RHS of a let(rec).
 551 It does two important optimisations though:
 552
 553         * It floats let(rec)s out of the RHS, even if they
 554           are hidden by big lambdas
 555
 556         * It does eta expansion
 557
 558 \begin{code}
 559 simplTopRhs :: InId -> InExpr
 560   -> SimplM ([OutBind], InScopeEnv, OutExpr, ArityInfo)
 561 simplTopRhs bndr rhs
 562   = getSubstEnv                 `thenSmpl` \ bndr_se ->
 563     simplRhs bndr bndr_se rhs
 564
 565 simplRhs bndr bndr_se rhs
 566   | idWantsToBeINLINEd bndr     -- Don't inline in the RHS of something that has an
 567                                 -- inline pragma.  But be careful that the InScopeEnv that
 568                                 -- we return does still have inlinings on!
 569   = switchOffInlining (simplExpr rhs Stop)      `thenSmpl` \ rhs' ->
 570     getInScope                                  `thenSmpl` \ in_scope ->
 571     returnSmpl ([], in_scope, rhs', unknownArity)
 572
 573   | otherwise
 574   =     -- Swizzle the inner lets past the big lambda (if any)
 575     mkRhsTyLam rhs                      `thenSmpl` \ swizzled_rhs ->
 576
 577         -- Simplify the swizzled RHS
 578     simplRhs2 bndr bndr_se swizzled_rhs `thenSmpl` \ (floats, (in_scope, rhs', arity)) ->
 579
 580     if not (null floats) && exprIsWHNF rhs' then        -- Do the float
 581         tick LetFloatFromLet    `thenSmpl_`
 582         returnSmpl (floats, in_scope, rhs', arity)
 583     else                        -- Don't do it
 584         getInScope              `thenSmpl` \ in_scope ->
 585         returnSmpl ([], in_scope, mkLetBinds floats rhs', arity)
 586 \end{code}
 587
 588 ---------------------------------------------------------
 589         Try eta expansion for RHSs
 590
 591 We need to pass in the substitution environment for the RHS, because
 592 it might be different to the current one (see simplBeta, as called
 593 from simplExpr for an applied lambda).  The binder needs to
 594
 595 \begin{code}
 596 simplRhs2 bndr bndr_se (Let bind body)
 597   = simplBind bind (simplRhs2 bndr bndr_se body)
 598
 599 simplRhs2 bndr bndr_se rhs
 600   | null ids    -- Prevent eta expansion for both thunks
 601                 -- (would lose sharing) and variables (nothing gained).
 602                 -- To see why we ignore it for thunks, consider
 603                 --      let f = lookup env key in (f 1, f 2)
 604                 -- We'd better not eta expand f just because it is
 605                 -- always applied!
 606                 --
 607                 -- Also if there isn't a lambda at the top we use
 608                 -- simplExprB so that we can do (more) let-floating
 609   = simplExprB rhs Stop         `thenSmpl` \ (binds, (in_scope, rhs')) ->
 610     returnSmpl (binds, (in_scope, rhs', unknownArity))
 611
 612   | otherwise   -- Consider eta expansion
 613   = getSwitchChecker            `thenSmpl` \ sw_chkr ->
 614     getInScope                  `thenSmpl` \ in_scope ->
 615     simplBinders tyvars         $ \ tyvars' ->
 616     simplBinders ids            $ \ ids' ->
 617
 618     if switchIsOn sw_chkr SimplDoLambdaEtaExpansion
 619     && not (null extra_arg_tys)
 620     then
 621         tick EtaExpansion                       `thenSmpl_`
 622         setSubstEnv bndr_se (mapSmpl simplType extra_arg_tys)
 623                                                 `thenSmpl` \ extra_arg_tys' ->
 624         newIds extra_arg_tys'                   $ \ extra_bndrs' ->
 625         simplExpr body (mk_cont extra_bndrs')   `thenSmpl` \ body' ->
 626         let
 627             expanded_rhs = mkLams tyvars'
 628                          $ mkLams ids'
 629                          $ mkLams extra_bndrs' body'
 630             expanded_arity = atLeastArity (no_of_ids + no_of_extras)
 631         in
 632         returnSmpl ([], (in_scope, expanded_rhs, expanded_arity))
 633
 634     else
 635         simplExpr body Stop                     `thenSmpl` \ body' ->
 636         let
 637             unexpanded_rhs = mkLams tyvars'
 638                            $ mkLams ids' body'
 639             unexpanded_arity = atLeastArity no_of_ids
 640         in
 641         returnSmpl ([], (in_scope, unexpanded_rhs, unexpanded_arity))
 642
 643   where
 644     (tyvars, ids, body) = collectTyAndValBinders rhs
 645     no_of_ids           = length ids
 646
 647     potential_extra_arg_tys :: [InType] -- NB: InType
 648     potential_extra_arg_tys  = case splitFunTys (applyTys (idType bndr) (mkTyVarTys tyvars)) of
 649                                   (arg_tys, _) -> drop no_of_ids arg_tys
 650
 651     extra_arg_tys :: [InType]
 652     extra_arg_tys  = take no_extras_wanted potential_extra_arg_tys
 653     no_of_extras   = length extra_arg_tys
 654
 655     no_extras_wanted =  -- Use information about how many args the fn is applied to
 656                         (arity - no_of_ids)     `max`
 657
 658                         -- See if the body could obviously do with more args
 659                         etaExpandCount body     `max`
 660
 661                         -- Finally, see if it's a state transformer, in which
 662                         -- case we eta-expand on principle! This can waste work,
 663                         -- but usually doesn't
 664                         case potential_extra_arg_tys of
 665                                 [ty] | ty == realWorldStatePrimTy -> 1
 666                                 other                             -> 0
 667
 668     arity = arityLowerBound (getIdArity bndr)
 669
 670     mk_cont []     = Stop
 671     mk_cont (b:bs) = ApplyTo OkToDup (Var b) emptySubstEnv (mk_cont bs)
 672 \end{code}
 673
 674
 675 %************************************************************************
 676 %*                                                                      *
 677 \subsection{Binding}
 678 %*                                                                      *
 679 %************************************************************************
 680
 681 \begin{code}
 682 simplBeta :: InId                       -- Binder
 683           -> InExpr -> SubstEnv         -- Arg, with its subst-env
 684           -> InExpr -> SimplCont        -- Lambda body
 685           -> SimplM OutExprStuff
 686 #ifdef DEBUG
 687 simplBeta bndr rhs rhs_se body cont
 688   | isTyVar bndr
 689   = pprPanic "simplBeta" ((ppr bndr <+> ppr rhs) $$ ppr cont)
 690 #endif
 691
 692 simplBeta bndr rhs rhs_se body cont
 693   |  isUnLiftedType bndr_ty
 694   || (isStrict (getIdDemandInfo bndr) || is_dict bndr) && not (exprIsWHNF rhs)
 695   = tick Let2Case       `thenSmpl_`
 696     getSubstEnv         `thenSmpl` \ body_se ->
 697     setSubstEnv rhs_se  $
 698     simplExprB rhs (Select NoDup bndr [(DEFAULT, [], body)] body_se cont)
 699
 700   | preInlineUnconditionally bndr && not opt_NoPreInlining
 701   = tick PreInlineUnconditionally                       `thenSmpl_`
 702     case rhs_se of                                      { (ty_subst, id_subst) ->
 703     extendIdSubst bndr (SubstMe rhs ty_subst id_subst)  $
 704     simplExprB body cont }
 705
 706   | otherwise
 707   = getSubstEnv                 `thenSmpl` \ bndr_se ->
 708     setSubstEnv rhs_se (simplRhs bndr bndr_se rhs)
 709                                 `thenSmpl` \ (floats, in_scope, rhs', arity) ->
 710     setInScope in_scope                         $
 711     completeBindNonRec (bndr `setIdArity` arity) rhs' (
 712             simplExprB body cont
 713     )                                           `thenSmpl` \ stuff ->
 714     returnSmpl (addBinds floats stuff)
 715   where
 716         -- Return true only for dictionary types where the dictionary
 717         -- has more than one component (else we risk poking on the component
 718         -- of a newtype dictionary)
 719     is_dict bndr = opt_DictsStrict && isDictTy bndr_ty && isDataType bndr_ty
 720     bndr_ty      = idType bndr
 721 \end{code}
 722
 723
 724 completeBindNonRec
 725         - deals only with Ids, not TyVars
 726         - take an already-simplified RHS
 727         - always produce let bindings
 728
 729 It does *not* attempt to do let-to-case.  Why?  Because they are used for
 730
 731         - top-level bindings
 732                 (when let-to-case is impossible)
 733
 734         - many situations where the "rhs" is known to be a WHNF
 735                 (so let-to-case is inappropriate).
 736
 737 \begin{code}
 738 completeBindNonRec :: InId              -- Binder
 739                 -> OutExpr              -- Simplified RHS
 740                 -> SimplM (OutStuff a)  -- Thing inside
 741                 -> SimplM (OutStuff a)
 742 completeBindNonRec bndr rhs thing_inside
 743   |  isDeadBinder bndr          -- This happens; for example, the case_bndr during case of
 744                                 -- known constructor:  case (a,b) of x { (p,q) -> ... }
 745                                 -- Here x isn't mentioned in the RHS, so we don't want to
 746                                 -- create the (dead) let-binding  let x = (a,b) in ...
 747   =  thing_inside
 748
 749   |  postInlineUnconditionally bndr etad_rhs
 750   =  tick PostInlineUnconditionally     `thenSmpl_`
 751      extendIdSubst bndr (Done etad_rhs)
 752      thing_inside
 753
 754   |  otherwise                  -- Note that we use etad_rhs here
 755                                 -- This gives maximum chance for a remaining binding
 756                                 -- to be zapped by the indirection zapper in OccurAnal
 757   =  simplBinder bndr                           $ \ bndr' ->
 758      simplPrags bndr bndr' etad_rhs             `thenSmpl` \ bndr'' ->
 759      modifyInScope bndr''                       $
 760      thing_inside                               `thenSmpl` \ stuff ->
 761      returnSmpl (addBind (NonRec bndr' etad_rhs) stuff)
 762   where
 763      etad_rhs = etaCoreExpr rhs
 764
 765 -- (simplPrags old_bndr new_bndr new_rhs) does two things
 766 --      (a) it attaches the new unfolding to new_bndr
 767 --      (b) it grabs the SpecEnv from old_bndr, applies the current
 768 --          substitution to it, and attaches it to new_bndr
 769 --  The assumption is that new_bndr, which is produced by simplBinder
 770 --  has no unfolding or specenv.
 771
 772 simplPrags old_bndr new_bndr new_rhs
 773   | isEmptySpecEnv spec_env
 774   = returnSmpl (bndr_w_unfolding)
 775
 776   | otherwise
 777   = getSimplBinderStuff `thenSmpl` \ (ty_subst, id_subst, in_scope, us) ->
 778     let
 779         spec_env' = substSpecEnv ty_subst in_scope (subst_val id_subst) spec_env
 780     in
 781     returnSmpl (bndr_w_unfolding `setIdSpecialisation` spec_env')
 782   where
 783     bndr_w_unfolding = new_bndr `setIdUnfolding` mkUnfolding new_rhs
 784
 785     spec_env = getIdSpecialisation old_bndr
 786     subst_val id_subst ty_subst in_scope expr
 787         = substExpr ty_subst id_subst in_scope expr
 788 \end{code}
 789
 790 \begin{code}
 791 preInlineUnconditionally :: InId -> Bool
 792         -- Examines a bndr to see if it is used just once in a
 793         -- completely safe way, so that it is safe to discard the binding
 794         -- inline its RHS at the (unique) usage site, REGARDLESS of how
 795         -- big the RHS might be.  If this is the case we don't simplify
 796         -- the RHS first, but just inline it un-simplified.
 797         --
 798         -- This is much better than first simplifying a perhaps-huge RHS
 799         -- and then inlining and re-simplifying it.
 800         --
 801         -- NB: we don't even look at the RHS to see if it's trivial
 802         -- We might have
 803         --                      x = y
 804         -- where x is used many times, but this is the unique occurrence
 805         -- of y.  We should NOT inline x at all its uses, because then
 806         -- we'd do the same for y -- aargh!  So we must base this
 807         -- pre-rhs-simplification decision solely on x's occurrences, not
 808         -- on its rhs.
 809 preInlineUnconditionally bndr
 810   = case getInlinePragma bndr of
 811         ICanSafelyBeINLINEd InsideLam  _    -> False
 812         ICanSafelyBeINLINEd not_in_lam True -> True     -- Not inside a lambda,
 813                                                         -- one occurrence ==> safe!
 814         other -> False
 815
 816
 817 postInlineUnconditionally :: InId -> OutExpr -> Bool
 818         -- Examines a (bndr = rhs) binding, AFTER the rhs has been simplified
 819         -- It returns True if it's ok to discard the binding and inline the
 820         -- RHS at every use site.
 821
 822         -- NOTE: This isn't our last opportunity to inline.
 823         -- We're at the binding site right now, and
 824         -- we'll get another opportunity when we get to the ocurrence(s)
 825
 826 postInlineUnconditionally bndr rhs
 827   | isExported bndr
 828   = False
 829   | otherwise
 830   = case getInlinePragma bndr of
 831         IAmALoopBreaker                           -> False
 832         IMustNotBeINLINEd                         -> False
 833         IAmASpecPragmaId                          -> False      -- Don't discard SpecPrag Ids
 834
 835         ICanSafelyBeINLINEd InsideLam one_branch  -> exprIsTrivial rhs
 836                         -- Don't inline even WHNFs inside lambdas; this
 837                         -- isn't the last chance; see NOTE above.
 838
 839         ICanSafelyBeINLINEd not_in_lam one_branch -> one_branch || exprIsDupable rhs
 840
 841         other                                     -> exprIsTrivial rhs  -- Duplicating is *free*
 842                 -- NB: Even IWantToBeINLINEd and IMustBeINLINEd are ignored here
 843                 -- Why?  Because we don't even want to inline them into the
 844                 -- RHS of constructor arguments. See NOTE above
 845
 846 inlineCase bndr scrut
 847   = case getInlinePragma bndr of
 848         -- Not expecting IAmALoopBreaker etc; this is a case binder!
 849
 850         ICanSafelyBeINLINEd StrictOcc one_branch
 851                 -> one_branch || exprIsDupable scrut
 852                 -- This case is the entire reason we distinguish StrictOcc from LazyOcc
 853                 -- We want eliminate the "case" only if we aren't going to
 854                 -- build a thunk instead, and that's what StrictOcc finds
 855                 -- For example:
 856                 --      case (f x) of y { DEFAULT -> g y }
 857                 -- Here we DO NOT WANT:
 858                 --      g (f x)
 859                 -- *even* if g is strict.  We want to avoid constructing the
 860                 -- thunk for (f x)!  So y gets a LazyOcc.
 861
 862         other   -> exprIsTrivial scrut                  -- Duplication is free
 863                 && (  isUnLiftedType (idType bndr)
 864                    || scrut_is_evald_var                -- So dropping the case won't change termination
 865                    || isStrict (getIdDemandInfo bndr))  -- It's going to get evaluated later, so again
 866                                                         -- termination doesn't change
 867   where
 868         -- Check whether or not scrut is known to be evaluted
 869         -- It's not going to be a visible value (else the previous
 870         -- blob would apply) so we just check the variable case
 871     scrut_is_evald_var = case scrut of
 872                                 Var v -> isEvaldUnfolding (getIdUnfolding v)
 873                                 other -> False
 874 \end{code}
 875
 876 okToInline is used at call sites, so it is a bit more generous.
 877 It's a very important function that embodies lots of heuristics.
 878
 879 \begin{code}
 880 okToInline :: SwitchChecker
 881            -> InScopeEnv
 882            -> Id                -- The Id
 883            -> FormSummary       -- The thing is WHNF or bottom;
 884            -> UnfoldingGuidance
 885            -> SimplCont
 886            -> Bool              -- True <=> inline it
 887
 888 -- A non-WHNF can be inlined if it doesn't occur inside a lambda,
 889 -- and occurs exactly once or
 890 --     occurs once in each branch of a case and is small
 891 --
 892 -- If the thing is in WHNF, there's no danger of duplicating work,
 893 -- so we can inline if it occurs once, or is small
 894
 895 okToInline sw_chkr in_scope id form guidance cont
 896   | switchIsOn sw_chkr EssentialUnfoldingsOnly
 897   =
 898 #ifdef DEBUG
 899     if opt_D_dump_inlinings then
 900         pprTrace "Considering inlining"
 901                  (ppr id <+> vcat [text "essential inlinings only",
 902                                    text "inline prag:" <+> ppr inline_prag,
 903                                    text "ANSWER =" <+> if result then text "YES" else text "NO"])
 904                  result
 905     else
 906 #endif
 907     result
 908   where
 909     inline_prag  = getInlinePragma id
 910     result = idMustBeINLINEd id
 911                 -- If "essential_unfoldings_only" is true we do no inlinings at all,
 912                 -- EXCEPT for things that absolutely have to be done
 913                 -- (see comments with idMustBeINLINEd)
 914
 915
 916 okToInline sw_chkr in_scope id form guidance cont
 917         -- Essential unfoldings only not on
 918   =
 919 #ifdef DEBUG
 920     if opt_D_dump_inlinings then
 921         pprTrace "Considering inlining"
 922                  (ppr id <+> vcat [text "inline prag:" <+> ppr inline_prag,
 923                                    text "whnf" <+> ppr whnf,
 924                                    text "small enough" <+> ppr small_enough,
 925                                    text "some benefit" <+> ppr some_benefit,
 926                                    text "arg evals" <+> ppr arg_evals,
 927                                    text "result scrut" <+> ppr result_scrut,
 928                                    text "ANSWER =" <+> if result then text "YES" else text "NO"])
 929                   result
 930      else
 931 #endif
 932     result
 933   where
 934     result = case inline_prag of
 935                 IAmDead           -> pprTrace "okToInline: dead" (ppr id) False
 936
 937                 IAmASpecPragmaId  -> False
 938                 IMustNotBeINLINEd -> False
 939                 IAmALoopBreaker   -> False
 940                 IMustBeINLINEd    -> True
 941                 IWantToBeINLINEd  -> True
 942
 943                 ICanSafelyBeINLINEd inside_lam one_branch
 944                         -> (small_enough || one_branch) &&
 945                            ((whnf && some_benefit) || not_inside_lam)
 946
 947                         where
 948                            not_inside_lam = case inside_lam of {InsideLam -> False; other -> True}
 949
 950                 other   -> whnf && small_enough && some_benefit
 951                         -- We could consider using exprIsCheap here,
 952                         -- as in postInlineUnconditionally, but unlike the latter we wouldn't
 953                         -- necessarily eliminate a thunk; and the "form" doesn't tell
 954                         -- us that.
 955
 956     inline_prag  = getInlinePragma id
 957     whnf         = whnfOrBottom form
 958     small_enough = smallEnoughToInline id arg_evals result_scrut guidance
 959     (arg_evals, result_scrut) = get_evals cont
 960
 961         -- some_benefit checks that *something* interesting happens to
 962         -- the variable after it's inlined.
 963     some_benefit = contIsInteresting cont
 964
 965         -- Finding out whether the args are evaluated.  This isn't completely easy
 966         -- because the args are not yet simplified, so we have to peek into them.
 967     get_evals (ApplyTo _ arg (te,ve) cont)
 968       | isValArg arg = case get_evals cont of
 969                           (args, res) -> (get_arg_eval arg ve : args, res)
 970       | otherwise    = get_evals cont
 971
 972     get_evals (Select _ _ _ _ _) = ([], True)
 973     get_evals other              = ([], False)
 974
 975     get_arg_eval (Con con _) ve = isWHNFCon con
 976     get_arg_eval (Var v)     ve = case lookupVarEnv ve v of
 977                                     Just (SubstMe e' _ ve') -> get_arg_eval e' ve'
 978                                     Just (Done (Con con _)) -> isWHNFCon con
 979                                     Just (Done (Var v'))    -> get_var_eval v'
 980                                     Just (Done other)       -> False
 981                                     Nothing                 -> get_var_eval v
 982     get_arg_eval other       ve = False
 983
 984     get_var_eval v = case lookupVarSet in_scope v of
 985                         Just v' -> isEvaldUnfolding (getIdUnfolding v')
 986                         Nothing -> isEvaldUnfolding (getIdUnfolding v)
 987
 988
 989 contIsInteresting :: SimplCont -> Bool
 990 contIsInteresting Stop                        = False
 991 contIsInteresting (ArgOf _ _ _)               = False
 992 contIsInteresting (ApplyTo _ (Type _) _ cont) = contIsInteresting cont
 993 contIsInteresting (CoerceIt _ _ _ cont)       = contIsInteresting cont
 994
 995 -- Even a case with only a default case is a bit interesting;
 996 --      we may be able to eliminate it after inlining.
 997 -- contIsInteresting (Select _ _ [(DEFAULT,_,_)] _ _) = False
 998
 999 contIsInteresting _                           = True
1000 \end{code}
1001
1002 Comment about some_benefit above
1003 ~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~
1004
1005 We want to avoid inlining an expression where there can't possibly be
1006 any gain, such as in an argument position.  Hence, if the continuation
1007 is interesting (eg. a case scrutinee, application etc.) then we
1008 inline, otherwise we don't.
1009
1010 Previously some_benefit used to return True only if the variable was
1011 applied to some value arguments.  This didn't work:
1012
1013         let x = _coerce_ (T Int) Int (I# 3) in
1014         case _coerce_ Int (T Int) x of
1015                 I# y -> ....
1016
1017 we want to inline x, but can't see that it's a constructor in a case
1018 scrutinee position, and some_benefit is False.
1019
1020 Another example:
1021
1022 dMonadST = _/\_ t -> :Monad (g1 _@_ t, g2 _@_ t, g3 _@_ t)
1023
1024 ....  case dMonadST _@_ x0 of (a,b,c) -> ....
1025
1026 we'd really like to inline dMonadST here, but we *don't* want to
1027 inline if the case expression is just
1028
1029         case x of y { DEFAULT -> ... }
1030
1031 since we can just eliminate this case instead (x is in WHNF).  Similar
1032 applies when x is bound to a lambda expression.  Hence
1033 contIsInteresting looks for case expressions with just a single
1034 default case.
1035
1036 %************************************************************************
1037 %*                                                                      *
1038 \subsection{The main rebuilder}
1039 %*                                                                      *
1040 %************************************************************************
1041
1042 \begin{code}
1043 -------------------------------------------------------------------
1044 rebuild :: OutExpr -> SimplCont -> SimplM OutExprStuff
1045
1046 rebuild expr cont
1047   = tick LeavesExamined                                 `thenSmpl_`
1048     do_rebuild expr cont
1049
1050 rebuild_done expr
1051   = getInScope                  `thenSmpl` \ in_scope ->
1052     returnSmpl ([], (in_scope, expr))
1053
1054 ---------------------------------------------------------
1055 --      Stop continuation
1056
1057 do_rebuild expr Stop = rebuild_done expr
1058
1059
1060 ---------------------------------------------------------
1061 --      ArgOf continuation
1062
1063 do_rebuild expr (ArgOf _ cont_fn _) = cont_fn expr
1064
1065 ---------------------------------------------------------
1066 --      ApplyTo continuation
1067
1068 do_rebuild expr cont@(ApplyTo _ arg se cont')
1069   = case expr of
1070         Var v -> case getIdStrictness v of
1071                     NoStrictnessInfo                    -> non_strict_case
1072                     StrictnessInfo demands result_bot _ -> ASSERT( not (null demands) || result_bot )
1073                                                                 -- If this happened we'd get an infinite loop
1074                                                            rebuild_strict demands result_bot expr (idType v) cont
1075         other -> non_strict_case
1076   where
1077     non_strict_case = setSubstEnv se (simplArg arg)     `thenSmpl` \ arg' ->
1078                       do_rebuild (App expr arg') cont'
1079
1080
1081 ---------------------------------------------------------
1082 --      Coerce continuation
1083
1084 do_rebuild expr (CoerceIt _ to_ty se cont)
1085   = setSubstEnv se      $
1086     simplType to_ty     `thenSmpl` \ to_ty' ->
1087     do_rebuild (mk_coerce to_ty' expr) cont
1088   where
1089     mk_coerce to_ty' (Note (Coerce _ from_ty) expr) = Note (Coerce to_ty' from_ty) expr
1090     mk_coerce to_ty' expr                           = Note (Coerce to_ty' (coreExprType expr)) expr
1091
1092
1093 ---------------------------------------------------------
1094 --      Case of known constructor or literal
1095
1096 do_rebuild expr@(Con con args) cont@(Select _ _ _ _ _)
1097   | conOkForAlt con     -- Knocks out PrimOps and NoRepLits
1098   = knownCon expr con args cont
1099
1100
1101 ---------------------------------------------------------
1102
1103 --      Case of other value (e.g. a partial application or lambda)
1104 --      Turn it back into a let
1105
1106 do_rebuild expr (Select _ bndr ((DEFAULT, bs, rhs):alts) se cont)
1107   | case mkFormSummary expr of { ValueForm -> True; other -> False }
1108   = ASSERT( null bs && null alts )
1109     tick Case2Let               `thenSmpl_`
1110     setSubstEnv se              (
1111     completeBindNonRec bndr expr        $
1112     simplExprB rhs cont
1113     )
1114
1115
1116 ---------------------------------------------------------
1117 --      The other Select cases
1118
1119 do_rebuild scrut (Select _ bndr alts se cont)
1120   = getSwitchChecker                                    `thenSmpl` \ chkr ->
1121
1122     if all (cheapEqExpr rhs1) other_rhss
1123        && inlineCase bndr scrut
1124        && all binders_unused alts
1125        && switchIsOn chkr SimplDoCaseElim
1126     then
1127         -- Get rid of the case altogether
1128         -- See the extensive notes on case-elimination below
1129         -- Remember to bind the binder though!
1130             tick  CaseElim              `thenSmpl_`
1131             setSubstEnv se                      (
1132             extendIdSubst bndr (Done scrut)     $
1133             simplExprB rhs1 cont
1134             )
1135
1136     else
1137         rebuild_case chkr scrut bndr alts se cont
1138   where
1139     (rhs1:other_rhss)            = [rhs | (_,_,rhs) <- alts]
1140     binders_unused (_, bndrs, _) = all isDeadBinder bndrs
1141 \end{code}
1142
1143 Case elimination [see the code above]
1144 ~~~~~~~~~~~~~~~~
1145 Start with a simple situation:
1146
1147         case x# of      ===>   e[x#/y#]
1148           y# -> e
1149
1150 (when x#, y# are of primitive type, of course).  We can't (in general)
1151 do this for algebraic cases, because we might turn bottom into
1152 non-bottom!
1153
1154 Actually, we generalise this idea to look for a case where we're
1155 scrutinising a variable, and we know that only the default case can
1156 match.  For example:
1157 \begin{verbatim}
1158         case x of
1159           0#    -> ...
1160           other -> ...(case x of
1161                          0#    -> ...
1162                          other -> ...) ...
1163 \end{code}
1164 Here the inner case can be eliminated.  This really only shows up in
1165 eliminating error-checking code.
1166
1167 We also make sure that we deal with this very common case:
1168
1169         case e of
1170           x -> ...x...
1171
1172 Here we are using the case as a strict let; if x is used only once
1173 then we want to inline it.  We have to be careful that this doesn't
1174 make the program terminate when it would have diverged before, so we
1175 check that
1176         - x is used strictly, or
1177         - e is already evaluated (it may so if e is a variable)
1178
1179 Lastly, we generalise the transformation to handle this:
1180
1181         case e of       ===> r
1182            True  -> r
1183            False -> r
1184
1185 We only do this for very cheaply compared r's (constructors, literals
1186 and variables).  If pedantic bottoms is on, we only do it when the
1187 scrutinee is a PrimOp which can't fail.
1188
1189 We do it *here*, looking at un-simplified alternatives, because we
1190 have to check that r doesn't mention the variables bound by the
1191 pattern in each alternative, so the binder-info is rather useful.
1192
1193 So the case-elimination algorithm is:
1194
1195         1. Eliminate alternatives which can't match
1196
1197         2. Check whether all the remaining alternatives
1198                 (a) do not mention in their rhs any of the variables bound in their pattern
1199            and  (b) have equal rhss
1200
1201         3. Check we can safely ditch the case:
1202                    * PedanticBottoms is off,
1203                 or * the scrutinee is an already-evaluated variable
1204                 or * the scrutinee is a primop which is ok for speculation
1205                         -- ie we want to preserve divide-by-zero errors, and
1206                         -- calls to error itself!
1207
1208                 or * [Prim cases] the scrutinee is a primitive variable
1209
1210                 or * [Alg cases] the scrutinee is a variable and
1211                      either * the rhs is the same variable
1212                         (eg case x of C a b -> x  ===>   x)
1213                      or     * there is only one alternative, the default alternative,
1214                                 and the binder is used strictly in its scope.
1215                                 [NB this is helped by the "use default binder where
1216                                  possible" transformation; see below.]
1217
1218
1219 If so, then we can replace the case with one of the rhss.
1220
1221
1222 \begin{code}
1223 ---------------------------------------------------------
1224 --      Rebuiling a function with strictness info
1225
1226 rebuild_strict :: [Demand] -> Bool      -- Stricness info
1227                -> OutExpr -> OutType    -- Function and type
1228                -> SimplCont             -- Continuation
1229                -> SimplM OutExprStuff
1230
1231 rebuild_strict [] True  fun fun_ty cont = rebuild_bot fun fun_ty cont
1232 rebuild_strict [] False fun fun_ty cont = do_rebuild fun cont
1233
1234 rebuild_strict ds result_bot fun fun_ty (ApplyTo _ (Type ty_arg) se cont)
1235                                 -- Type arg; don't consume a demand
1236         = setSubstEnv se (simplType ty_arg)     `thenSmpl` \ ty_arg' ->
1237           rebuild_strict ds result_bot (App fun (Type ty_arg'))
1238                          (applyTy fun_ty ty_arg') cont
1239
1240 rebuild_strict (d:ds) result_bot fun fun_ty (ApplyTo _ val_arg se cont)
1241         | isStrict d || isUnLiftedType arg_ty   -- Strict value argument
1242         = getInScope                            `thenSmpl` \ in_scope ->
1243           let
1244                 cont_ty = contResultType in_scope res_ty cont
1245           in
1246           setSubstEnv se (simplExprB val_arg (ArgOf NoDup cont_fn cont_ty))
1247
1248         | otherwise                             -- Lazy value argument
1249         = setSubstEnv se (simplArg val_arg)     `thenSmpl` \ val_arg' ->
1250           cont_fn val_arg'
1251
1252         where
1253           Just (arg_ty, res_ty) = splitFunTy_maybe fun_ty
1254           cont_fn arg'          = rebuild_strict ds result_bot
1255                                                  (App fun arg') res_ty
1256                                                  cont
1257
1258 rebuild_strict ds result_bot fun fun_ty cont = do_rebuild fun cont
1259
1260 ---------------------------------------------------------
1261 --      Dealing with
1262 --      * case (error "hello") of { ... }
1263 --      * (error "Hello") arg
1264 --      etc
1265
1266 rebuild_bot expr expr_ty Stop                           -- No coerce needed
1267   = rebuild_done expr
1268
1269 rebuild_bot expr expr_ty (CoerceIt _ to_ty se Stop)     -- Don't "tick" on this,
1270                                                         -- else simplifier never stops
1271   = setSubstEnv se      $
1272     simplType to_ty     `thenSmpl` \ to_ty' ->
1273     rebuild_done (mkNote (Coerce to_ty' expr_ty) expr)
1274
1275 rebuild_bot expr expr_ty cont
1276   = tick CaseOfError            `thenSmpl_`
1277     getInScope                  `thenSmpl` \ in_scope ->
1278     let
1279         result_ty = contResultType in_scope expr_ty cont
1280     in
1281     rebuild_done (mkNote (Coerce result_ty expr_ty) expr)
1282 \end{code}
1283
1284 Blob of helper functions for the "case-of-something-else" situation.
1285
1286 \begin{code}
1287 ---------------------------------------------------------
1288 --      Case of something else
1289
1290 rebuild_case sw_chkr scrut case_bndr alts se cont
1291   =     -- Prepare case alternatives
1292     prepareCaseAlts (splitTyConApp_maybe (idType case_bndr))
1293                     scrut_cons alts             `thenSmpl` \ better_alts ->
1294
1295         -- Set the new subst-env in place (before dealing with the case binder)
1296     setSubstEnv se                              $
1297
1298         -- Deal with the case binder, and prepare the continuation;
1299         -- The new subst_env is in place
1300     simplBinder case_bndr                       $ \ case_bndr' ->
1301     prepareCaseCont better_alts cont            $ \ cont' ->
1302
1303
1304         -- Deal with variable scrutinee
1305     substForVarScrut scrut case_bndr'           $ \ zap_occ_info ->
1306     let
1307         case_bndr'' = zap_occ_info case_bndr'
1308     in
1309
1310         -- Deal with the case alternaatives
1311     simplAlts zap_occ_info scrut_cons
1312               case_bndr'' better_alts cont'     `thenSmpl` \ alts' ->
1313
1314     mkCase sw_chkr scrut case_bndr'' alts'      `thenSmpl` \ case_expr ->
1315     rebuild_done case_expr
1316   where
1317         -- scrut_cons tells what constructors the scrutinee can't possibly match
1318     scrut_cons = case scrut of
1319                    Var v -> case getIdUnfolding v of
1320                                 OtherCon cons -> cons
1321                                 other         -> []
1322                    other -> []
1323
1324
1325 knownCon expr con args (Select _ bndr alts se cont)
1326   = tick KnownBranch            `thenSmpl_`
1327     setSubstEnv se              (
1328     case findAlt con alts of
1329         (DEFAULT, bs, rhs)     -> ASSERT( null bs )
1330                                   completeBindNonRec bndr expr $
1331                                   simplExprB rhs cont
1332
1333         (Literal lit, bs, rhs) -> ASSERT( null bs )
1334                                   extendIdSubst bndr (Done expr)        $
1335                                         -- Unconditionally substitute, because expr must
1336                                         -- be a variable or a literal.  It can't be a
1337                                         -- NoRep literal because they don't occur in
1338                                         -- case patterns.
1339                                   simplExprB rhs cont
1340
1341         (DataCon dc, bs, rhs)  -> completeBindNonRec bndr expr          $
1342                                   extend bs real_args                   $
1343                                   simplExprB rhs cont
1344                                where
1345                                   real_args = drop (dataConNumInstArgs dc) args
1346     )
1347   where
1348     extend []     []         thing_inside = thing_inside
1349     extend (b:bs) (arg:args) thing_inside = extendIdSubst b (Done arg)  $
1350                                             extend bs args thing_inside
1351 \end{code}
1352
1353 \begin{code}
1354 prepareCaseCont :: [InAlt] -> SimplCont
1355                 -> (SimplCont -> SimplM (OutStuff a))
1356                 -> SimplM (OutStuff a)
1357         -- Polymorphic recursion here!
1358
1359 prepareCaseCont [alt] cont thing_inside = thing_inside cont
1360 prepareCaseCont alts  cont thing_inside = mkDupableCont (coreAltsType alts) cont thing_inside
1361 \end{code}
1362
1363 substForVarScrut checks whether the scrutinee is a variable, v.
1364 If so, try to eliminate uses of v in the RHSs in favour of case_bndr;
1365 that way, there's a chance that v will now only be used once, and hence inlined.
1366
1367 If we do this, then we have to nuke any occurrence info (eg IAmDead)
1368 in the case binder, because the case-binder now effectively occurs
1369 whenever v does.  AND we have to do the same for the pattern-bound
1370 variables!  Example:
1371
1372         (case x of { (a,b) -> a }) (case x of { (p,q) -> q })
1373
1374 Here, b and p are dead.  But when we move the argment inside the first
1375 case RHS, and eliminate the second case, we get
1376
1377         case x or { (a,b) -> a b
1378
1379 Urk! b is alive!  Reason: the scrutinee was a variable, and case elimination
1380 happened.  Hence the zap_occ_info function returned by substForVarScrut
1381
1382 \begin{code}
1383 substForVarScrut (Var v) case_bndr' thing_inside
1384   | isLocallyDefined v          -- No point for imported things
1385   = modifyInScope (v `setIdUnfolding` mkUnfolding (Var case_bndr')
1386                      `setInlinePragma` IMustBeINLINEd)                  $
1387         -- We could extend the substitution instead, but it would be
1388         -- a hack because then the substitution wouldn't be idempotent
1389         -- any more.
1390     thing_inside (\ bndr ->  bndr `setInlinePragma` NoInlinePragInfo)
1391
1392 substForVarScrut other_scrut case_bndr' thing_inside
1393   = thing_inside (\ bndr -> bndr)       -- NoOp on bndr
1394 \end{code}
1395
1396 prepareCaseAlts does two things:
1397
1398 1.  Remove impossible alternatives
1399
1400 2.  If the DEFAULT alternative can match only one possible constructor,
1401     then make that constructor explicit.
1402     e.g.
1403         case e of x { DEFAULT -> rhs }
1404      ===>
1405         case e of x { (a,b) -> rhs }
1406     where the type is a single constructor type.  This gives better code
1407     when rhs also scrutinises x or e.
1408
1409 \begin{code}
1410 prepareCaseAlts (Just (tycon, inst_tys)) scrut_cons alts
1411   | isDataTyCon tycon
1412   = case (findDefault filtered_alts, missing_cons) of
1413
1414         ((alts_no_deflt, Just rhs), [data_con])         -- Just one missing constructor!
1415                 -> tick FillInCaseDefault       `thenSmpl_`
1416                    let
1417                         (_,_,ex_tyvars,_,_,_) = dataConSig data_con
1418                    in
1419                    getUniquesSmpl (length ex_tyvars)                            `thenSmpl` \ tv_uniqs ->
1420                    let
1421                         ex_tyvars' = zipWithEqual "simpl_alt" mk tv_uniqs ex_tyvars
1422                         mk uniq tv = mkSysTyVar uniq (tyVarKind tv)
1423                    in
1424                    newIds (dataConArgTys
1425                                 data_con
1426                                 (inst_tys ++ mkTyVarTys ex_tyvars'))            $ \ bndrs ->
1427                    returnSmpl ((DataCon data_con, ex_tyvars' ++ bndrs, rhs) : alts_no_deflt)
1428
1429         other -> returnSmpl filtered_alts
1430   where
1431         -- Filter out alternatives that can't possibly match
1432     filtered_alts = case scrut_cons of
1433                         []    -> alts
1434                         other -> [alt | alt@(con,_,_) <- alts, not (con `elem` scrut_cons)]
1435
1436     missing_cons = [data_con | data_con <- tyConDataCons tycon,
1437                                not (data_con `elem` handled_data_cons)]
1438     handled_data_cons = [data_con | DataCon data_con         <- scrut_cons] ++
1439                         [data_con | (DataCon data_con, _, _) <- filtered_alts]
1440
1441 -- The default case
1442 prepareCaseAlts _ scrut_cons alts
1443   = returnSmpl alts                     -- Functions
1444
1445
1446 ----------------------
1447 simplAlts zap_occ_info scrut_cons case_bndr'' alts cont'
1448   = mapSmpl simpl_alt alts
1449   where
1450     inst_tys' = case splitTyConApp_maybe (idType case_bndr'') of
1451                         Just (tycon, inst_tys) -> inst_tys
1452
1453         -- handled_cons is all the constructors that are dealt
1454         -- with, either by being impossible, or by there being an alternative
1455     handled_cons = scrut_cons ++ [con | (con,_,_) <- alts, con /= DEFAULT]
1456
1457     simpl_alt (DEFAULT, _, rhs)
1458         = modifyInScope (case_bndr'' `setIdUnfolding` OtherCon handled_cons)    $
1459           simplExpr rhs cont'                                                   `thenSmpl` \ rhs' ->
1460           returnSmpl (DEFAULT, [], rhs')
1461
1462     simpl_alt (con, vs, rhs)
1463         =       -- Deal with the case-bound variables
1464                 -- Mark the ones that are in ! positions in the data constructor
1465                 -- as certainly-evaluated
1466           simplBinders (add_evals con vs)       $ \ vs' ->
1467
1468                 -- Bind the case-binder to (Con args)
1469                 -- In the default case we record the constructors it *can't* be.
1470                 -- We take advantage of any OtherCon info in the case scrutinee
1471           let
1472                 con_app = Con con (map Type inst_tys' ++ map varToCoreExpr vs')
1473           in
1474           modifyInScope (case_bndr'' `setIdUnfolding` mkUnfolding con_app)      $
1475           simplExpr rhs cont'           `thenSmpl` \ rhs' ->
1476           returnSmpl (con, vs', rhs')
1477
1478
1479         -- add_evals records the evaluated-ness of the bound variables of
1480         -- a case pattern.  This is *important*.  Consider
1481         --      data T = T !Int !Int
1482         --
1483         --      case x of { T a b -> T (a+1) b }
1484         --
1485         -- We really must record that b is already evaluated so that we don't
1486         -- go and re-evaluated it when constructing the result.
1487
1488     add_evals (DataCon dc) vs = stretchZipEqual add_eval vs (dataConStrictMarks dc)
1489     add_evals other_con    vs = vs
1490
1491     add_eval v m | isTyVar v = Nothing
1492                  | otherwise = case m of
1493                                   MarkedStrict    -> Just (zap_occ_info v `setIdUnfolding` OtherCon [])
1494                                   NotMarkedStrict -> Just (zap_occ_info v)
1495 \end{code}
1496
1497
1498
1499
1500 %************************************************************************
1501 %*                                                                      *
1502 \subsection{Duplicating continuations}
1503 %*                                                                      *
1504 %************************************************************************
1505
1506 \begin{code}
1507 mkDupableCont :: InType         -- Type of the thing to be given to the continuation
1508               -> SimplCont
1509               -> (SimplCont -> SimplM (OutStuff a))
1510               -> SimplM (OutStuff a)
1511 mkDupableCont ty cont thing_inside
1512   | contIsDupable cont
1513   = thing_inside cont
1514
1515 mkDupableCont _ (CoerceIt _ ty se cont) thing_inside
1516   = mkDupableCont ty cont               $ \ cont' ->
1517     thing_inside (CoerceIt OkToDup ty se cont')
1518
1519 mkDupableCont join_arg_ty (ArgOf _ cont_fn res_ty) thing_inside
1520   =     -- Build the RHS of the join point
1521     simplType join_arg_ty                               `thenSmpl` \ join_arg_ty' ->
1522     newId join_arg_ty'                                  ( \ arg_id ->
1523         getSwitchChecker                                `thenSmpl` \ chkr ->
1524         cont_fn (Var arg_id)                            `thenSmpl` \ (binds, (_, rhs)) ->
1525         returnSmpl (Lam arg_id (mkLetBinds binds rhs))
1526     )                                                   `thenSmpl` \ join_rhs ->
1527
1528         -- Build the join Id and continuation
1529     newId (coreExprType join_rhs)               $ \ join_id ->
1530     let
1531         new_cont = ArgOf OkToDup
1532                          (\arg' -> rebuild_done (App (Var join_id) arg'))
1533                          res_ty
1534     in
1535
1536         -- Do the thing inside
1537     thing_inside new_cont               `thenSmpl` \ res ->
1538     returnSmpl (addBind (NonRec join_id join_rhs) res)
1539
1540 mkDupableCont ty (ApplyTo _ arg se cont) thing_inside
1541   = mkDupableCont (funResultTy ty) cont                 $ \ cont' ->
1542     setSubstEnv se (simplArg arg)                       `thenSmpl` \ arg' ->
1543     if exprIsDupable arg' then
1544         thing_inside (ApplyTo OkToDup arg' emptySubstEnv cont')
1545     else
1546     newId (coreExprType arg')                                           $ \ bndr ->
1547     thing_inside (ApplyTo OkToDup (Var bndr) emptySubstEnv cont')       `thenSmpl` \ res ->
1548     returnSmpl (addBind (NonRec bndr arg') res)
1549
1550 mkDupableCont ty (Select _ case_bndr alts se cont) thing_inside
1551   = tick CaseOfCase                                             `thenSmpl_` (
1552     setSubstEnv se      (
1553         simplBinder case_bndr                                   $ \ case_bndr' ->
1554         prepareCaseCont alts cont                               $ \ cont' ->
1555         mapAndUnzipSmpl (mkDupableAlt case_bndr' cont') alts    `thenSmpl` \ (alt_binds_s, alts') ->
1556         returnSmpl (concat alt_binds_s, (case_bndr', alts'))
1557     )                                   `thenSmpl` \ (alt_binds, (case_bndr', alts')) ->
1558
1559     extendInScopes [b | NonRec b _ <- alt_binds]                        $
1560     thing_inside (Select OkToDup case_bndr' alts' emptySubstEnv Stop)   `thenSmpl` \ res ->
1561     returnSmpl (addBinds alt_binds res)
1562     )
1563
1564 mkDupableAlt :: OutId -> SimplCont -> InAlt -> SimplM (OutStuff CoreAlt)
1565 mkDupableAlt case_bndr' cont alt@(con, bndrs, rhs)
1566   = simplBinders bndrs                                  $ \ bndrs' ->
1567     simplExpr rhs cont                                  `thenSmpl` \ rhs' ->
1568     if exprIsDupable rhs' then
1569         -- It's small, so don't bother to let-bind it
1570         returnSmpl ([], (con, bndrs', rhs'))
1571     else
1572         -- It's big, so let-bind it
1573     let
1574         rhs_ty' = coreExprType rhs'
1575         used_bndrs' = filter (not . isDeadBinder) (case_bndr' : bndrs')
1576     in
1577     ( if null used_bndrs' && isUnLiftedType rhs_ty'
1578         then newId realWorldStatePrimTy  $ \ rw_id ->
1579              returnSmpl ([rw_id], [varToCoreExpr realWorldPrimId])
1580         else
1581              returnSmpl (used_bndrs', map varToCoreExpr used_bndrs')
1582     )
1583         `thenSmpl` \ (final_bndrs', final_args) ->
1584
1585         -- If we try to lift a primitive-typed something out
1586         -- for let-binding-purposes, we will *caseify* it (!),
1587         -- with potentially-disastrous strictness results.  So
1588         -- instead we turn it into a function: \v -> e
1589         -- where v::State# RealWorld#.  The value passed to this function
1590         -- is realworld#, which generates (almost) no code.
1591
1592         -- There's a slight infelicity here: we pass the overall
1593         -- case_bndr to all the join points if it's used in *any* RHS,
1594         -- because we don't know its usage in each RHS separately
1595
1596     newId (foldr (mkFunTy . idType) rhs_ty' final_bndrs')       $ \ join_bndr ->
1597     returnSmpl ([NonRec join_bndr (mkLams final_bndrs' rhs')],
1598                 (con, bndrs', mkApps (Var join_bndr) final_args))
1599 \end{code}