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