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