ghc/compiler/simplCore/Simplify.lhs

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