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