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   = 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         final_bndr = bndr_w_unfolding `setIdSpecialisation` spec_env'
 781     in
 782     returnSmpl final_bndr
 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     case expr of
1036         Var v -> case getIdStrictness v of
1037                     NoStrictnessInfo                    -> do_rebuild expr cont
1038                     StrictnessInfo demands result_bot _ -> ASSERT( not (null demands) || result_bot )
1039                                                                 -- If this happened we'd get an infinite loop
1040                                                            rebuild_strict demands result_bot expr (idType v) cont
1041         other  -> do_rebuild expr cont
1042
1043 rebuild_done expr
1044   = getInScope                  `thenSmpl` \ in_scope ->
1045     returnSmpl ([], (in_scope, expr))
1046
1047 ---------------------------------------------------------
1048 --      Stop continuation
1049
1050 do_rebuild expr Stop = rebuild_done expr
1051
1052
1053 ---------------------------------------------------------
1054 --      ArgOf continuation
1055
1056 do_rebuild expr (ArgOf _ cont_fn _) = cont_fn expr
1057
1058 ---------------------------------------------------------
1059 --      ApplyTo continuation
1060
1061 do_rebuild expr cont@(ApplyTo _ arg se cont')
1062   = setSubstEnv se (simplArg arg)       `thenSmpl` \ arg' ->
1063     do_rebuild (App expr arg') cont'
1064
1065
1066 ---------------------------------------------------------
1067 --      Coerce continuation
1068
1069 do_rebuild expr (CoerceIt _ to_ty se cont)
1070   = setSubstEnv se      $
1071     simplType to_ty     `thenSmpl` \ to_ty' ->
1072     do_rebuild (mk_coerce to_ty' expr) cont
1073
1074
1075 ---------------------------------------------------------
1076 --      Case of known constructor or literal
1077
1078 do_rebuild expr@(Con con args) cont@(Select _ _ _ _ _)
1079   | conOkForAlt con     -- Knocks out PrimOps and NoRepLits
1080   = knownCon expr con args cont
1081
1082
1083 ---------------------------------------------------------
1084
1085 --      Case of other value (e.g. a partial application or lambda)
1086 --      Turn it back into a let
1087
1088 do_rebuild expr (Select _ bndr ((DEFAULT, bs, rhs):alts) se cont)
1089   | case mkFormSummary expr of { ValueForm -> True; other -> False }
1090   = ASSERT( null bs && null alts )
1091     tick Case2Let               `thenSmpl_`
1092     setSubstEnv se              (
1093     completeBindNonRec bndr expr        $
1094     simplExprB rhs cont
1095     )
1096
1097
1098 ---------------------------------------------------------
1099 --      The other Select cases
1100
1101 do_rebuild scrut (Select _ bndr alts se cont)
1102   = getSwitchChecker                                    `thenSmpl` \ chkr ->
1103
1104     if all (cheapEqExpr rhs1) other_rhss
1105        && inlineCase bndr scrut
1106        && all binders_unused alts
1107        && switchIsOn chkr SimplDoCaseElim
1108     then
1109         -- Get rid of the case altogether
1110         -- See the extensive notes on case-elimination below
1111         -- Remember to bind the binder though!
1112             tick  CaseElim              `thenSmpl_`
1113             setSubstEnv se                      (
1114             extendIdSubst bndr (Done scrut)     $
1115             simplExprB rhs1 cont
1116             )
1117
1118     else
1119         rebuild_case chkr scrut bndr alts se cont
1120   where
1121     (rhs1:other_rhss)            = [rhs | (_,_,rhs) <- alts]
1122     binders_unused (_, bndrs, _) = all isDeadBinder bndrs
1123 \end{code}
1124
1125 Case elimination [see the code above]
1126 ~~~~~~~~~~~~~~~~
1127 Start with a simple situation:
1128
1129         case x# of      ===>   e[x#/y#]
1130           y# -> e
1131
1132 (when x#, y# are of primitive type, of course).  We can't (in general)
1133 do this for algebraic cases, because we might turn bottom into
1134 non-bottom!
1135
1136 Actually, we generalise this idea to look for a case where we're
1137 scrutinising a variable, and we know that only the default case can
1138 match.  For example:
1139 \begin{verbatim}
1140         case x of
1141           0#    -> ...
1142           other -> ...(case x of
1143                          0#    -> ...
1144                          other -> ...) ...
1145 \end{code}
1146 Here the inner case can be eliminated.  This really only shows up in
1147 eliminating error-checking code.
1148
1149 We also make sure that we deal with this very common case:
1150
1151         case e of
1152           x -> ...x...
1153
1154 Here we are using the case as a strict let; if x is used only once
1155 then we want to inline it.  We have to be careful that this doesn't
1156 make the program terminate when it would have diverged before, so we
1157 check that
1158         - x is used strictly, or
1159         - e is already evaluated (it may so if e is a variable)
1160
1161 Lastly, we generalise the transformation to handle this:
1162
1163         case e of       ===> r
1164            True  -> r
1165            False -> r
1166
1167 We only do this for very cheaply compared r's (constructors, literals
1168 and variables).  If pedantic bottoms is on, we only do it when the
1169 scrutinee is a PrimOp which can't fail.
1170
1171 We do it *here*, looking at un-simplified alternatives, because we
1172 have to check that r doesn't mention the variables bound by the
1173 pattern in each alternative, so the binder-info is rather useful.
1174
1175 So the case-elimination algorithm is:
1176
1177         1. Eliminate alternatives which can't match
1178
1179         2. Check whether all the remaining alternatives
1180                 (a) do not mention in their rhs any of the variables bound in their pattern
1181            and  (b) have equal rhss
1182
1183         3. Check we can safely ditch the case:
1184                    * PedanticBottoms is off,
1185                 or * the scrutinee is an already-evaluated variable
1186                 or * the scrutinee is a primop which is ok for speculation
1187                         -- ie we want to preserve divide-by-zero errors, and
1188                         -- calls to error itself!
1189
1190                 or * [Prim cases] the scrutinee is a primitive variable
1191
1192                 or * [Alg cases] the scrutinee is a variable and
1193                      either * the rhs is the same variable
1194                         (eg case x of C a b -> x  ===>   x)
1195                      or     * there is only one alternative, the default alternative,
1196                                 and the binder is used strictly in its scope.
1197                                 [NB this is helped by the "use default binder where
1198                                  possible" transformation; see below.]
1199
1200
1201 If so, then we can replace the case with one of the rhss.
1202
1203
1204 \begin{code}
1205 ---------------------------------------------------------
1206 --      Rebuiling a function with strictness info
1207 --      This just a version of do_rebuild, enhanced with info about
1208 --      the strictness of the thing being rebuilt.
1209
1210 rebuild_strict :: [Demand] -> Bool      -- Stricness info
1211                -> OutExpr -> OutType    -- Function and type
1212                -> SimplCont             -- Continuation
1213                -> SimplM OutExprStuff
1214
1215 rebuild_strict [] True  fun fun_ty cont = rebuild_bot fun fun_ty cont
1216 rebuild_strict [] False fun fun_ty cont = do_rebuild fun cont
1217
1218 rebuild_strict ds result_bot fun fun_ty (CoerceIt _ to_ty se cont)
1219         = setSubstEnv se        $
1220           simplType to_ty       `thenSmpl` \ to_ty' ->
1221           rebuild_strict ds result_bot (mk_coerce to_ty' fun) to_ty' cont
1222
1223 rebuild_strict ds result_bot fun fun_ty (ApplyTo _ (Type ty_arg) se cont)
1224                                 -- Type arg; don't consume a demand
1225         = setSubstEnv se (simplType ty_arg)     `thenSmpl` \ ty_arg' ->
1226           rebuild_strict ds result_bot (App fun (Type ty_arg'))
1227                          (applyTy fun_ty ty_arg') cont
1228
1229 rebuild_strict (d:ds) result_bot fun fun_ty (ApplyTo _ val_arg se cont)
1230         | isStrict d || isUnLiftedType arg_ty
1231                                 -- Strict value argument
1232         = getInScope                            `thenSmpl` \ in_scope ->
1233           let
1234                 cont_ty = contResultType in_scope res_ty cont
1235           in
1236           setSubstEnv se (simplExprB val_arg (ArgOf NoDup cont_fn cont_ty))
1237
1238         | otherwise                             -- Lazy value argument
1239         = setSubstEnv se (simplArg val_arg)     `thenSmpl` \ val_arg' ->
1240           cont_fn val_arg'
1241
1242         where
1243           Just (arg_ty, res_ty) = splitFunTy_maybe fun_ty
1244           cont_fn arg'          = rebuild_strict ds result_bot
1245                                                  (App fun arg') res_ty
1246                                                  cont
1247
1248 rebuild_strict ds result_bot fun fun_ty cont = do_rebuild fun cont
1249
1250 ---------------------------------------------------------
1251 --      Dealing with
1252 --      * case (error "hello") of { ... }
1253 --      * (error "Hello") arg
1254 --      * f (error "Hello") where f is strict
1255 --      etc
1256
1257 rebuild_bot expr expr_ty Stop                           -- No coerce needed
1258   = rebuild_done expr
1259
1260 rebuild_bot expr expr_ty (CoerceIt _ to_ty se Stop)     -- Don't "tick" on this,
1261                                                         -- else simplifier never stops
1262   = setSubstEnv se      $
1263     simplType to_ty     `thenSmpl` \ to_ty' ->
1264     rebuild_done (mkNote (Coerce to_ty' expr_ty) expr)
1265
1266 rebuild_bot expr expr_ty cont                           -- Abandon the (strict) continuation,
1267                                                         -- and just return expr
1268   = tick CaseOfError            `thenSmpl_`
1269     getInScope                  `thenSmpl` \ in_scope ->
1270     let
1271         result_ty = contResultType in_scope expr_ty cont
1272     in
1273     rebuild_done (mkNote (Coerce result_ty expr_ty) expr)
1274
1275 mk_coerce to_ty (Note (Coerce _ from_ty) expr) = Note (Coerce to_ty from_ty) expr
1276 mk_coerce to_ty expr                           = Note (Coerce to_ty (coreExprType expr)) expr
1277 \end{code}
1278
1279 Blob of helper functions for the "case-of-something-else" situation.
1280
1281 \begin{code}
1282 ---------------------------------------------------------
1283 --      Case of something else
1284
1285 rebuild_case sw_chkr scrut case_bndr alts se cont
1286   =     -- Prepare case alternatives
1287     prepareCaseAlts (splitTyConApp_maybe (idType case_bndr))
1288                     scrut_cons alts             `thenSmpl` \ better_alts ->
1289
1290         -- Set the new subst-env in place (before dealing with the case binder)
1291     setSubstEnv se                              $
1292
1293         -- Deal with the case binder, and prepare the continuation;
1294         -- The new subst_env is in place
1295     simplBinder case_bndr                       $ \ case_bndr' ->
1296     prepareCaseCont better_alts cont            $ \ cont' ->
1297
1298
1299         -- Deal with variable scrutinee
1300     substForVarScrut scrut case_bndr'           $ \ zap_occ_info ->
1301     let
1302         case_bndr'' = zap_occ_info case_bndr'
1303     in
1304
1305         -- Deal with the case alternaatives
1306     simplAlts zap_occ_info scrut_cons
1307               case_bndr'' better_alts cont'     `thenSmpl` \ alts' ->
1308
1309     mkCase sw_chkr scrut case_bndr'' alts'      `thenSmpl` \ case_expr ->
1310     rebuild_done case_expr
1311   where
1312         -- scrut_cons tells what constructors the scrutinee can't possibly match
1313     scrut_cons = case scrut of
1314                    Var v -> case getIdUnfolding v of
1315                                 OtherCon cons -> cons
1316                                 other         -> []
1317                    other -> []
1318
1319
1320 knownCon expr con args (Select _ bndr alts se cont)
1321   = tick KnownBranch            `thenSmpl_`
1322     setSubstEnv se              (
1323     case findAlt con alts of
1324         (DEFAULT, bs, rhs)     -> ASSERT( null bs )
1325                                   completeBindNonRec bndr expr $
1326                                   simplExprB rhs cont
1327
1328         (Literal lit, bs, rhs) -> ASSERT( null bs )
1329                                   extendIdSubst bndr (Done expr)        $
1330                                         -- Unconditionally substitute, because expr must
1331                                         -- be a variable or a literal.  It can't be a
1332                                         -- NoRep literal because they don't occur in
1333                                         -- case patterns.
1334                                   simplExprB rhs cont
1335
1336         (DataCon dc, bs, rhs)  -> completeBindNonRec bndr expr          $
1337                                   extend bs real_args                   $
1338                                   simplExprB rhs cont
1339                                where
1340                                   real_args = drop (dataConNumInstArgs dc) args
1341     )
1342   where
1343     extend []     []         thing_inside = thing_inside
1344     extend (b:bs) (arg:args) thing_inside = extendIdSubst b (Done arg)  $
1345                                             extend bs args thing_inside
1346 \end{code}
1347
1348 \begin{code}
1349 prepareCaseCont :: [InAlt] -> SimplCont
1350                 -> (SimplCont -> SimplM (OutStuff a))
1351                 -> SimplM (OutStuff a)
1352         -- Polymorphic recursion here!
1353
1354 prepareCaseCont [alt] cont thing_inside = thing_inside cont
1355 prepareCaseCont alts  cont thing_inside = mkDupableCont (coreAltsType alts) cont thing_inside
1356 \end{code}
1357
1358 substForVarScrut checks whether the scrutinee is a variable, v.
1359 If so, try to eliminate uses of v in the RHSs in favour of case_bndr;
1360 that way, there's a chance that v will now only be used once, and hence inlined.
1361
1362 If we do this, then we have to nuke any occurrence info (eg IAmDead)
1363 in the case binder, because the case-binder now effectively occurs
1364 whenever v does.  AND we have to do the same for the pattern-bound
1365 variables!  Example:
1366
1367         (case x of { (a,b) -> a }) (case x of { (p,q) -> q })
1368
1369 Here, b and p are dead.  But when we move the argment inside the first
1370 case RHS, and eliminate the second case, we get
1371
1372         case x or { (a,b) -> a b
1373
1374 Urk! b is alive!  Reason: the scrutinee was a variable, and case elimination
1375 happened.  Hence the zap_occ_info function returned by substForVarScrut
1376
1377 \begin{code}
1378 substForVarScrut (Var v) case_bndr' thing_inside
1379   | isLocallyDefined v          -- No point for imported things
1380   = modifyInScope (v `setIdUnfolding` mkUnfolding (Var case_bndr')
1381                      `setInlinePragma` IMustBeINLINEd)                  $
1382         -- We could extend the substitution instead, but it would be
1383         -- a hack because then the substitution wouldn't be idempotent
1384         -- any more.
1385     thing_inside (\ bndr ->  bndr `setInlinePragma` NoInlinePragInfo)
1386
1387 substForVarScrut other_scrut case_bndr' thing_inside
1388   = thing_inside (\ bndr -> bndr)       -- NoOp on bndr
1389 \end{code}
1390
1391 prepareCaseAlts does two things:
1392
1393 1.  Remove impossible alternatives
1394
1395 2.  If the DEFAULT alternative can match only one possible constructor,
1396     then make that constructor explicit.
1397     e.g.
1398         case e of x { DEFAULT -> rhs }
1399      ===>
1400         case e of x { (a,b) -> rhs }
1401     where the type is a single constructor type.  This gives better code
1402     when rhs also scrutinises x or e.
1403
1404 \begin{code}
1405 prepareCaseAlts (Just (tycon, inst_tys)) scrut_cons alts
1406   | isDataTyCon tycon
1407   = case (findDefault filtered_alts, missing_cons) of
1408
1409         ((alts_no_deflt, Just rhs), [data_con])         -- Just one missing constructor!
1410                 -> tick FillInCaseDefault       `thenSmpl_`
1411                    let
1412                         (_,_,ex_tyvars,_,_,_) = dataConSig data_con
1413                    in
1414                    getUniquesSmpl (length ex_tyvars)                            `thenSmpl` \ tv_uniqs ->
1415                    let
1416                         ex_tyvars' = zipWithEqual "simpl_alt" mk tv_uniqs ex_tyvars
1417                         mk uniq tv = mkSysTyVar uniq (tyVarKind tv)
1418                    in
1419                    newIds (dataConArgTys
1420                                 data_con
1421                                 (inst_tys ++ mkTyVarTys ex_tyvars'))            $ \ bndrs ->
1422                    returnSmpl ((DataCon data_con, ex_tyvars' ++ bndrs, rhs) : alts_no_deflt)
1423
1424         other -> returnSmpl filtered_alts
1425   where
1426         -- Filter out alternatives that can't possibly match
1427     filtered_alts = case scrut_cons of
1428                         []    -> alts
1429                         other -> [alt | alt@(con,_,_) <- alts, not (con `elem` scrut_cons)]
1430
1431     missing_cons = [data_con | data_con <- tyConDataCons tycon,
1432                                not (data_con `elem` handled_data_cons)]
1433     handled_data_cons = [data_con | DataCon data_con         <- scrut_cons] ++
1434                         [data_con | (DataCon data_con, _, _) <- filtered_alts]
1435
1436 -- The default case
1437 prepareCaseAlts _ scrut_cons alts
1438   = returnSmpl alts                     -- Functions
1439
1440
1441 ----------------------
1442 simplAlts zap_occ_info scrut_cons case_bndr'' alts cont'
1443   = mapSmpl simpl_alt alts
1444   where
1445     inst_tys' = case splitTyConApp_maybe (idType case_bndr'') of
1446                         Just (tycon, inst_tys) -> inst_tys
1447
1448         -- handled_cons is all the constructors that are dealt
1449         -- with, either by being impossible, or by there being an alternative
1450     handled_cons = scrut_cons ++ [con | (con,_,_) <- alts, con /= DEFAULT]
1451
1452     simpl_alt (DEFAULT, _, rhs)
1453         =       -- In the default case we record the constructors that the
1454                 -- case-binder *can't* be.
1455                 -- We take advantage of any OtherCon info in the case scrutinee
1456           modifyInScope (case_bndr'' `setIdUnfolding` OtherCon handled_cons)    $
1457           simplExpr rhs cont'                                                   `thenSmpl` \ rhs' ->
1458           returnSmpl (DEFAULT, [], rhs')
1459
1460     simpl_alt (con, vs, rhs)
1461         =       -- Deal with the pattern-bound variables
1462                 -- Mark the ones that are in ! positions in the data constructor
1463                 -- as certainly-evaluated
1464           simplBinders (add_evals con vs)       $ \ vs' ->
1465
1466                 -- Bind the case-binder to (Con args)
1467           let
1468                 con_app = Con con (map Type inst_tys' ++ map varToCoreExpr vs')
1469           in
1470           modifyInScope (case_bndr'' `setIdUnfolding` mkUnfolding con_app)      $
1471           simplExpr rhs cont'           `thenSmpl` \ rhs' ->
1472           returnSmpl (con, vs', rhs')
1473
1474
1475         -- add_evals records the evaluated-ness of the bound variables of
1476         -- a case pattern.  This is *important*.  Consider
1477         --      data T = T !Int !Int
1478         --
1479         --      case x of { T a b -> T (a+1) b }
1480         --
1481         -- We really must record that b is already evaluated so that we don't
1482         -- go and re-evaluated it when constructing the result.
1483
1484     add_evals (DataCon dc) vs = stretchZipEqual add_eval vs (dataConStrictMarks dc)
1485     add_evals other_con    vs = vs
1486
1487     add_eval v m | isTyVar v = Nothing
1488                  | otherwise = case m of
1489                                   MarkedStrict    -> Just (zap_occ_info v `setIdUnfolding` OtherCon [])
1490                                   NotMarkedStrict -> Just (zap_occ_info v)
1491 \end{code}
1492
1493
1494
1495
1496 %************************************************************************
1497 %*                                                                      *
1498 \subsection{Duplicating continuations}
1499 %*                                                                      *
1500 %************************************************************************
1501
1502 \begin{code}
1503 mkDupableCont :: InType         -- Type of the thing to be given to the continuation
1504               -> SimplCont
1505               -> (SimplCont -> SimplM (OutStuff a))
1506               -> SimplM (OutStuff a)
1507 mkDupableCont ty cont thing_inside
1508   | contIsDupable cont
1509   = thing_inside cont
1510
1511 mkDupableCont _ (CoerceIt _ ty se cont) thing_inside
1512   = mkDupableCont ty cont               $ \ cont' ->
1513     thing_inside (CoerceIt OkToDup ty se cont')
1514
1515 mkDupableCont join_arg_ty (ArgOf _ cont_fn res_ty) thing_inside
1516   =     -- Build the RHS of the join point
1517     simplType join_arg_ty                               `thenSmpl` \ join_arg_ty' ->
1518     newId join_arg_ty'                                  ( \ arg_id ->
1519         getSwitchChecker                                `thenSmpl` \ chkr ->
1520         cont_fn (Var arg_id)                            `thenSmpl` \ (binds, (_, rhs)) ->
1521         returnSmpl (Lam arg_id (mkLetBinds binds rhs))
1522     )                                                   `thenSmpl` \ join_rhs ->
1523
1524         -- Build the join Id and continuation
1525     newId (coreExprType join_rhs)               $ \ join_id ->
1526     let
1527         new_cont = ArgOf OkToDup
1528                          (\arg' -> rebuild_done (App (Var join_id) arg'))
1529                          res_ty
1530     in
1531
1532         -- Do the thing inside
1533     thing_inside new_cont               `thenSmpl` \ res ->
1534     returnSmpl (addBind (NonRec join_id join_rhs) res)
1535
1536 mkDupableCont ty (ApplyTo _ arg se cont) thing_inside
1537   = mkDupableCont (funResultTy ty) cont                 $ \ cont' ->
1538     setSubstEnv se (simplArg arg)                       `thenSmpl` \ arg' ->
1539     if exprIsDupable arg' then
1540         thing_inside (ApplyTo OkToDup arg' emptySubstEnv cont')
1541     else
1542     newId (coreExprType arg')                                           $ \ bndr ->
1543     thing_inside (ApplyTo OkToDup (Var bndr) emptySubstEnv cont')       `thenSmpl` \ res ->
1544     returnSmpl (addBind (NonRec bndr arg') res)
1545
1546 mkDupableCont ty (Select _ case_bndr alts se cont) thing_inside
1547   = tick CaseOfCase                                             `thenSmpl_` (
1548     setSubstEnv se      (
1549         simplBinder case_bndr                                   $ \ case_bndr' ->
1550         prepareCaseCont alts cont                               $ \ cont' ->
1551         mapAndUnzipSmpl (mkDupableAlt case_bndr' cont') alts    `thenSmpl` \ (alt_binds_s, alts') ->
1552         returnSmpl (concat alt_binds_s, (case_bndr', alts'))
1553     )                                   `thenSmpl` \ (alt_binds, (case_bndr', alts')) ->
1554
1555     extendInScopes [b | NonRec b _ <- alt_binds]                        $
1556     thing_inside (Select OkToDup case_bndr' alts' emptySubstEnv Stop)   `thenSmpl` \ res ->
1557     returnSmpl (addBinds alt_binds res)
1558     )
1559
1560 mkDupableAlt :: OutId -> SimplCont -> InAlt -> SimplM (OutStuff CoreAlt)
1561 mkDupableAlt case_bndr' cont alt@(con, bndrs, rhs)
1562   = simplBinders bndrs                                  $ \ bndrs' ->
1563     simplExpr rhs cont                                  `thenSmpl` \ rhs' ->
1564     if exprIsDupable rhs' then
1565         -- It's small, so don't bother to let-bind it
1566         returnSmpl ([], (con, bndrs', rhs'))
1567     else
1568         -- It's big, so let-bind it
1569     let
1570         rhs_ty' = coreExprType rhs'
1571         used_bndrs' = filter (not . isDeadBinder) (case_bndr' : bndrs')
1572     in
1573     ( if null used_bndrs' && isUnLiftedType rhs_ty'
1574         then newId realWorldStatePrimTy  $ \ rw_id ->
1575              returnSmpl ([rw_id], [varToCoreExpr realWorldPrimId])
1576         else
1577              returnSmpl (used_bndrs', map varToCoreExpr used_bndrs')
1578     )
1579         `thenSmpl` \ (final_bndrs', final_args) ->
1580
1581         -- If we try to lift a primitive-typed something out
1582         -- for let-binding-purposes, we will *caseify* it (!),
1583         -- with potentially-disastrous strictness results.  So
1584         -- instead we turn it into a function: \v -> e
1585         -- where v::State# RealWorld#.  The value passed to this function
1586         -- is realworld#, which generates (almost) no code.
1587
1588         -- There's a slight infelicity here: we pass the overall
1589         -- case_bndr to all the join points if it's used in *any* RHS,
1590         -- because we don't know its usage in each RHS separately
1591
1592     newId (foldr (mkFunTy . idType) rhs_ty' final_bndrs')       $ \ join_bndr ->
1593     returnSmpl ([NonRec join_bndr (mkLams final_bndrs' rhs')],
1594                 (con, bndrs', mkApps (Var join_bndr) final_args))
1595 \end{code}