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, unfoldAlways
  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   = pprTrace "simplPrags" (ppr old_bndr) $
 778     getSimplBinderStuff `thenSmpl` \ (ty_subst, id_subst, in_scope, us) ->
 779     let
 780         spec_env' = substSpecEnv ty_subst in_scope (subst_val id_subst) spec_env
 781     in
 782     returnSmpl (bndr_w_unfolding `setIdSpecialisation` spec_env')
 783   where
 784     bndr_w_unfolding = new_bndr `setIdUnfolding` mkUnfolding new_rhs
 785
 786     spec_env = getIdSpecialisation old_bndr
 787     subst_val id_subst ty_subst in_scope expr
 788         = substExpr ty_subst id_subst in_scope expr
 789 \end{code}
 790
 791 \begin{code}
 792 preInlineUnconditionally :: InId -> Bool
 793         -- Examines a bndr to see if it is used just once in a
 794         -- completely safe way, so that it is safe to discard the binding
 795         -- inline its RHS at the (unique) usage site, REGARDLESS of how
 796         -- big the RHS might be.  If this is the case we don't simplify
 797         -- the RHS first, but just inline it un-simplified.
 798         --
 799         -- This is much better than first simplifying a perhaps-huge RHS
 800         -- and then inlining and re-simplifying it.
 801         --
 802         -- NB: we don't even look at the RHS to see if it's trivial
 803         -- We might have
 804         --                      x = y
 805         -- where x is used many times, but this is the unique occurrence
 806         -- of y.  We should NOT inline x at all its uses, because then
 807         -- we'd do the same for y -- aargh!  So we must base this
 808         -- pre-rhs-simplification decision solely on x's occurrences, not
 809         -- on its rhs.
 810 preInlineUnconditionally bndr
 811   = case getInlinePragma bndr of
 812         ICanSafelyBeINLINEd InsideLam  _    -> False
 813         ICanSafelyBeINLINEd not_in_lam True -> True     -- Not inside a lambda,
 814                                                         -- one occurrence ==> safe!
 815         other -> False
 816
 817
 818 postInlineUnconditionally :: InId -> OutExpr -> Bool
 819         -- Examines a (bndr = rhs) binding, AFTER the rhs has been simplified
 820         -- It returns True if it's ok to discard the binding and inline the
 821         -- RHS at every use site.
 822
 823         -- NOTE: This isn't our last opportunity to inline.
 824         -- We're at the binding site right now, and
 825         -- we'll get another opportunity when we get to the ocurrence(s)
 826
 827 postInlineUnconditionally bndr rhs
 828   | isExported bndr
 829   = False
 830   | otherwise
 831   = case getInlinePragma bndr of
 832         IAmALoopBreaker                           -> False
 833         IMustNotBeINLINEd                         -> False
 834         IAmASpecPragmaId                          -> False      -- Don't discard SpecPrag Ids
 835
 836         ICanSafelyBeINLINEd InsideLam one_branch  -> exprIsTrivial rhs
 837                         -- Don't inline even WHNFs inside lambdas; this
 838                         -- isn't the last chance; see NOTE above.
 839
 840         ICanSafelyBeINLINEd not_in_lam one_branch -> one_branch || exprIsDupable rhs
 841
 842         other                                     -> exprIsTrivial rhs  -- Duplicating is *free*
 843                 -- NB: Even IWantToBeINLINEd and IMustBeINLINEd are ignored here
 844                 -- Why?  Because we don't even want to inline them into the
 845                 -- RHS of constructor arguments. See NOTE above
 846
 847 inlineCase bndr scrut
 848   = case getInlinePragma bndr of
 849         -- Not expecting IAmALoopBreaker etc; this is a case binder!
 850
 851         ICanSafelyBeINLINEd StrictOcc one_branch
 852                 -> one_branch || exprIsDupable scrut
 853                 -- This case is the entire reason we distinguish StrictOcc from LazyOcc
 854                 -- We want eliminate the "case" only if we aren't going to
 855                 -- build a thunk instead, and that's what StrictOcc finds
 856                 -- For example:
 857                 --      case (f x) of y { DEFAULT -> g y }
 858                 -- Here we DO NOT WANT:
 859                 --      g (f x)
 860                 -- *even* if g is strict.  We want to avoid constructing the
 861                 -- thunk for (f x)!  So y gets a LazyOcc.
 862
 863         other   -> exprIsTrivial scrut                  -- Duplication is free
 864                 && (  isUnLiftedType (idType bndr)
 865                    || scrut_is_evald_var                -- So dropping the case won't change termination
 866                    || isStrict (getIdDemandInfo bndr))  -- It's going to get evaluated later, so again
 867                                                         -- termination doesn't change
 868   where
 869         -- Check whether or not scrut is known to be evaluted
 870         -- It's not going to be a visible value (else the previous
 871         -- blob would apply) so we just check the variable case
 872     scrut_is_evald_var = case scrut of
 873                                 Var v -> isEvaldUnfolding (getIdUnfolding v)
 874                                 other -> False
 875 \end{code}
 876
 877 okToInline is used at call sites, so it is a bit more generous.
 878 It's a very important function that embodies lots of heuristics.
 879
 880 \begin{code}
 881 okToInline :: SwitchChecker
 882            -> InScopeEnv
 883            -> Id                -- The Id
 884            -> FormSummary       -- The thing is WHNF or bottom;
 885            -> UnfoldingGuidance
 886            -> SimplCont
 887            -> Bool              -- True <=> inline it
 888
 889 -- A non-WHNF can be inlined if it doesn't occur inside a lambda,
 890 -- and occurs exactly once or
 891 --     occurs once in each branch of a case and is small
 892 --
 893 -- If the thing is in WHNF, there's no danger of duplicating work,
 894 -- so we can inline if it occurs once, or is small
 895
 896 okToInline sw_chkr in_scope id form guidance cont
 897   =
 898 #ifdef DEBUG
 899     if opt_D_dump_inlinings then
 900         pprTrace "Considering inlining"
 901                  (ppr id <+> vcat [text "inline prag:" <+> ppr inline_prag,
 902                                    text "whnf" <+> ppr whnf,
 903                                    text "small enough" <+> ppr small_enough,
 904                                    text "some benefit" <+> ppr some_benefit,
 905                                    text "arg evals" <+> ppr arg_evals,
 906                                    text "result scrut" <+> ppr result_scrut,
 907                                    text "ANSWER =" <+> if result then text "YES" else text "NO"])
 908                   result
 909     else
 910 #endif
 911     result
 912   where
 913     result =
 914       case inline_prag of
 915         IAmDead           -> pprTrace "okToInline: dead" (ppr id) False
 916         IAmASpecPragmaId  -> False
 917         IMustNotBeINLINEd -> False
 918         IAmALoopBreaker   -> False
 919         IMustBeINLINEd    -> True       -- If "essential_unfoldings_only" is true we do no inlinings at all,
 920                                         -- EXCEPT for things that absolutely have to be done
 921                                         -- (see comments with idMustBeINLINEd)
 922         IWantToBeINLINEd  -> inlinings_enabled
 923         ICanSafelyBeINLINEd inside_lam one_branch
 924                           -> inlinings_enabled && (unfold_always || consider_single inside_lam one_branch)
 925         NoInlinePragInfo  -> inlinings_enabled && (unfold_always || consider_multi)
 926
 927     inlinings_enabled = not (switchIsOn sw_chkr EssentialUnfoldingsOnly)
 928     unfold_always     = unfoldAlways guidance
 929
 930         -- Consider benefit for ICanSafelyBeINLINEd
 931     consider_single inside_lam one_branch
 932         = (small_enough || one_branch) && some_benefit && (whnf || not_inside_lam)
 933         where
 934           not_inside_lam = case inside_lam of {InsideLam -> False; other -> True}
 935
 936         -- Consider benefit for NoInlinePragInfo
 937     consider_multi = whnf && small_enough && some_benefit
 938                         -- We could consider using exprIsCheap here,
 939                         -- as in postInlineUnconditionally, but unlike the latter we wouldn't
 940                         -- necessarily eliminate a thunk; and the "form" doesn't tell
 941                         -- us that.
 942
 943     inline_prag  = getInlinePragma id
 944     whnf         = whnfOrBottom form
 945     small_enough = smallEnoughToInline id arg_evals result_scrut guidance
 946     (arg_evals, result_scrut) = get_evals cont
 947
 948         -- some_benefit checks that *something* interesting happens to
 949         -- the variable after it's inlined.
 950     some_benefit = contIsInteresting cont
 951
 952         -- Finding out whether the args are evaluated.  This isn't completely easy
 953         -- because the args are not yet simplified, so we have to peek into them.
 954     get_evals (ApplyTo _ arg (te,ve) cont)
 955       | isValArg arg = case get_evals cont of
 956                           (args, res) -> (get_arg_eval arg ve : args, res)
 957       | otherwise    = get_evals cont
 958
 959     get_evals (Select _ _ _ _ _) = ([], True)
 960     get_evals other              = ([], False)
 961
 962     get_arg_eval (Con con _) ve = isWHNFCon con
 963     get_arg_eval (Var v)     ve = case lookupVarEnv ve v of
 964                                     Just (SubstMe e' _ ve') -> get_arg_eval e' ve'
 965                                     Just (Done (Con con _)) -> isWHNFCon con
 966                                     Just (Done (Var v'))    -> get_var_eval v'
 967                                     Just (Done other)       -> False
 968                                     Nothing                 -> get_var_eval v
 969     get_arg_eval other       ve = False
 970
 971     get_var_eval v = case lookupVarSet in_scope v of
 972                         Just v' -> isEvaldUnfolding (getIdUnfolding v')
 973                         Nothing -> isEvaldUnfolding (getIdUnfolding v)
 974
 975
 976 contIsInteresting :: SimplCont -> Bool
 977 contIsInteresting Stop                        = False
 978 contIsInteresting (ArgOf _ _ _)               = False
 979 contIsInteresting (ApplyTo _ (Type _) _ cont) = contIsInteresting cont
 980 contIsInteresting (CoerceIt _ _ _ cont)       = contIsInteresting cont
 981
 982 -- See notes below on why a case with only a DEFAULT case is not intersting
 983 -- contIsInteresting (Select _ _ [(DEFAULT,_,_)] _ _) = False
 984
 985 contIsInteresting _                           = True
 986 \end{code}
 987
 988 Comment about some_benefit above
 989 ~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~
 990
 991 We want to avoid inlining an expression where there can't possibly be
 992 any gain, such as in an argument position.  Hence, if the continuation
 993 is interesting (eg. a case scrutinee, application etc.) then we
 994 inline, otherwise we don't.
 995
 996 Previously some_benefit used to return True only if the variable was
 997 applied to some value arguments.  This didn't work:
 998
 999         let x = _coerce_ (T Int) Int (I# 3) in
1000         case _coerce_ Int (T Int) x of
1001                 I# y -> ....
1002
1003 we want to inline x, but can't see that it's a constructor in a case
1004 scrutinee position, and some_benefit is False.
1005
1006 Another example:
1007
1008 dMonadST = _/\_ t -> :Monad (g1 _@_ t, g2 _@_ t, g3 _@_ t)
1009
1010 ....  case dMonadST _@_ x0 of (a,b,c) -> ....
1011
1012 we'd really like to inline dMonadST here, but we *don't* want to
1013 inline if the case expression is just
1014
1015         case x of y { DEFAULT -> ... }
1016
1017 since we can just eliminate this case instead (x is in WHNF).  Similar
1018 applies when x is bound to a lambda expression.  Hence
1019 contIsInteresting looks for case expressions with just a single
1020 default case.
1021
1022
1023 %************************************************************************
1024 %*                                                                      *
1025 \subsection{The main rebuilder}
1026 %*                                                                      *
1027 %************************************************************************
1028
1029 \begin{code}
1030 -------------------------------------------------------------------
1031 rebuild :: OutExpr -> SimplCont -> SimplM OutExprStuff
1032
1033 rebuild expr cont
1034   = tick LeavesExamined                                 `thenSmpl_`
1035     do_rebuild expr cont
1036
1037 rebuild_done expr
1038   = getInScope                  `thenSmpl` \ in_scope ->
1039     returnSmpl ([], (in_scope, expr))
1040
1041 ---------------------------------------------------------
1042 --      Stop continuation
1043
1044 do_rebuild expr Stop = rebuild_done expr
1045
1046
1047 ---------------------------------------------------------
1048 --      ArgOf continuation
1049
1050 do_rebuild expr (ArgOf _ cont_fn _) = cont_fn expr
1051
1052 ---------------------------------------------------------
1053 --      ApplyTo continuation
1054
1055 do_rebuild expr cont@(ApplyTo _ arg se cont')
1056   = case expr of
1057         Var v -> case getIdStrictness v of
1058                     NoStrictnessInfo                    -> non_strict_case
1059                     StrictnessInfo demands result_bot _ -> ASSERT( not (null demands) || result_bot )
1060                                                                 -- If this happened we'd get an infinite loop
1061                                                            rebuild_strict demands result_bot expr (idType v) cont
1062         other -> non_strict_case
1063   where
1064     non_strict_case = setSubstEnv se (simplArg arg)     `thenSmpl` \ arg' ->
1065                       do_rebuild (App expr arg') cont'
1066
1067
1068 ---------------------------------------------------------
1069 --      Coerce continuation
1070
1071 do_rebuild expr (CoerceIt _ to_ty se cont)
1072   = setSubstEnv se      $
1073     simplType to_ty     `thenSmpl` \ to_ty' ->
1074     do_rebuild (mk_coerce to_ty' expr) cont
1075   where
1076     mk_coerce to_ty' (Note (Coerce _ from_ty) expr) = Note (Coerce to_ty' from_ty) expr
1077     mk_coerce to_ty' expr                           = Note (Coerce to_ty' (coreExprType expr)) expr
1078
1079
1080 ---------------------------------------------------------
1081 --      Case of known constructor or literal
1082
1083 do_rebuild expr@(Con con args) cont@(Select _ _ _ _ _)
1084   | conOkForAlt con     -- Knocks out PrimOps and NoRepLits
1085   = knownCon expr con args cont
1086
1087
1088 ---------------------------------------------------------
1089
1090 --      Case of other value (e.g. a partial application or lambda)
1091 --      Turn it back into a let
1092
1093 do_rebuild expr (Select _ bndr ((DEFAULT, bs, rhs):alts) se cont)
1094   | case mkFormSummary expr of { ValueForm -> True; other -> False }
1095   = ASSERT( null bs && null alts )
1096     tick Case2Let               `thenSmpl_`
1097     setSubstEnv se              (
1098     completeBindNonRec bndr expr        $
1099     simplExprB rhs cont
1100     )
1101
1102
1103 ---------------------------------------------------------
1104 --      The other Select cases
1105
1106 do_rebuild scrut (Select _ bndr alts se cont)
1107   = getSwitchChecker                                    `thenSmpl` \ chkr ->
1108
1109     if all (cheapEqExpr rhs1) other_rhss
1110        && inlineCase bndr scrut
1111        && all binders_unused alts
1112        && switchIsOn chkr SimplDoCaseElim
1113     then
1114         -- Get rid of the case altogether
1115         -- See the extensive notes on case-elimination below
1116         -- Remember to bind the binder though!
1117             tick  CaseElim              `thenSmpl_`
1118             setSubstEnv se                      (
1119             extendIdSubst bndr (Done scrut)     $
1120             simplExprB rhs1 cont
1121             )
1122
1123     else
1124         rebuild_case chkr scrut bndr alts se cont
1125   where
1126     (rhs1:other_rhss)            = [rhs | (_,_,rhs) <- alts]
1127     binders_unused (_, bndrs, _) = all isDeadBinder bndrs
1128 \end{code}
1129
1130 Case elimination [see the code above]
1131 ~~~~~~~~~~~~~~~~
1132 Start with a simple situation:
1133
1134         case x# of      ===>   e[x#/y#]
1135           y# -> e
1136
1137 (when x#, y# are of primitive type, of course).  We can't (in general)
1138 do this for algebraic cases, because we might turn bottom into
1139 non-bottom!
1140
1141 Actually, we generalise this idea to look for a case where we're
1142 scrutinising a variable, and we know that only the default case can
1143 match.  For example:
1144 \begin{verbatim}
1145         case x of
1146           0#    -> ...
1147           other -> ...(case x of
1148                          0#    -> ...
1149                          other -> ...) ...
1150 \end{code}
1151 Here the inner case can be eliminated.  This really only shows up in
1152 eliminating error-checking code.
1153
1154 We also make sure that we deal with this very common case:
1155
1156         case e of
1157           x -> ...x...
1158
1159 Here we are using the case as a strict let; if x is used only once
1160 then we want to inline it.  We have to be careful that this doesn't
1161 make the program terminate when it would have diverged before, so we
1162 check that
1163         - x is used strictly, or
1164         - e is already evaluated (it may so if e is a variable)
1165
1166 Lastly, we generalise the transformation to handle this:
1167
1168         case e of       ===> r
1169            True  -> r
1170            False -> r
1171
1172 We only do this for very cheaply compared r's (constructors, literals
1173 and variables).  If pedantic bottoms is on, we only do it when the
1174 scrutinee is a PrimOp which can't fail.
1175
1176 We do it *here*, looking at un-simplified alternatives, because we
1177 have to check that r doesn't mention the variables bound by the
1178 pattern in each alternative, so the binder-info is rather useful.
1179
1180 So the case-elimination algorithm is:
1181
1182         1. Eliminate alternatives which can't match
1183
1184         2. Check whether all the remaining alternatives
1185                 (a) do not mention in their rhs any of the variables bound in their pattern
1186            and  (b) have equal rhss
1187
1188         3. Check we can safely ditch the case:
1189                    * PedanticBottoms is off,
1190                 or * the scrutinee is an already-evaluated variable
1191                 or * the scrutinee is a primop which is ok for speculation
1192                         -- ie we want to preserve divide-by-zero errors, and
1193                         -- calls to error itself!
1194
1195                 or * [Prim cases] the scrutinee is a primitive variable
1196
1197                 or * [Alg cases] the scrutinee is a variable and
1198                      either * the rhs is the same variable
1199                         (eg case x of C a b -> x  ===>   x)
1200                      or     * there is only one alternative, the default alternative,
1201                                 and the binder is used strictly in its scope.
1202                                 [NB this is helped by the "use default binder where
1203                                  possible" transformation; see below.]
1204
1205
1206 If so, then we can replace the case with one of the rhss.
1207
1208
1209 \begin{code}
1210 ---------------------------------------------------------
1211 --      Rebuiling a function with strictness info
1212
1213 rebuild_strict :: [Demand] -> Bool      -- Stricness info
1214                -> OutExpr -> OutType    -- Function and type
1215                -> SimplCont             -- Continuation
1216                -> SimplM OutExprStuff
1217
1218 rebuild_strict [] True  fun fun_ty cont = rebuild_bot fun fun_ty cont
1219 rebuild_strict [] False fun fun_ty cont = do_rebuild fun cont
1220
1221 rebuild_strict ds result_bot fun fun_ty (ApplyTo _ (Type ty_arg) se cont)
1222                                 -- Type arg; don't consume a demand
1223         = setSubstEnv se (simplType ty_arg)     `thenSmpl` \ ty_arg' ->
1224           rebuild_strict ds result_bot (App fun (Type ty_arg'))
1225                          (applyTy fun_ty ty_arg') cont
1226
1227 rebuild_strict (d:ds) result_bot fun fun_ty (ApplyTo _ val_arg se cont)
1228         | isStrict d || isUnLiftedType arg_ty   -- Strict value argument
1229         = getInScope                            `thenSmpl` \ in_scope ->
1230           let
1231                 cont_ty = contResultType in_scope res_ty cont
1232           in
1233           setSubstEnv se (simplExprB val_arg (ArgOf NoDup cont_fn cont_ty))
1234
1235         | otherwise                             -- Lazy value argument
1236         = setSubstEnv se (simplArg val_arg)     `thenSmpl` \ val_arg' ->
1237           cont_fn val_arg'
1238
1239         where
1240           Just (arg_ty, res_ty) = splitFunTy_maybe fun_ty
1241           cont_fn arg'          = rebuild_strict ds result_bot
1242                                                  (App fun arg') res_ty
1243                                                  cont
1244
1245 rebuild_strict ds result_bot fun fun_ty cont = do_rebuild fun cont
1246
1247 ---------------------------------------------------------
1248 --      Dealing with
1249 --      * case (error "hello") of { ... }
1250 --      * (error "Hello") arg
1251 --      etc
1252
1253 rebuild_bot expr expr_ty Stop                           -- No coerce needed
1254   = rebuild_done expr
1255
1256 rebuild_bot expr expr_ty (CoerceIt _ to_ty se Stop)     -- Don't "tick" on this,
1257                                                         -- else simplifier never stops
1258   = setSubstEnv se      $
1259     simplType to_ty     `thenSmpl` \ to_ty' ->
1260     rebuild_done (mkNote (Coerce to_ty' expr_ty) expr)
1261
1262 rebuild_bot expr expr_ty cont
1263   = tick CaseOfError            `thenSmpl_`
1264     getInScope                  `thenSmpl` \ in_scope ->
1265     let
1266         result_ty = contResultType in_scope expr_ty cont
1267     in
1268     rebuild_done (mkNote (Coerce result_ty expr_ty) expr)
1269 \end{code}
1270
1271 Blob of helper functions for the "case-of-something-else" situation.
1272
1273 \begin{code}
1274 ---------------------------------------------------------
1275 --      Case of something else
1276
1277 rebuild_case sw_chkr scrut case_bndr alts se cont
1278   =     -- Prepare case alternatives
1279     prepareCaseAlts (splitTyConApp_maybe (idType case_bndr))
1280                     scrut_cons alts             `thenSmpl` \ better_alts ->
1281
1282         -- Set the new subst-env in place (before dealing with the case binder)
1283     setSubstEnv se                              $
1284
1285         -- Deal with the case binder, and prepare the continuation;
1286         -- The new subst_env is in place
1287     simplBinder case_bndr                       $ \ case_bndr' ->
1288     prepareCaseCont better_alts cont            $ \ cont' ->
1289
1290
1291         -- Deal with variable scrutinee
1292     substForVarScrut scrut case_bndr'           $ \ zap_occ_info ->
1293     let
1294         case_bndr'' = zap_occ_info case_bndr'
1295     in
1296
1297         -- Deal with the case alternaatives
1298     simplAlts zap_occ_info scrut_cons
1299               case_bndr'' better_alts cont'     `thenSmpl` \ alts' ->
1300
1301     mkCase sw_chkr scrut case_bndr'' alts'      `thenSmpl` \ case_expr ->
1302     rebuild_done case_expr
1303   where
1304         -- scrut_cons tells what constructors the scrutinee can't possibly match
1305     scrut_cons = case scrut of
1306                    Var v -> case getIdUnfolding v of
1307                                 OtherCon cons -> cons
1308                                 other         -> []
1309                    other -> []
1310
1311
1312 knownCon expr con args (Select _ bndr alts se cont)
1313   = tick KnownBranch            `thenSmpl_`
1314     setSubstEnv se              (
1315     case findAlt con alts of
1316         (DEFAULT, bs, rhs)     -> ASSERT( null bs )
1317                                   completeBindNonRec bndr expr $
1318                                   simplExprB rhs cont
1319
1320         (Literal lit, bs, rhs) -> ASSERT( null bs )
1321                                   extendIdSubst bndr (Done expr)        $
1322                                         -- Unconditionally substitute, because expr must
1323                                         -- be a variable or a literal.  It can't be a
1324                                         -- NoRep literal because they don't occur in
1325                                         -- case patterns.
1326                                   simplExprB rhs cont
1327
1328         (DataCon dc, bs, rhs)  -> completeBindNonRec bndr expr          $
1329                                   extend bs real_args                   $
1330                                   simplExprB rhs cont
1331                                where
1332                                   real_args = drop (dataConNumInstArgs dc) args
1333     )
1334   where
1335     extend []     []         thing_inside = thing_inside
1336     extend (b:bs) (arg:args) thing_inside = extendIdSubst b (Done arg)  $
1337                                             extend bs args thing_inside
1338 \end{code}
1339
1340 \begin{code}
1341 prepareCaseCont :: [InAlt] -> SimplCont
1342                 -> (SimplCont -> SimplM (OutStuff a))
1343                 -> SimplM (OutStuff a)
1344         -- Polymorphic recursion here!
1345
1346 prepareCaseCont [alt] cont thing_inside = thing_inside cont
1347 prepareCaseCont alts  cont thing_inside = mkDupableCont (coreAltsType alts) cont thing_inside
1348 \end{code}
1349
1350 substForVarScrut checks whether the scrutinee is a variable, v.
1351 If so, try to eliminate uses of v in the RHSs in favour of case_bndr;
1352 that way, there's a chance that v will now only be used once, and hence inlined.
1353
1354 If we do this, then we have to nuke any occurrence info (eg IAmDead)
1355 in the case binder, because the case-binder now effectively occurs
1356 whenever v does.  AND we have to do the same for the pattern-bound
1357 variables!  Example:
1358
1359         (case x of { (a,b) -> a }) (case x of { (p,q) -> q })
1360
1361 Here, b and p are dead.  But when we move the argment inside the first
1362 case RHS, and eliminate the second case, we get
1363
1364         case x or { (a,b) -> a b
1365
1366 Urk! b is alive!  Reason: the scrutinee was a variable, and case elimination
1367 happened.  Hence the zap_occ_info function returned by substForVarScrut
1368
1369 \begin{code}
1370 substForVarScrut (Var v) case_bndr' thing_inside
1371   | isLocallyDefined v          -- No point for imported things
1372   = modifyInScope (v `setIdUnfolding` mkUnfolding (Var case_bndr')
1373                      `setInlinePragma` IMustBeINLINEd)                  $
1374         -- We could extend the substitution instead, but it would be
1375         -- a hack because then the substitution wouldn't be idempotent
1376         -- any more.
1377     thing_inside (\ bndr ->  bndr `setInlinePragma` NoInlinePragInfo)
1378
1379 substForVarScrut other_scrut case_bndr' thing_inside
1380   = thing_inside (\ bndr -> bndr)       -- NoOp on bndr
1381 \end{code}
1382
1383 prepareCaseAlts does two things:
1384
1385 1.  Remove impossible alternatives
1386
1387 2.  If the DEFAULT alternative can match only one possible constructor,
1388     then make that constructor explicit.
1389     e.g.
1390         case e of x { DEFAULT -> rhs }
1391      ===>
1392         case e of x { (a,b) -> rhs }
1393     where the type is a single constructor type.  This gives better code
1394     when rhs also scrutinises x or e.
1395
1396 \begin{code}
1397 prepareCaseAlts (Just (tycon, inst_tys)) scrut_cons alts
1398   | isDataTyCon tycon
1399   = case (findDefault filtered_alts, missing_cons) of
1400
1401         ((alts_no_deflt, Just rhs), [data_con])         -- Just one missing constructor!
1402                 -> tick FillInCaseDefault       `thenSmpl_`
1403                    let
1404                         (_,_,ex_tyvars,_,_,_) = dataConSig data_con
1405                    in
1406                    getUniquesSmpl (length ex_tyvars)                            `thenSmpl` \ tv_uniqs ->
1407                    let
1408                         ex_tyvars' = zipWithEqual "simpl_alt" mk tv_uniqs ex_tyvars
1409                         mk uniq tv = mkSysTyVar uniq (tyVarKind tv)
1410                    in
1411                    newIds (dataConArgTys
1412                                 data_con
1413                                 (inst_tys ++ mkTyVarTys ex_tyvars'))            $ \ bndrs ->
1414                    returnSmpl ((DataCon data_con, ex_tyvars' ++ bndrs, rhs) : alts_no_deflt)
1415
1416         other -> returnSmpl filtered_alts
1417   where
1418         -- Filter out alternatives that can't possibly match
1419     filtered_alts = case scrut_cons of
1420                         []    -> alts
1421                         other -> [alt | alt@(con,_,_) <- alts, not (con `elem` scrut_cons)]
1422
1423     missing_cons = [data_con | data_con <- tyConDataCons tycon,
1424                                not (data_con `elem` handled_data_cons)]
1425     handled_data_cons = [data_con | DataCon data_con         <- scrut_cons] ++
1426                         [data_con | (DataCon data_con, _, _) <- filtered_alts]
1427
1428 -- The default case
1429 prepareCaseAlts _ scrut_cons alts
1430   = returnSmpl alts                     -- Functions
1431
1432
1433 ----------------------
1434 simplAlts zap_occ_info scrut_cons case_bndr'' alts cont'
1435   = mapSmpl simpl_alt alts
1436   where
1437     inst_tys' = case splitTyConApp_maybe (idType case_bndr'') of
1438                         Just (tycon, inst_tys) -> inst_tys
1439
1440         -- handled_cons is all the constructors that are dealt
1441         -- with, either by being impossible, or by there being an alternative
1442     handled_cons = scrut_cons ++ [con | (con,_,_) <- alts, con /= DEFAULT]
1443
1444     simpl_alt (DEFAULT, _, rhs)
1445         =       -- In the default case we record the constructors that the
1446                 -- case-binder *can't* be.
1447                 -- We take advantage of any OtherCon info in the case scrutinee
1448           modifyInScope (case_bndr'' `setIdUnfolding` OtherCon handled_cons)    $
1449           simplExpr rhs cont'                                                   `thenSmpl` \ rhs' ->
1450           returnSmpl (DEFAULT, [], rhs')
1451
1452     simpl_alt (con, vs, rhs)
1453         =       -- Deal with the pattern-bound variables
1454                 -- Mark the ones that are in ! positions in the data constructor
1455                 -- as certainly-evaluated
1456           simplBinders (add_evals con vs)       $ \ vs' ->
1457
1458                 -- Bind the case-binder to (Con args)
1459           let
1460                 con_app = Con con (map Type inst_tys' ++ map varToCoreExpr vs')
1461           in
1462           modifyInScope (case_bndr'' `setIdUnfolding` mkUnfolding con_app)      $
1463           simplExpr rhs cont'           `thenSmpl` \ rhs' ->
1464           returnSmpl (con, vs', rhs')
1465
1466
1467         -- add_evals records the evaluated-ness of the bound variables of
1468         -- a case pattern.  This is *important*.  Consider
1469         --      data T = T !Int !Int
1470         --
1471         --      case x of { T a b -> T (a+1) b }
1472         --
1473         -- We really must record that b is already evaluated so that we don't
1474         -- go and re-evaluated it when constructing the result.
1475
1476     add_evals (DataCon dc) vs = stretchZipEqual add_eval vs (dataConStrictMarks dc)
1477     add_evals other_con    vs = vs
1478
1479     add_eval v m | isTyVar v = Nothing
1480                  | otherwise = case m of
1481                                   MarkedStrict    -> Just (zap_occ_info v `setIdUnfolding` OtherCon [])
1482                                   NotMarkedStrict -> Just (zap_occ_info v)
1483 \end{code}
1484
1485
1486
1487
1488 %************************************************************************
1489 %*                                                                      *
1490 \subsection{Duplicating continuations}
1491 %*                                                                      *
1492 %************************************************************************
1493
1494 \begin{code}
1495 mkDupableCont :: InType         -- Type of the thing to be given to the continuation
1496               -> SimplCont
1497               -> (SimplCont -> SimplM (OutStuff a))
1498               -> SimplM (OutStuff a)
1499 mkDupableCont ty cont thing_inside
1500   | contIsDupable cont
1501   = thing_inside cont
1502
1503 mkDupableCont _ (CoerceIt _ ty se cont) thing_inside
1504   = mkDupableCont ty cont               $ \ cont' ->
1505     thing_inside (CoerceIt OkToDup ty se cont')
1506
1507 mkDupableCont join_arg_ty (ArgOf _ cont_fn res_ty) thing_inside
1508   =     -- Build the RHS of the join point
1509     simplType join_arg_ty                               `thenSmpl` \ join_arg_ty' ->
1510     newId join_arg_ty'                                  ( \ arg_id ->
1511         getSwitchChecker                                `thenSmpl` \ chkr ->
1512         cont_fn (Var arg_id)                            `thenSmpl` \ (binds, (_, rhs)) ->
1513         returnSmpl (Lam arg_id (mkLetBinds binds rhs))
1514     )                                                   `thenSmpl` \ join_rhs ->
1515
1516         -- Build the join Id and continuation
1517     newId (coreExprType join_rhs)               $ \ join_id ->
1518     let
1519         new_cont = ArgOf OkToDup
1520                          (\arg' -> rebuild_done (App (Var join_id) arg'))
1521                          res_ty
1522     in
1523
1524         -- Do the thing inside
1525     thing_inside new_cont               `thenSmpl` \ res ->
1526     returnSmpl (addBind (NonRec join_id join_rhs) res)
1527
1528 mkDupableCont ty (ApplyTo _ arg se cont) thing_inside
1529   = mkDupableCont (funResultTy ty) cont                 $ \ cont' ->
1530     setSubstEnv se (simplArg arg)                       `thenSmpl` \ arg' ->
1531     if exprIsDupable arg' then
1532         thing_inside (ApplyTo OkToDup arg' emptySubstEnv cont')
1533     else
1534     newId (coreExprType arg')                                           $ \ bndr ->
1535     thing_inside (ApplyTo OkToDup (Var bndr) emptySubstEnv cont')       `thenSmpl` \ res ->
1536     returnSmpl (addBind (NonRec bndr arg') res)
1537
1538 mkDupableCont ty (Select _ case_bndr alts se cont) thing_inside
1539   = tick CaseOfCase                                             `thenSmpl_` (
1540     setSubstEnv se      (
1541         simplBinder case_bndr                                   $ \ case_bndr' ->
1542         prepareCaseCont alts cont                               $ \ cont' ->
1543         mapAndUnzipSmpl (mkDupableAlt case_bndr' cont') alts    `thenSmpl` \ (alt_binds_s, alts') ->
1544         returnSmpl (concat alt_binds_s, (case_bndr', alts'))
1545     )                                   `thenSmpl` \ (alt_binds, (case_bndr', alts')) ->
1546
1547     extendInScopes [b | NonRec b _ <- alt_binds]                        $
1548     thing_inside (Select OkToDup case_bndr' alts' emptySubstEnv Stop)   `thenSmpl` \ res ->
1549     returnSmpl (addBinds alt_binds res)
1550     )
1551
1552 mkDupableAlt :: OutId -> SimplCont -> InAlt -> SimplM (OutStuff CoreAlt)
1553 mkDupableAlt case_bndr' cont alt@(con, bndrs, rhs)
1554   = simplBinders bndrs                                  $ \ bndrs' ->
1555     simplExpr rhs cont                                  `thenSmpl` \ rhs' ->
1556     if exprIsDupable rhs' then
1557         -- It's small, so don't bother to let-bind it
1558         returnSmpl ([], (con, bndrs', rhs'))
1559     else
1560         -- It's big, so let-bind it
1561     let
1562         rhs_ty' = coreExprType rhs'
1563         used_bndrs' = filter (not . isDeadBinder) (case_bndr' : bndrs')
1564     in
1565     ( if null used_bndrs' && isUnLiftedType rhs_ty'
1566         then newId realWorldStatePrimTy  $ \ rw_id ->
1567              returnSmpl ([rw_id], [varToCoreExpr realWorldPrimId])
1568         else
1569              returnSmpl (used_bndrs', map varToCoreExpr used_bndrs')
1570     )
1571         `thenSmpl` \ (final_bndrs', final_args) ->
1572
1573         -- If we try to lift a primitive-typed something out
1574         -- for let-binding-purposes, we will *caseify* it (!),
1575         -- with potentially-disastrous strictness results.  So
1576         -- instead we turn it into a function: \v -> e
1577         -- where v::State# RealWorld#.  The value passed to this function
1578         -- is realworld#, which generates (almost) no code.
1579
1580         -- There's a slight infelicity here: we pass the overall
1581         -- case_bndr to all the join points if it's used in *any* RHS,
1582         -- because we don't know its usage in each RHS separately
1583
1584     newId (foldr (mkFunTy . idType) rhs_ty' final_bndrs')       $ \ join_bndr ->
1585     returnSmpl ([NonRec join_bndr (mkLams final_bndrs' rhs')],
1586                 (con, bndrs', mkApps (Var join_bndr) final_args))
1587 \end{code}