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