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 ( simplTopBinds, simplExpr ) where
   8
   9 #include "HsVersions.h"
  10
  11 import CmdLineOpts      ( intSwitchSet,
  12                           opt_SccProfilingOn, opt_PprStyle_Debug, opt_SimplDoEtaReduction,
  13                           opt_SimplNoPreInlining, opt_DictsStrict, opt_SimplPedanticBottoms,
  14                           SimplifierSwitch(..)
  15                         )
  16 import SimplMonad
  17 import SimplUtils       ( mkCase, transformRhs, findAlt, etaCoreExpr,
  18                           simplBinder, simplBinders, simplIds, findDefault, mkCoerce
  19                         )
  20 import Var              ( TyVar, mkSysTyVar, tyVarKind, maybeModifyIdInfo )
  21 import VarEnv
  22 import VarSet
  23 import Id               ( Id, idType, idInfo, idUnique,
  24                           getIdUnfolding, setIdUnfolding, isExportedId,
  25                           getIdSpecialisation, setIdSpecialisation,
  26                           getIdDemandInfo, setIdDemandInfo,
  27                           setIdInfo,
  28                           getIdStrictness,
  29                           setInlinePragma, getInlinePragma, idMustBeINLINEd,
  30                           setOneShotLambda, maybeModifyIdInfo
  31                         )
  32 import IdInfo           ( InlinePragInfo(..), OccInfo(..), StrictnessInfo(..),
  33                           ArityInfo(..), atLeastArity, arityLowerBound, unknownArity, zapFragileIdInfo,
  34                           specInfo, inlinePragInfo, zapLamIdInfo, setArityInfo, setInlinePragInfo, setUnfoldingInfo
  35                         )
  36 import Demand           ( Demand, isStrict, wwLazy )
  37 import Const            ( isWHNFCon, conOkForAlt )
  38 import ConFold          ( tryPrimOp )
  39 import PrimOp           ( PrimOp, primOpStrictness, primOpType )
  40 import DataCon          ( DataCon, dataConNumInstArgs, dataConRepStrictness, dataConSig, dataConArgTys )
  41 import Const            ( Con(..) )
  42 import Name             ( isLocallyDefined )
  43 import CoreSyn
  44 import CoreFVs          ( exprFreeVars )
  45 import CoreUnfold       ( Unfolding, mkOtherCon, mkUnfolding, otherCons,
  46                           callSiteInline, hasSomeUnfolding
  47                         )
  48 import CoreUtils        ( cheapEqExpr, exprIsDupable, exprIsCheap, exprIsTrivial,
  49                           coreExprType, coreAltsType, exprArity, exprIsValue,
  50                           exprOkForSpeculation
  51                         )
  52 import Rules            ( lookupRule )
  53 import CostCentre       ( isSubsumedCCS, currentCCS, isEmptyCC )
  54 import Type             ( Type, mkTyVarTy, mkTyVarTys, isUnLiftedType, seqType,
  55                           mkFunTy, splitFunTys, splitTyConApp_maybe, splitFunTy_maybe,
  56                           funResultTy, isDictTy, isDataType, applyTy, applyTys, mkFunTys
  57                         )
  58 import Subst            ( Subst, mkSubst, emptySubst, substExpr, substTy,
  59                           substEnv, lookupInScope, lookupSubst, substIdInfo
  60                         )
  61 import TyCon            ( isDataTyCon, tyConDataCons, tyConClass_maybe, tyConArity, isDataTyCon )
  62 import TysPrim          ( realWorldStatePrimTy )
  63 import PrelInfo         ( realWorldPrimId )
  64 import BasicTypes       ( TopLevelFlag(..), isTopLevel )
  65 import Maybes           ( maybeToBool )
  66 import Util             ( zipWithEqual, stretchZipEqual, lengthExceeds )
  67 import PprCore
  68 import Outputable
  69 \end{code}
  70
  71
  72 The guts of the simplifier is in this module, but the driver
  73 loop for the simplifier is in SimplCore.lhs.
  74
  75
  76 %************************************************************************
  77 %*                                                                      *
  78 \subsection{Bindings}
  79 %*                                                                      *
  80 %************************************************************************
  81
  82 \begin{code}
  83 simplTopBinds :: [InBind] -> SimplM [OutBind]
  84
  85 simplTopBinds binds
  86   =     -- Put all the top-level binders into scope at the start
  87         -- so that if a transformation rule has unexpectedly brought
  88         -- anything into scope, then we don't get a complaint about that.
  89         -- It's rather as if the top-level binders were imported.
  90     extendInScopes top_binders  $
  91     simpl_binds binds           `thenSmpl` \ (binds', _) ->
  92     freeTick SimplifierDone     `thenSmpl_`
  93     returnSmpl binds'
  94   where
  95     top_binders = bindersOfBinds binds
  96
  97     simpl_binds []                        = returnSmpl ([], panic "simplTopBinds corner")
  98     simpl_binds (NonRec bndr rhs : binds) = simplLazyBind TopLevel bndr  (zap bndr) rhs  (simpl_binds binds)
  99     simpl_binds (Rec pairs       : binds) = simplRecBind  TopLevel pairs (map (zap . fst) pairs) (simpl_binds binds)
 100
 101     zap id = maybeModifyIdInfo zapFragileIdInfo id
 102 -- TEMP
 103
 104
 105 simplRecBind :: TopLevelFlag -> [(InId, InExpr)] -> [OutId]
 106              -> SimplM (OutStuff a) -> SimplM (OutStuff a)
 107 simplRecBind top_lvl pairs bndrs' thing_inside
 108   = go pairs bndrs'             `thenSmpl` \ (binds', stuff) ->
 109     returnSmpl (addBind (Rec (flattenBinds binds')) stuff)
 110   where
 111     go [] _ = thing_inside      `thenSmpl` \ stuff ->
 112               returnSmpl ([], stuff)
 113
 114     go ((bndr, rhs) : pairs) (bndr' : bndrs')
 115         = simplLazyBind top_lvl bndr bndr' rhs (go pairs bndrs')
 116                 -- Don't float unboxed bindings out,
 117                 -- because we can't "rec" them
 118 \end{code}
 119
 120
 121 %************************************************************************
 122 %*                                                                      *
 123 \subsection[Simplify-simplExpr]{The main function: simplExpr}
 124 %*                                                                      *
 125 %************************************************************************
 126
 127 \begin{code}
 128 addBind :: CoreBind -> OutStuff a -> OutStuff a
 129 addBind bind    (binds,  res) = (bind:binds,     res)
 130
 131 addBinds :: [CoreBind] -> OutStuff a -> OutStuff a
 132 addBinds []     stuff         = stuff
 133 addBinds binds1 (binds2, res) = (binds1++binds2, res)
 134 \end{code}
 135
 136 The reason for this OutExprStuff stuff is that we want to float *after*
 137 simplifying a RHS, not before.  If we do so naively we get quadratic
 138 behaviour as things float out.
 139
 140 To see why it's important to do it after, consider this (real) example:
 141
 142         let t = f x
 143         in fst t
 144 ==>
 145         let t = let a = e1
 146                     b = e2
 147                 in (a,b)
 148         in fst t
 149 ==>
 150         let a = e1
 151             b = e2
 152             t = (a,b)
 153         in
 154         a       -- Can't inline a this round, cos it appears twice
 155 ==>
 156         e1
 157
 158 Each of the ==> steps is a round of simplification.  We'd save a
 159 whole round if we float first.  This can cascade.  Consider
 160
 161         let f = g d
 162         in \x -> ...f...
 163 ==>
 164         let f = let d1 = ..d.. in \y -> e
 165         in \x -> ...f...
 166 ==>
 167         let d1 = ..d..
 168         in \x -> ...(\y ->e)...
 169
 170 Only in this second round can the \y be applied, and it
 171 might do the same again.
 172
 173
 174 \begin{code}
 175 simplExpr :: CoreExpr -> SimplM CoreExpr
 176 simplExpr expr = getSubst       `thenSmpl` \ subst ->
 177                  simplExprC expr (Stop (substTy subst (coreExprType expr)))
 178         -- The type in the Stop continuation is usually not used
 179         -- It's only needed when discarding continuations after finding
 180         -- a function that returns bottom.
 181         -- Hence the lazy substitution
 182
 183 simplExprC :: CoreExpr -> SimplCont -> SimplM CoreExpr
 184         -- Simplify an expression, given a continuation
 185
 186 simplExprC expr cont = simplExprF expr cont     `thenSmpl` \ (floats, (_, body)) ->
 187                        returnSmpl (mkLets floats body)
 188
 189 simplExprF :: InExpr -> SimplCont -> SimplM OutExprStuff
 190         -- Simplify an expression, returning floated binds
 191
 192 simplExprF (Var v) cont
 193   = simplVar v cont
 194
 195 simplExprF expr@(Con (PrimOp op) args) cont
 196   = getSubstEnv                         `thenSmpl` \ se ->
 197     prepareArgs (ppr op)
 198                 (primOpType op)
 199                 (primOpStrictness op)
 200                 (pushArgs se args cont) $ \ args1 cont1 ->
 201
 202     let
 203         -- Boring... we may have too many arguments now, so we push them back
 204         n_args = length args
 205         args2 = ASSERT( length args1 >= n_args )
 206                  take n_args args1
 207         cont2 = pushArgs emptySubstEnv (drop n_args args1) cont1
 208     in
 209         --      Try the prim op simplification
 210         -- It's really worth trying simplExpr again if it succeeds,
 211         -- because you can find
 212         --      case (eqChar# x 'a') of ...
 213         -- ==>
 214         --      case (case x of 'a' -> True; other -> False) of ...
 215      case tryPrimOp op args2 of
 216           Just e' -> zapSubstEnv (simplExprF e' cont2)
 217           Nothing -> rebuild (Con (PrimOp op) args2) cont2
 218
 219 simplExprF (Con con@(DataCon _) args) cont
 220   = simplConArgs args           $ \ args' ->
 221     rebuild (Con con args') cont
 222
 223 simplExprF expr@(Con con@(Literal _) args) cont
 224   = ASSERT( null args )
 225     rebuild expr cont
 226
 227 simplExprF (App fun arg) cont
 228   = getSubstEnv         `thenSmpl` \ se ->
 229     simplExprF fun (ApplyTo NoDup arg se cont)
 230
 231 simplExprF (Case scrut bndr alts) cont
 232   = getSubstEnv         `thenSmpl` \ se ->
 233     simplExprF scrut (Select NoDup bndr alts se cont)
 234
 235
 236 simplExprF (Let (Rec pairs) body) cont
 237   = simplIds (map fst pairs)            $ \ bndrs' ->
 238         -- NB: bndrs' don't have unfoldings or spec-envs
 239         -- We add them as we go down, using simplPrags
 240
 241     simplRecBind NotTopLevel pairs bndrs' (simplExprF body cont)
 242
 243 simplExprF expr@(Lam _ _) cont = simplLam expr cont
 244
 245 simplExprF (Type ty) cont
 246   = ASSERT( case cont of { Stop _ -> True; ArgOf _ _ _ -> True; other -> False } )
 247     simplType ty        `thenSmpl` \ ty' ->
 248     rebuild (Type ty') cont
 249
 250 simplExprF (Note (Coerce to from) e) cont
 251   | to == from = simplExprF e cont
 252   | otherwise  = simplType to           `thenSmpl` \ to' ->
 253                  simplExprF e (CoerceIt to' cont)
 254
 255 -- hack: we only distinguish subsumed cost centre stacks for the purposes of
 256 -- inlining.  All other CCCSs are mapped to currentCCS.
 257 simplExprF (Note (SCC cc) e) cont
 258   = setEnclosingCC currentCCS $
 259     simplExpr e         `thenSmpl` \ e ->
 260     rebuild (mkNote (SCC cc) e) cont
 261
 262 simplExprF (Note InlineCall e) cont
 263   = simplExprF e (InlinePlease cont)
 264
 265 -- Comments about the InlineMe case
 266 -- ~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~
 267 -- Don't inline in the RHS of something that has an
 268 -- inline pragma.  But be careful that the InScopeEnv that
 269 -- we return does still have inlinings on!
 270 --
 271 -- It really is important to switch off inlinings.  This function
 272 -- may be inlinined in other modules, so we don't want to remove
 273 -- (by inlining) calls to functions that have specialisations, or
 274 -- that may have transformation rules in an importing scope.
 275 -- E.g.         {-# INLINE f #-}
 276 --              f x = ...g...
 277 -- and suppose that g is strict *and* has specialisations.
 278 -- If we inline g's wrapper, we deny f the chance of getting
 279 -- the specialised version of g when f is inlined at some call site
 280 -- (perhaps in some other module).
 281
 282 simplExprF (Note InlineMe e) cont
 283   = case cont of
 284         Stop _ ->       -- Totally boring continuation
 285                         -- Don't inline inside an INLINE expression
 286                   switchOffInlining (simplExpr e)       `thenSmpl` \ e' ->
 287                   rebuild (mkNote InlineMe e') cont
 288
 289         other  ->       -- Dissolve the InlineMe note if there's
 290                         -- an interesting context of any kind to combine with
 291                         -- (even a type application -- anything except Stop)
 292                   simplExprF e cont
 293
 294 -- A non-recursive let is dealt with by simplBeta
 295 simplExprF (Let (NonRec bndr rhs) body) cont
 296   = getSubstEnv                 `thenSmpl` \ se ->
 297     simplBeta bndr rhs se (contResultType cont) $
 298     simplExprF body cont
 299 \end{code}
 300
 301
 302 ---------------------------------
 303
 304 \begin{code}
 305 simplLam fun cont
 306   = go fun cont
 307   where
 308     zap_it = mkLamBndrZapper fun (countArgs cont)
 309     cont_ty = contResultType cont
 310
 311         -- Type-beta reduction
 312     go (Lam bndr body) (ApplyTo _ (Type ty_arg) arg_se body_cont)
 313       = ASSERT( isTyVar bndr )
 314         tick (BetaReduction bndr)               `thenSmpl_`
 315         getInScope                              `thenSmpl` \ in_scope ->
 316         let
 317                 ty' = substTy (mkSubst in_scope arg_se) ty_arg
 318         in
 319         seqType ty'     `seq`
 320         extendSubst bndr (DoneTy ty')
 321         (go body body_cont)
 322
 323         -- Ordinary beta reduction
 324     go (Lam bndr body) cont@(ApplyTo _ arg arg_se body_cont)
 325       = tick (BetaReduction bndr)                       `thenSmpl_`
 326         simplBeta zapped_bndr arg arg_se cont_ty
 327         (go body body_cont)
 328       where
 329         zapped_bndr = zap_it bndr
 330
 331         -- Not enough args
 332     go lam@(Lam _ _) cont = completeLam [] lam cont
 333
 334         -- Exactly enough args
 335     go expr cont = simplExprF expr cont
 336
 337 -- completeLam deals with the case where a lambda doesn't have an ApplyTo
 338 -- continuation.
 339 -- We used to try for eta reduction here, but I found that this was
 340 -- eta reducing things like
 341 --      f = \x -> (coerce (\x -> e))
 342 -- This made f's arity reduce, which is a bad thing, so I removed the
 343 -- eta reduction at this point, and now do it only when binding
 344 -- (at the call to postInlineUnconditionally
 345
 346 completeLam acc (Lam bndr body) cont
 347   = simplBinder bndr                    $ \ bndr' ->
 348     completeLam (bndr':acc) body cont
 349
 350 completeLam acc body cont
 351   = simplExpr body                      `thenSmpl` \ body' ->
 352     rebuild (foldl (flip Lam) body' acc) cont
 353                 -- Remember, acc is the *reversed* binders
 354
 355 mkLamBndrZapper :: CoreExpr     -- Function
 356                 -> Int          -- Number of args
 357                 -> Id -> Id     -- Use this to zap the binders
 358 mkLamBndrZapper fun n_args
 359   | n_args >= n_params fun = \b -> b            -- Enough args
 360   | otherwise              = \b -> maybeModifyIdInfo zapLamIdInfo b
 361   where
 362     n_params (Lam b e) | isId b    = 1 + n_params e
 363                        | otherwise = n_params e
 364     n_params other                 = 0::Int
 365 \end{code}
 366
 367
 368 ---------------------------------
 369 simplConArgs makes sure that the arguments all end up being atomic.
 370 That means it may generate some Lets, hence the strange type
 371
 372 \begin{code}
 373 simplConArgs :: [InArg] -> ([OutArg] -> SimplM OutExprStuff) -> SimplM OutExprStuff
 374 simplConArgs [] thing_inside
 375   = thing_inside []
 376
 377 simplConArgs (arg:args) thing_inside
 378   = switchOffInlining (simplExpr arg)   `thenSmpl` \ arg' ->
 379         -- Simplify the RHS with inlining switched off, so that
 380         -- only absolutely essential things will happen.
 381         -- If we don't do this, consider:
 382         --      let x = e in C {x}
 383         -- We end up inlining x back into C's argument,
 384         -- and then let-binding it again!
 385
 386     simplConArgs args                           $ \ args' ->
 387
 388         -- If the argument ain't trivial, then let-bind it
 389     if exprIsTrivial arg' then
 390         thing_inside (arg' : args')
 391     else
 392         newId (coreExprType arg')               $ \ arg_id ->
 393         completeBeta arg_id arg_id arg'         $
 394         thing_inside (Var arg_id : args')
 395 \end{code}
 396
 397
 398 ---------------------------------
 399 \begin{code}
 400 simplType :: InType -> SimplM OutType
 401 simplType ty
 402   = getSubst    `thenSmpl` \ subst ->
 403     let
 404         new_ty = substTy subst ty
 405     in
 406     seqType new_ty `seq`
 407     returnSmpl new_ty
 408 \end{code}
 409
 410
 411 %************************************************************************
 412 %*                                                                      *
 413 \subsection{Binding}
 414 %*                                                                      *
 415 %************************************************************************
 416
 417 @simplBeta@ is used for non-recursive lets in expressions,
 418 as well as true beta reduction.
 419
 420 Very similar to @simplLazyBind@, but not quite the same.
 421
 422 \begin{code}
 423 simplBeta :: InId                       -- Binder
 424           -> InExpr -> SubstEnv         -- Arg, with its subst-env
 425           -> OutType                    -- Type of thing computed by the context
 426           -> SimplM OutExprStuff        -- The body
 427           -> SimplM OutExprStuff
 428 #ifdef DEBUG
 429 simplBeta bndr rhs rhs_se cont_ty thing_inside
 430   | isTyVar bndr
 431   = pprPanic "simplBeta" (ppr bndr <+> ppr rhs)
 432 #endif
 433
 434 simplBeta bndr rhs rhs_se cont_ty thing_inside
 435   | preInlineUnconditionally bndr && not opt_SimplNoPreInlining
 436   = tick (PreInlineUnconditionally bndr)                `thenSmpl_`
 437     extendSubst bndr (ContEx rhs_se rhs) thing_inside
 438
 439   | otherwise
 440   =     -- Simplify the RHS
 441     simplBinder bndr                                    $ \ bndr' ->
 442     simplArg (idType bndr') (getIdDemandInfo bndr)
 443              rhs rhs_se cont_ty                         $ \ rhs' ->
 444
 445         -- Now complete the binding and simplify the body
 446     completeBeta bndr bndr' rhs' thing_inside
 447
 448 completeBeta bndr bndr' rhs' thing_inside
 449   | isUnLiftedType (idType bndr') && not (exprOkForSpeculation rhs')
 450         -- Make a case expression instead of a let
 451         -- These can arise either from the desugarer,
 452         -- or from beta reductions: (\x.e) (x +# y)
 453   = getInScope                  `thenSmpl` \ in_scope ->
 454     thing_inside                `thenSmpl` \ (floats, (_, body)) ->
 455     returnSmpl ([], (in_scope, Case rhs' bndr' [(DEFAULT, [], mkLets floats body)]))
 456
 457   | otherwise
 458   = completeBinding bndr bndr' False rhs' thing_inside
 459 \end{code}
 460
 461
 462 \begin{code}
 463 simplArg :: OutType -> Demand
 464          -> InExpr -> SubstEnv
 465          -> OutType             -- Type of thing computed by the context
 466          -> (OutExpr -> SimplM OutExprStuff)
 467          -> SimplM OutExprStuff
 468 simplArg arg_ty demand arg arg_se cont_ty thing_inside
 469   | isStrict demand ||
 470     isUnLiftedType arg_ty ||
 471     (opt_DictsStrict && isDictTy arg_ty && isDataType arg_ty)
 472         -- Return true only for dictionary types where the dictionary
 473         -- has more than one component (else we risk poking on the component
 474         -- of a newtype dictionary)
 475   = transformRhs arg                    `thenSmpl` \ t_arg ->
 476     getEnv                              `thenSmpl` \ env ->
 477     setSubstEnv arg_se                          $
 478     simplExprF t_arg (ArgOf NoDup cont_ty       $ \ rhs' ->
 479     setAllExceptInScope env                     $
 480     etaFirst thing_inside rhs')
 481
 482   | otherwise
 483   = simplRhs NotTopLevel True {- OK to float unboxed -}
 484              arg_ty arg arg_se
 485              thing_inside
 486
 487 -- Do eta-reduction on the simplified RHS, if eta reduction is on
 488 -- NB: etaCoreExpr only eta-reduces if that results in something trivial
 489 etaFirst | opt_SimplDoEtaReduction = \ thing_inside rhs -> thing_inside (etaCoreExprToTrivial rhs)
 490          | otherwise               = \ thing_inside rhs -> thing_inside rhs
 491
 492 -- Try for eta reduction, but *only* if we get all
 493 -- the way to an exprIsTrivial expression.    We don't want to remove
 494 -- extra lambdas unless we are going to avoid allocating this thing altogether
 495 etaCoreExprToTrivial rhs | exprIsTrivial rhs' = rhs'
 496                          | otherwise          = rhs
 497                          where
 498                            rhs' = etaCoreExpr rhs
 499 \end{code}
 500
 501
 502 completeBinding
 503         - deals only with Ids, not TyVars
 504         - take an already-simplified RHS
 505
 506 It does *not* attempt to do let-to-case.  Why?  Because they are used for
 507
 508         - top-level bindings
 509                 (when let-to-case is impossible)
 510
 511         - many situations where the "rhs" is known to be a WHNF
 512                 (so let-to-case is inappropriate).
 513
 514 \begin{code}
 515 completeBinding :: InId                 -- Binder
 516                 -> OutId                -- New binder
 517                 -> Bool                 -- True <=> black-listed; don't inline
 518                 -> OutExpr              -- Simplified RHS
 519                 -> SimplM (OutStuff a)  -- Thing inside
 520                 -> SimplM (OutStuff a)
 521
 522 completeBinding old_bndr new_bndr black_listed new_rhs thing_inside
 523   |  isDeadBinder old_bndr      -- This happens; for example, the case_bndr during case of
 524                                 -- known constructor:  case (a,b) of x { (p,q) -> ... }
 525                                 -- Here x isn't mentioned in the RHS, so we don't want to
 526                                 -- create the (dead) let-binding  let x = (a,b) in ...
 527   =  thing_inside
 528
 529   |  not black_listed && postInlineUnconditionally old_bndr new_rhs
 530         -- Maybe we don't need a let-binding!  Maybe we can just
 531         -- inline it right away.  Unlike the preInlineUnconditionally case
 532         -- we are allowed to look at the RHS.
 533         --
 534         -- NB: a loop breaker never has postInlineUnconditionally True
 535         -- and non-loop-breakers only have *forward* references
 536         -- Hence, it's safe to discard the binding
 537   =  tick (PostInlineUnconditionally old_bndr)  `thenSmpl_`
 538      extendSubst old_bndr (DoneEx new_rhs)
 539      thing_inside
 540
 541   |  otherwise
 542   =  getSubst                   `thenSmpl` \ subst ->
 543      let
 544         -- We make new IdInfo for the new binder by starting from the old binder,
 545         -- doing appropriate substitutions,
 546         new_bndr_info = substIdInfo subst (idInfo old_bndr) (idInfo new_bndr)
 547                         `setArityInfo` ArityAtLeast (exprArity new_rhs)
 548
 549         -- At the *binding* site we use the new binder info
 550         binding_site_id = new_bndr `setIdInfo` new_bndr_info
 551
 552         -- At the *occurrence* sites we want to know the unfolding
 553         -- We also want the occurrence info of the *original*
 554         occ_site_id = new_bndr `setIdInfo`
 555                       (new_bndr_info `setUnfoldingInfo` mkUnfolding new_rhs
 556                                      `setInlinePragInfo` getInlinePragma old_bndr)
 557      in
 558         -- These seqs force the Ids, and hence the IdInfos, and hence any
 559         -- inner substitutions
 560      binding_site_id    `seq`
 561      occ_site_id        `seq`
 562
 563      (modifyInScope occ_site_id thing_inside    `thenSmpl` \ stuff ->
 564       returnSmpl (addBind (NonRec binding_site_id new_rhs) stuff))
 565 \end{code}
 566
 567
 568 %************************************************************************
 569 %*                                                                      *
 570 \subsection{simplLazyBind}
 571 %*                                                                      *
 572 %************************************************************************
 573
 574 simplLazyBind basically just simplifies the RHS of a let(rec).
 575 It does two important optimisations though:
 576
 577         * It floats let(rec)s out of the RHS, even if they
 578           are hidden by big lambdas
 579
 580         * It does eta expansion
 581
 582 \begin{code}
 583 simplLazyBind :: TopLevelFlag
 584               -> InId -> OutId
 585               -> InExpr                 -- The RHS
 586               -> SimplM (OutStuff a)    -- The body of the binding
 587               -> SimplM (OutStuff a)
 588 -- When called, the subst env is correct for the entire let-binding
 589 -- and hence right for the RHS.
 590 -- Also the binder has already been simplified, and hence is in scope
 591
 592 simplLazyBind top_lvl bndr bndr' rhs thing_inside
 593   = getBlackList                `thenSmpl` \ black_list_fn ->
 594     let
 595         black_listed = isTopLevel top_lvl && black_list_fn bndr
 596         -- Only top level things can be black listed, so the
 597         -- first test gets us 'False' without having to call
 598         -- the function, in the common case.
 599     in
 600     if not black_listed &&
 601        preInlineUnconditionally bndr &&
 602        not opt_SimplNoPreInlining
 603     then
 604         tick (PreInlineUnconditionally bndr)            `thenSmpl_`
 605         getSubstEnv                                     `thenSmpl` \ rhs_se ->
 606         (extendSubst bndr (ContEx rhs_se rhs) thing_inside)
 607
 608     else        -- Simplify the RHS
 609         getSubstEnv                                     `thenSmpl` \ rhs_se ->
 610         simplRhs top_lvl False {- Not ok to float unboxed -}
 611                  (idType bndr')
 612                  rhs rhs_se                             $ \ rhs' ->
 613
 614         -- Now compete the binding and simplify the body
 615         completeBinding bndr bndr' black_listed rhs' thing_inside
 616 \end{code}
 617
 618
 619
 620 \begin{code}
 621 simplRhs :: TopLevelFlag
 622          -> Bool                -- True <=> OK to float unboxed (speculative) bindings
 623          -> OutType -> InExpr -> SubstEnv
 624          -> (OutExpr -> SimplM (OutStuff a))
 625          -> SimplM (OutStuff a)
 626 simplRhs top_lvl float_ubx rhs_ty rhs rhs_se thing_inside
 627   =     -- Swizzle the inner lets past the big lambda (if any)
 628         -- and try eta expansion
 629     transformRhs rhs                                    `thenSmpl` \ t_rhs ->
 630
 631         -- Simplify it
 632     setSubstEnv rhs_se (simplExprF t_rhs (Stop rhs_ty)) `thenSmpl` \ (floats, (in_scope', rhs')) ->
 633
 634         -- Float lets out of RHS
 635     let
 636         (floats_out, rhs'') | float_ubx = (floats, rhs')
 637                             | otherwise = splitFloats floats rhs'
 638     in
 639     if (isTopLevel top_lvl || exprIsCheap rhs') &&      -- Float lets if (a) we're at the top level
 640         not (null floats_out)                           -- or            (b) it exposes a cheap (i.e. duplicatable) expression
 641     then
 642         tickLetFloat floats_out                         `thenSmpl_`
 643                 -- Do the float
 644                 --
 645                 -- There's a subtlety here.  There may be a binding (x* = e) in the
 646                 -- floats, where the '*' means 'will be demanded'.  So is it safe
 647                 -- to float it out?  Answer no, but it won't matter because
 648                 -- we only float if arg' is a WHNF,
 649                 -- and so there can't be any 'will be demanded' bindings in the floats.
 650                 -- Hence the assert
 651         WARN( any demanded_float floats_out, ppr floats_out )
 652         setInScope in_scope' (etaFirst thing_inside rhs'')      `thenSmpl` \ stuff ->
 653                 -- in_scope' may be excessive, but that's OK;
 654                 -- it's a superset of what's in scope
 655         returnSmpl (addBinds floats_out stuff)
 656     else
 657                 -- Don't do the float
 658         etaFirst thing_inside (mkLets floats rhs')
 659
 660 -- In a let-from-let float, we just tick once, arbitrarily
 661 -- choosing the first floated binder to identify it
 662 tickLetFloat (NonRec b r      : fs) = tick (LetFloatFromLet b)
 663 tickLetFloat (Rec ((b,r):prs) : fs) = tick (LetFloatFromLet b)
 664
 665 demanded_float (NonRec b r) = isStrict (getIdDemandInfo b) && not (isUnLiftedType (idType b))
 666                 -- Unlifted-type (cheap-eagerness) lets may well have a demanded flag on them
 667 demanded_float (Rec _)      = False
 668
 669 -- Don't float any unlifted bindings out, because the context
 670 -- is either a Rec group, or the top level, neither of which
 671 -- can tolerate them.
 672 splitFloats floats rhs
 673   = go floats
 674   where
 675     go []                   = ([], rhs)
 676     go (f:fs) | must_stay f = ([], mkLets (f:fs) rhs)
 677               | otherwise   = case go fs of
 678                                    (out, rhs') -> (f:out, rhs')
 679
 680     must_stay (Rec prs)    = False      -- No unlifted bindings in here
 681     must_stay (NonRec b r) = isUnLiftedType (idType b)
 682 \end{code}
 683
 684
 685
 686 %************************************************************************
 687 %*                                                                      *
 688 \subsection{Variables}
 689 %*                                                                      *
 690 %************************************************************************
 691
 692 \begin{code}
 693 simplVar var cont
 694   = getSubst            `thenSmpl` \ subst ->
 695     case lookupSubst subst var of
 696         Just (DoneEx (Var v)) -> zapSubstEnv (simplVar v cont)
 697         Just (DoneEx e)       -> zapSubstEnv (simplExprF e cont)
 698         Just (ContEx env' e)  -> setSubstEnv env' (simplExprF e cont)
 699
 700         Nothing -> let
 701                         var' = case lookupInScope subst var of
 702                                  Just v' -> v'
 703                                  Nothing ->
 704 #ifdef DEBUG
 705                                             if isLocallyDefined var && not (idMustBeINLINEd var)
 706                                                 -- The idMustBeINLINEd test accouunts for the fact
 707                                                 -- that class dictionary constructors don't have top level
 708                                                 -- bindings and hence aren't in scope.
 709                                             then
 710                                                 -- Not in scope
 711                                                 pprTrace "simplVar:" (ppr var) var
 712                                             else
 713 #endif
 714                                             var
 715                    in
 716                    getBlackList         `thenSmpl` \ black_list ->
 717                    getInScope           `thenSmpl` \ in_scope ->
 718                    completeCall black_list in_scope var var' cont
 719
 720 ---------------------------------------------------------
 721 --      Dealing with a call
 722
 723 completeCall black_list_fn in_scope orig_var var cont
 724 -- For reasons I'm not very clear about, it's important *not* to plug 'var',
 725 -- which is replete with an inlining in its IdInfo, into the resulting expression
 726 -- Doing so results in a significant space leak.
 727 -- Instead we pass orig_var, which has no inlinings etc.
 728
 729         -- Look for an unfolding. There's a binding for the
 730         -- thing, but perhaps we want to inline it anyway
 731   | maybeToBool maybe_inline
 732   = tick (UnfoldingDone var)            `thenSmpl_`
 733     zapSubstEnv (completeInlining orig_var unf_template discard_inline_cont)
 734                 -- The template is already simplified, so don't re-substitute.
 735                 -- This is VITAL.  Consider
 736                 --      let x = e in
 737                 --      let y = \z -> ...x... in
 738                 --      \ x -> ...y...
 739                 -- We'll clone the inner \x, adding x->x' in the id_subst
 740                 -- Then when we inline y, we must *not* replace x by x' in
 741                 -- the inlined copy!!
 742
 743   | otherwise           -- Neither rule nor inlining
 744                         -- Use prepareArgs to use function strictness
 745   = prepareArgs (ppr var) (idType var) (get_str var) cont       $ \ args' cont' ->
 746
 747         -- Look for rules or specialisations that match
 748         --
 749         -- It's important to simplify the args first, because the rule-matcher
 750         -- doesn't do substitution as it goes.  We don't want to use subst_args
 751         -- (defined in the 'where') because that throws away useful occurrence info,
 752         -- and perhaps-very-important specialisations.
 753         --
 754         -- Some functions have specialisations *and* are strict; in this case,
 755         -- we don't want to inline the wrapper of the non-specialised thing; better
 756         -- to call the specialised thing instead.
 757         -- But the black-listing mechanism means that inlining of the wrapper
 758         -- won't occur for things that have specialisations till a later phase, so
 759         -- it's ok to try for inlining first.
 760     case lookupRule in_scope var args' of
 761         Just (rule_name, rule_rhs, rule_args) ->
 762                 tick (RuleFired rule_name)                      `thenSmpl_`
 763                 zapSubstEnv (simplExprF rule_rhs (pushArgs emptySubstEnv rule_args cont'))
 764                         -- See note above about zapping the substitution here
 765
 766         Nothing -> rebuild (mkApps (Var orig_var) args') cont'
 767
 768   where
 769     get_str var = case getIdStrictness var of
 770                         NoStrictnessInfo                  -> (repeat wwLazy, False)
 771                         StrictnessInfo demands result_bot -> (demands, result_bot)
 772
 773         ---------- Unfolding stuff
 774     (subst_args, result_cont) = contArgs in_scope cont
 775     val_args                  = filter isValArg subst_args
 776     arg_infos                 = map (interestingArg in_scope) val_args
 777     inline_call               = contIsInline result_cont
 778     interesting_cont          = contIsInteresting result_cont
 779     discard_inline_cont       | inline_call = discardInline cont
 780                               | otherwise   = cont
 781
 782     maybe_inline  = callSiteInline black_listed inline_call
 783                                    var arg_infos interesting_cont
 784     Just unf_template = maybe_inline
 785     black_listed      = black_list_fn var
 786
 787
 788 -- An argument is interesting if it has *some* structure
 789 -- We are here trying to avoid unfolding a function that
 790 -- is applied only to variables that have no unfolding
 791 -- (i.e. they are probably lambda bound): f x y z
 792 -- There is little point in inlining f here.
 793 interestingArg in_scope (Type _)          = False
 794 interestingArg in_scope (App fn (Type _)) = interestingArg in_scope fn
 795 interestingArg in_scope (Var v)           = hasSomeUnfolding (getIdUnfolding v')
 796                                           where
 797                                             v' = case lookupVarSet in_scope v of
 798                                                         Just v' -> v'
 799                                                         other   -> v
 800 interestingArg in_scope other             = True
 801
 802
 803 -- First a special case
 804 -- Don't actually inline the scrutinee when we see
 805 --      case x of y { .... }
 806 -- and x has unfolding (C a b).  Why not?  Because
 807 -- we get a silly binding y = C a b.  If we don't
 808 -- inline knownCon can directly substitute x for y instead.
 809 completeInlining var (Con con con_args) (Select _ bndr alts se cont)
 810   | conOkForAlt con
 811   = knownCon (Var var) con con_args bndr alts se cont
 812
 813 -- Now the normal case
 814 completeInlining var unfolding cont
 815   = simplExprF unfolding cont
 816
 817 ----------- costCentreOk
 818 -- costCentreOk checks that it's ok to inline this thing
 819 -- The time it *isn't* is this:
 820 --
 821 --      f x = let y = E in
 822 --            scc "foo" (...y...)
 823 --
 824 -- Here y has a "current cost centre", and we can't inline it inside "foo",
 825 -- regardless of whether E is a WHNF or not.
 826
 827 costCentreOk ccs_encl cc_rhs
 828   =  not opt_SccProfilingOn
 829   || isSubsumedCCS ccs_encl       -- can unfold anything into a subsumed scope
 830   || not (isEmptyCC cc_rhs)       -- otherwise need a cc on the unfolding
 831 \end{code}
 832
 833
 834 \begin{code}
 835 ---------------------------------------------------------
 836 --      Preparing arguments for a call
 837
 838 prepareArgs :: SDoc     -- Error message info
 839             -> OutType -> ([Demand],Bool) -> SimplCont
 840             -> ([OutExpr] -> SimplCont -> SimplM OutExprStuff)
 841             -> SimplM OutExprStuff
 842
 843 prepareArgs pp_fun orig_fun_ty (fun_demands, result_bot) orig_cont thing_inside
 844   = go [] demands orig_fun_ty orig_cont
 845   where
 846     not_enough_args = fun_demands `lengthExceeds` countValArgs orig_cont
 847         -- "No strictness info" is signalled by an infinite list of wwLazy
 848
 849     demands | not_enough_args = repeat wwLazy                   -- Not enough args, or no strictness
 850             | result_bot      = fun_demands                     -- Enough args, and function returns bottom
 851             | otherwise       = fun_demands ++ repeat wwLazy    -- Enough args and function does not return bottom
 852         -- NB: demands is finite iff enough args and result_bot is True
 853
 854         -- Main game plan: loop through the arguments, simplifying
 855         -- each of them in turn.  We carry with us a list of demands,
 856         -- and the type of the function-applied-to-earlier-args
 857
 858         -- Type argument
 859     go acc ds fun_ty (ApplyTo _ arg@(Type ty_arg) se cont)
 860         = getInScope            `thenSmpl` \ in_scope ->
 861           let
 862                 ty_arg' = substTy (mkSubst in_scope se) ty_arg
 863                 res_ty  = applyTy fun_ty ty_arg'
 864           in
 865           seqType ty_arg'       `seq`
 866           go (Type ty_arg' : acc) ds res_ty cont
 867
 868         -- Value argument
 869     go acc (d:ds) fun_ty (ApplyTo _ val_arg se cont)
 870         = case splitFunTy_maybe fun_ty of {
 871                 Nothing -> pprTrace "prepareArgs" (pp_fun $$ ppr orig_fun_ty $$ ppr orig_cont)
 872                            (thing_inside (reverse acc) cont) ;
 873                 Just (arg_ty, res_ty) ->
 874           simplArg arg_ty d val_arg se (contResultType cont)    $ \ arg' ->
 875           go (arg':acc) ds res_ty cont }
 876
 877         -- We've run out of demands, which only happens for functions
 878         -- we *know* now return bottom
 879         -- This deals with
 880         --      * case (error "hello") of { ... }
 881         --      * (error "Hello") arg
 882         --      * f (error "Hello") where f is strict
 883         --      etc
 884     go acc [] fun_ty cont = tick_case_of_error cont             `thenSmpl_`
 885                             thing_inside (reverse acc) (discardCont cont)
 886
 887         -- We're run out of arguments
 888     go acc ds fun_ty cont = thing_inside (reverse acc) cont
 889
 890 -- Boring: we must only record a tick if there was an interesting
 891 --         continuation to discard.  If not, we tick forever.
 892 tick_case_of_error (Stop _)              = returnSmpl ()
 893 tick_case_of_error (CoerceIt _ (Stop _)) = returnSmpl ()
 894 tick_case_of_error other                 = tick BottomFound
 895 \end{code}
 896
 897 %************************************************************************
 898 %*                                                                      *
 899 \subsection{Decisions about inlining}
 900 %*                                                                      *
 901 %************************************************************************
 902
 903 \begin{code}
 904 preInlineUnconditionally :: InId -> Bool
 905         -- Examines a bndr to see if it is used just once in a
 906         -- completely safe way, so that it is safe to discard the binding
 907         -- inline its RHS at the (unique) usage site, REGARDLESS of how
 908         -- big the RHS might be.  If this is the case we don't simplify
 909         -- the RHS first, but just inline it un-simplified.
 910         --
 911         -- This is much better than first simplifying a perhaps-huge RHS
 912         -- and then inlining and re-simplifying it.
 913         --
 914         -- NB: we don't even look at the RHS to see if it's trivial
 915         -- We might have
 916         --                      x = y
 917         -- where x is used many times, but this is the unique occurrence
 918         -- of y.  We should NOT inline x at all its uses, because then
 919         -- we'd do the same for y -- aargh!  So we must base this
 920         -- pre-rhs-simplification decision solely on x's occurrences, not
 921         -- on its rhs.
 922         --
 923         -- Evne RHSs labelled InlineMe aren't caught here, because
 924         -- there might be no benefit from inlining at the call site.
 925         -- But things labelled 'IMustBeINLINEd' *are* caught.  We use this
 926         -- for the trivial bindings introduced by SimplUtils.mkRhsTyLam
 927 preInlineUnconditionally bndr
 928   = case getInlinePragma bndr of
 929         IMustBeINLINEd                        -> True
 930         ICanSafelyBeINLINEd NotInsideLam True -> True   -- Not inside a lambda,
 931                                                         -- one occurrence ==> safe!
 932         other -> False
 933
 934
 935 postInlineUnconditionally :: InId -> OutExpr -> Bool
 936         -- Examines a (bndr = rhs) binding, AFTER the rhs has been simplified
 937         -- It returns True if it's ok to discard the binding and inline the
 938         -- RHS at every use site.
 939
 940         -- NOTE: This isn't our last opportunity to inline.
 941         -- We're at the binding site right now, and
 942         -- we'll get another opportunity when we get to the ocurrence(s)
 943
 944 postInlineUnconditionally bndr rhs
 945   | isExportedId bndr
 946   = False
 947   | otherwise
 948   = case getInlinePragma bndr of
 949         IAmALoopBreaker                           -> False
 950
 951         ICanSafelyBeINLINEd InsideLam one_branch  -> exprIsTrivial rhs
 952                 -- Don't inline even WHNFs inside lambdas; doing so may
 953                 -- simply increase allocation when the function is called
 954                 -- This isn't the last chance; see NOTE above.
 955
 956         ICanSafelyBeINLINEd not_in_lam one_branch -> one_branch || exprIsTrivial rhs
 957                 -- Was 'exprIsDupable' instead of 'exprIsTrivial' but the
 958                 -- decision about duplicating code is best left to callSiteInline
 959
 960         other                                     -> exprIsTrivial rhs  -- Duplicating is *free*
 961                 -- NB: Even InlineMe and IMustBeINLINEd are ignored here
 962                 -- Why?  Because we don't even want to inline them into the
 963                 -- RHS of constructor arguments. See NOTE above
 964                 -- NB: Even IMustBeINLINEd is ignored here: if the rhs is trivial
 965                 -- it's best to inline it anyway.  We often get a=E; b=a
 966                 -- from desugaring, with both a and b marked NOINLINE.
 967 \end{code}
 968
 969
 970
 971 %************************************************************************
 972 %*                                                                      *
 973 \subsection{The main rebuilder}
 974 %*                                                                      *
 975 %************************************************************************
 976
 977 \begin{code}
 978 -------------------------------------------------------------------
 979 -- Finish rebuilding
 980 rebuild_done expr
 981   = getInScope                  `thenSmpl` \ in_scope ->
 982     returnSmpl ([], (in_scope, expr))
 983
 984 ---------------------------------------------------------
 985 rebuild :: OutExpr -> SimplCont -> SimplM OutExprStuff
 986
 987 --      Stop continuation
 988 rebuild expr (Stop _) = rebuild_done expr
 989
 990 --      ArgOf continuation
 991 rebuild expr (ArgOf _ _ cont_fn) = cont_fn expr
 992
 993 --      ApplyTo continuation
 994 rebuild expr cont@(ApplyTo _ arg se cont')
 995   = setSubstEnv se (simplExpr arg)      `thenSmpl` \ arg' ->
 996     rebuild (App expr arg') cont'
 997
 998 --      Coerce continuation
 999 rebuild expr (CoerceIt to_ty cont)
1000   = rebuild (mkCoerce to_ty expr) cont
1001
1002 --      Inline continuation
1003 rebuild expr (InlinePlease cont)
1004   = rebuild (Note InlineCall expr) cont
1005
1006 --      Case of known constructor or literal
1007 rebuild expr@(Con con args) (Select _ bndr alts se cont)
1008   | conOkForAlt con     -- Knocks out PrimOps and NoRepLits
1009   = knownCon expr con args bndr alts se cont
1010
1011
1012 ---------------------------------------------------------
1013 --      The other Select cases
1014
1015 rebuild scrut (Select _ bndr alts se cont)
1016   |     -- Check that the RHSs are all the same, and
1017         -- don't use the binders in the alternatives
1018         -- This test succeeds rapidly in the common case of
1019         -- a single DEFAULT alternative
1020     all (cheapEqExpr rhs1) other_rhss && all binders_unused alts
1021
1022         -- Check that the scrutinee can be let-bound instead of case-bound
1023     && (   exprOkForSpeculation scrut
1024                 -- OK not to evaluate it
1025                 -- This includes things like (==# a# b#)::Bool
1026                 -- so that we simplify
1027                 --      case ==# a# b# of { True -> x; False -> x }
1028                 -- to just
1029                 --      x
1030                 -- This particular example shows up in default methods for
1031                 -- comparision operations (e.g. in (>=) for Int.Int32)
1032         || exprIsValue scrut                    -- It's already evaluated
1033         || var_demanded_later scrut             -- It'll be demanded later
1034
1035 --      || not opt_SimplPedanticBottoms)        -- Or we don't care!
1036 --      We used to allow improving termination by discarding cases, unless -fpedantic-bottoms was on,
1037 --      but that breaks badly for the dataToTag# primop, which relies on a case to evaluate
1038 --      its argument:  case x of { y -> dataToTag# y }
1039 --      Here we must *not* discard the case, because dataToTag# just fetches the tag from
1040 --      the info pointer.  So we'll be pedantic all the time, and see if that gives any
1041 --      other problems
1042        )
1043
1044 --    && opt_SimplDoCaseElim
1045 --      [June 99; don't test this flag.  The code generator dies if it sees
1046 --              case (\x.e) of f -> ...
1047 --      so better to always do it
1048
1049         -- Get rid of the case altogether
1050         -- See the extensive notes on case-elimination below
1051         -- Remember to bind the binder though!
1052   = tick (CaseElim bndr)                        `thenSmpl_` (
1053     setSubstEnv se                              $
1054     simplBinder bndr                            $ \ bndr' ->
1055     completeBinding bndr bndr' False scrut      $
1056     simplExprF rhs1 cont)
1057
1058   | otherwise
1059   = rebuild_case scrut bndr alts se cont
1060   where
1061     (rhs1:other_rhss)            = [rhs | (_,_,rhs) <- alts]
1062     binders_unused (_, bndrs, _) = all isDeadBinder bndrs
1063
1064     var_demanded_later (Var v) = isStrict (getIdDemandInfo bndr)        -- It's going to be evaluated later
1065     var_demanded_later other   = False
1066 \end{code}
1067
1068 Case elimination [see the code above]
1069 ~~~~~~~~~~~~~~~~
1070 Start with a simple situation:
1071
1072         case x# of      ===>   e[x#/y#]
1073           y# -> e
1074
1075 (when x#, y# are of primitive type, of course).  We can't (in general)
1076 do this for algebraic cases, because we might turn bottom into
1077 non-bottom!
1078
1079 Actually, we generalise this idea to look for a case where we're
1080 scrutinising a variable, and we know that only the default case can
1081 match.  For example:
1082 \begin{verbatim}
1083         case x of
1084           0#    -> ...
1085           other -> ...(case x of
1086                          0#    -> ...
1087                          other -> ...) ...
1088 \end{code}
1089 Here the inner case can be eliminated.  This really only shows up in
1090 eliminating error-checking code.
1091
1092 We also make sure that we deal with this very common case:
1093
1094         case e of
1095           x -> ...x...
1096
1097 Here we are using the case as a strict let; if x is used only once
1098 then we want to inline it.  We have to be careful that this doesn't
1099 make the program terminate when it would have diverged before, so we
1100 check that
1101         - x is used strictly, or
1102         - e is already evaluated (it may so if e is a variable)
1103
1104 Lastly, we generalise the transformation to handle this:
1105
1106         case e of       ===> r
1107            True  -> r
1108            False -> r
1109
1110 We only do this for very cheaply compared r's (constructors, literals
1111 and variables).  If pedantic bottoms is on, we only do it when the
1112 scrutinee is a PrimOp which can't fail.
1113
1114 We do it *here*, looking at un-simplified alternatives, because we
1115 have to check that r doesn't mention the variables bound by the
1116 pattern in each alternative, so the binder-info is rather useful.
1117
1118 So the case-elimination algorithm is:
1119
1120         1. Eliminate alternatives which can't match
1121
1122         2. Check whether all the remaining alternatives
1123                 (a) do not mention in their rhs any of the variables bound in their pattern
1124            and  (b) have equal rhss
1125
1126         3. Check we can safely ditch the case:
1127                    * PedanticBottoms is off,
1128                 or * the scrutinee is an already-evaluated variable
1129                 or * the scrutinee is a primop which is ok for speculation
1130                         -- ie we want to preserve divide-by-zero errors, and
1131                         -- calls to error itself!
1132
1133                 or * [Prim cases] the scrutinee is a primitive variable
1134
1135                 or * [Alg cases] the scrutinee is a variable and
1136                      either * the rhs is the same variable
1137                         (eg case x of C a b -> x  ===>   x)
1138                      or     * there is only one alternative, the default alternative,
1139                                 and the binder is used strictly in its scope.
1140                                 [NB this is helped by the "use default binder where
1141                                  possible" transformation; see below.]
1142
1143
1144 If so, then we can replace the case with one of the rhss.
1145
1146
1147 Blob of helper functions for the "case-of-something-else" situation.
1148
1149 \begin{code}
1150 ---------------------------------------------------------
1151 --      Case of something else
1152
1153 rebuild_case scrut case_bndr alts se cont
1154   =     -- Prepare case alternatives
1155     prepareCaseAlts case_bndr (splitTyConApp_maybe (idType case_bndr))
1156                     scrut_cons alts             `thenSmpl` \ better_alts ->
1157
1158         -- Set the new subst-env in place (before dealing with the case binder)
1159     setSubstEnv se                              $
1160
1161         -- Deal with the case binder, and prepare the continuation;
1162         -- The new subst_env is in place
1163     prepareCaseCont better_alts cont            $ \ cont' ->
1164
1165
1166         -- Deal with variable scrutinee
1167     (   simplBinder case_bndr                   $ \ case_bndr' ->
1168         substForVarScrut scrut case_bndr'               $ \ zap_occ_info ->
1169         let
1170            case_bndr'' = zap_occ_info case_bndr'
1171         in
1172
1173         -- Deal with the case alternaatives
1174         simplAlts zap_occ_info scrut_cons
1175                   case_bndr'' better_alts cont' `thenSmpl` \ alts' ->
1176
1177         mkCase scrut case_bndr'' alts'
1178     )                                           `thenSmpl` \ case_expr ->
1179
1180         -- Notice that the simplBinder, prepareCaseCont, etc, do *not* scope
1181         -- over the rebuild_done; rebuild_done returns the in-scope set, and
1182         -- that should not include these chaps!
1183     rebuild_done case_expr
1184   where
1185         -- scrut_cons tells what constructors the scrutinee can't possibly match
1186     scrut_cons = case scrut of
1187                    Var v -> otherCons (getIdUnfolding v)
1188                    other -> []
1189
1190
1191 knownCon expr con args bndr alts se cont
1192   = tick (KnownBranch bndr)     `thenSmpl_`
1193     setSubstEnv se              (
1194     simplBinder bndr            $ \ bndr' ->
1195     case findAlt con alts of
1196         (DEFAULT, bs, rhs)     -> ASSERT( null bs )
1197                                   completeBinding bndr bndr' False expr $
1198                                         -- Don't use completeBeta here.  The expr might be
1199                                         -- an unboxed literal, like 3, or a variable
1200                                         -- whose unfolding is an unboxed literal... and
1201                                         -- completeBeta will just construct another case
1202                                         -- expression!
1203                                   simplExprF rhs cont
1204
1205         (Literal lit, bs, rhs) -> ASSERT( null bs )
1206                                   extendSubst bndr (DoneEx expr)        $
1207                                         -- Unconditionally substitute, because expr must
1208                                         -- be a variable or a literal.  It can't be a
1209                                         -- NoRep literal because they don't occur in
1210                                         -- case patterns.
1211                                   simplExprF rhs cont
1212
1213         (DataCon dc, bs, rhs)  -> ASSERT( length bs == length real_args )
1214                                   completeBinding bndr bndr' False expr $
1215                                         -- See note above
1216                                   extendSubstList bs (map mk real_args) $
1217                                   simplExprF rhs cont
1218                                where
1219                                   real_args    = drop (dataConNumInstArgs dc) args
1220                                   mk (Type ty) = DoneTy ty
1221                                   mk other     = DoneEx other
1222     )
1223 \end{code}
1224
1225 \begin{code}
1226 prepareCaseCont :: [InAlt] -> SimplCont
1227                 -> (SimplCont -> SimplM (OutStuff a))
1228                 -> SimplM (OutStuff a)
1229         -- Polymorphic recursion here!
1230
1231 prepareCaseCont [alt] cont thing_inside = thing_inside cont
1232 prepareCaseCont alts  cont thing_inside = mkDupableCont (coreAltsType alts) cont thing_inside
1233 \end{code}
1234
1235 substForVarScrut checks whether the scrutinee is a variable, v.
1236 If so, try to eliminate uses of v in the RHSs in favour of case_bndr;
1237 that way, there's a chance that v will now only be used once, and hence inlined.
1238
1239 If we do this, then we have to nuke any occurrence info (eg IAmDead)
1240 in the case binder, because the case-binder now effectively occurs
1241 whenever v does.  AND we have to do the same for the pattern-bound
1242 variables!  Example:
1243
1244         (case x of { (a,b) -> a }) (case x of { (p,q) -> q })
1245
1246 Here, b and p are dead.  But when we move the argment inside the first
1247 case RHS, and eliminate the second case, we get
1248
1249         case x or { (a,b) -> a b }
1250
1251 Urk! b is alive!  Reason: the scrutinee was a variable, and case elimination
1252 happened.  Hence the zap_occ_info function returned by substForVarScrut
1253
1254 \begin{code}
1255 substForVarScrut (Var v) case_bndr' thing_inside
1256   | isLocallyDefined v          -- No point for imported things
1257   = modifyInScope (v `setIdUnfolding` mkUnfolding (Var case_bndr')
1258                      `setInlinePragma` IMustBeINLINEd)                  $
1259         -- We could extend the substitution instead, but it would be
1260         -- a hack because then the substitution wouldn't be idempotent
1261         -- any more.
1262     thing_inside (\ bndr ->  bndr `setInlinePragma` NoInlinePragInfo)
1263
1264 substForVarScrut other_scrut case_bndr' thing_inside
1265   = thing_inside (\ bndr -> bndr)       -- NoOp on bndr
1266 \end{code}
1267
1268 prepareCaseAlts does two things:
1269
1270 1.  Remove impossible alternatives
1271
1272 2.  If the DEFAULT alternative can match only one possible constructor,
1273     then make that constructor explicit.
1274     e.g.
1275         case e of x { DEFAULT -> rhs }
1276      ===>
1277         case e of x { (a,b) -> rhs }
1278     where the type is a single constructor type.  This gives better code
1279     when rhs also scrutinises x or e.
1280
1281 \begin{code}
1282 prepareCaseAlts bndr (Just (tycon, inst_tys)) scrut_cons alts
1283   | isDataTyCon tycon
1284   = case (findDefault filtered_alts, missing_cons) of
1285
1286         ((alts_no_deflt, Just rhs), [data_con])         -- Just one missing constructor!
1287                 -> tick (FillInCaseDefault bndr)        `thenSmpl_`
1288                    let
1289                         (_,_,ex_tyvars,_,_,_) = dataConSig data_con
1290                    in
1291                    getUniquesSmpl (length ex_tyvars)                            `thenSmpl` \ tv_uniqs ->
1292                    let
1293                         ex_tyvars' = zipWithEqual "simpl_alt" mk tv_uniqs ex_tyvars
1294                         mk uniq tv = mkSysTyVar uniq (tyVarKind tv)
1295                    in
1296                    newIds (dataConArgTys
1297                                 data_con
1298                                 (inst_tys ++ mkTyVarTys ex_tyvars'))            $ \ bndrs ->
1299                    returnSmpl ((DataCon data_con, ex_tyvars' ++ bndrs, rhs) : alts_no_deflt)
1300
1301         other -> returnSmpl filtered_alts
1302   where
1303         -- Filter out alternatives that can't possibly match
1304     filtered_alts = case scrut_cons of
1305                         []    -> alts
1306                         other -> [alt | alt@(con,_,_) <- alts, not (con `elem` scrut_cons)]
1307
1308     missing_cons = [data_con | data_con <- tyConDataCons tycon,
1309                                not (data_con `elem` handled_data_cons)]
1310     handled_data_cons = [data_con | DataCon data_con         <- scrut_cons] ++
1311                         [data_con | (DataCon data_con, _, _) <- filtered_alts]
1312
1313 -- The default case
1314 prepareCaseAlts _ _ scrut_cons alts
1315   = returnSmpl alts                     -- Functions
1316
1317
1318 ----------------------
1319 simplAlts zap_occ_info scrut_cons case_bndr'' alts cont'
1320   = mapSmpl simpl_alt alts
1321   where
1322     inst_tys' = case splitTyConApp_maybe (idType case_bndr'') of
1323                         Just (tycon, inst_tys) -> inst_tys
1324
1325         -- handled_cons is all the constructors that are dealt
1326         -- with, either by being impossible, or by there being an alternative
1327     handled_cons = scrut_cons ++ [con | (con,_,_) <- alts, con /= DEFAULT]
1328
1329     simpl_alt (DEFAULT, _, rhs)
1330         =       -- In the default case we record the constructors that the
1331                 -- case-binder *can't* be.
1332                 -- We take advantage of any OtherCon info in the case scrutinee
1333           modifyInScope (case_bndr'' `setIdUnfolding` mkOtherCon handled_cons)  $
1334           simplExprC rhs cont'                                                  `thenSmpl` \ rhs' ->
1335           returnSmpl (DEFAULT, [], rhs')
1336
1337     simpl_alt (con, vs, rhs)
1338         =       -- Deal with the pattern-bound variables
1339                 -- Mark the ones that are in ! positions in the data constructor
1340                 -- as certainly-evaluated
1341           simplBinders (add_evals con vs)       $ \ vs' ->
1342
1343                 -- Bind the case-binder to (Con args)
1344           let
1345                 con_app = Con con (map Type inst_tys' ++ map varToCoreExpr vs')
1346           in
1347           modifyInScope (case_bndr'' `setIdUnfolding` mkUnfolding con_app)      $
1348           simplExprC rhs cont'          `thenSmpl` \ rhs' ->
1349           returnSmpl (con, vs', rhs')
1350
1351
1352         -- add_evals records the evaluated-ness of the bound variables of
1353         -- a case pattern.  This is *important*.  Consider
1354         --      data T = T !Int !Int
1355         --
1356         --      case x of { T a b -> T (a+1) b }
1357         --
1358         -- We really must record that b is already evaluated so that we don't
1359         -- go and re-evaluate it when constructing the result.
1360
1361     add_evals (DataCon dc) vs = cat_evals vs (dataConRepStrictness dc)
1362     add_evals other_con    vs = vs
1363
1364     cat_evals [] [] = []
1365     cat_evals (v:vs) (str:strs)
1366         | isTyVar v    = v                                   : cat_evals vs (str:strs)
1367         | isStrict str = (v' `setIdUnfolding` mkOtherCon []) : cat_evals vs strs
1368         | otherwise    = v'                                  : cat_evals vs strs
1369         where
1370           v' = zap_occ_info v
1371 \end{code}
1372
1373
1374 %************************************************************************
1375 %*                                                                      *
1376 \subsection{Duplicating continuations}
1377 %*                                                                      *
1378 %************************************************************************
1379
1380 \begin{code}
1381 mkDupableCont :: InType         -- Type of the thing to be given to the continuation
1382               -> SimplCont
1383               -> (SimplCont -> SimplM (OutStuff a))
1384               -> SimplM (OutStuff a)
1385 mkDupableCont ty cont thing_inside
1386   | contIsDupable cont
1387   = thing_inside cont
1388
1389 mkDupableCont _ (CoerceIt ty cont) thing_inside
1390   = mkDupableCont ty cont               $ \ cont' ->
1391     thing_inside (CoerceIt ty cont')
1392
1393 mkDupableCont ty (InlinePlease cont) thing_inside
1394   = mkDupableCont ty cont               $ \ cont' ->
1395     thing_inside (InlinePlease cont')
1396
1397 mkDupableCont join_arg_ty (ArgOf _ cont_ty cont_fn) thing_inside
1398   =     -- Build the RHS of the join point
1399     simplType join_arg_ty                               `thenSmpl` \ join_arg_ty' ->
1400     newId join_arg_ty'                                  ( \ arg_id ->
1401         getSwitchChecker                                `thenSmpl` \ chkr ->
1402         cont_fn (Var arg_id)                            `thenSmpl` \ (binds, (_, rhs)) ->
1403         returnSmpl (Lam (setOneShotLambda arg_id) (mkLets binds rhs))
1404     )                                                   `thenSmpl` \ join_rhs ->
1405
1406         -- Build the join Id and continuation
1407     newId (coreExprType join_rhs)               $ \ join_id ->
1408     let
1409         new_cont = ArgOf OkToDup cont_ty
1410                          (\arg' -> rebuild_done (App (Var join_id) arg'))
1411     in
1412
1413     tick (CaseOfCase join_id)                                           `thenSmpl_`
1414         -- Want to tick here so that we go round again,
1415         -- and maybe copy or inline the code;
1416         -- not strictly CaseOf Case
1417     thing_inside new_cont               `thenSmpl` \ res ->
1418     returnSmpl (addBind (NonRec join_id join_rhs) res)
1419
1420 mkDupableCont ty (ApplyTo _ arg se cont) thing_inside
1421   = mkDupableCont (funResultTy ty) cont                 $ \ cont' ->
1422     setSubstEnv se (simplExpr arg)                      `thenSmpl` \ arg' ->
1423     if exprIsDupable arg' then
1424         thing_inside (ApplyTo OkToDup arg' emptySubstEnv cont')
1425     else
1426     newId (coreExprType arg')                                           $ \ bndr ->
1427
1428     tick (CaseOfCase bndr)                                              `thenSmpl_`
1429         -- Want to tick here so that we go round again,
1430         -- and maybe copy or inline the code;
1431         -- not strictly CaseOf Case
1432     thing_inside (ApplyTo OkToDup (Var bndr) emptySubstEnv cont')       `thenSmpl` \ res ->
1433     returnSmpl (addBind (NonRec bndr arg') res)
1434
1435 mkDupableCont ty (Select _ case_bndr alts se cont) thing_inside
1436   = tick (CaseOfCase case_bndr)                                         `thenSmpl_`
1437     setSubstEnv se (
1438         simplBinder case_bndr                                           $ \ case_bndr' ->
1439         prepareCaseCont alts cont                                       $ \ cont' ->
1440         mapAndUnzipSmpl (mkDupableAlt case_bndr case_bndr' cont') alts  `thenSmpl` \ (alt_binds_s, alts') ->
1441         returnSmpl (concat alt_binds_s, alts')
1442     )                                   `thenSmpl` \ (alt_binds, alts') ->
1443
1444     extendInScopes [b | NonRec b _ <- alt_binds]                $
1445
1446         -- NB that the new alternatives, alts', are still InAlts, using the original
1447         -- binders.  That means we can keep the case_bndr intact. This is important
1448         -- because another case-of-case might strike, and so we want to keep the
1449         -- info that the case_bndr is dead (if it is, which is often the case).
1450         -- This is VITAL when the type of case_bndr is an unboxed pair (often the
1451         -- case in I/O rich code.  We aren't allowed a lambda bound
1452         -- arg of unboxed tuple type, and indeed such a case_bndr is always dead
1453     thing_inside (Select OkToDup case_bndr alts' se (Stop (contResultType cont)))       `thenSmpl` \ res ->
1454
1455     returnSmpl (addBinds alt_binds res)
1456
1457
1458 mkDupableAlt :: InId -> OutId -> SimplCont -> InAlt -> SimplM (OutStuff InAlt)
1459 mkDupableAlt case_bndr case_bndr' (Stop _) alt@(con, bndrs, rhs)
1460   | exprIsDupable rhs
1461   =     -- It is worth checking for a small RHS because otherwise we
1462         -- get extra let bindings that may cause an extra iteration of the simplifier to
1463         -- inline back in place.  Quite often the rhs is just a variable or constructor.
1464         -- The Ord instance of Maybe in PrelMaybe.lhs, for example, took several extra
1465         -- iterations because the version with the let bindings looked big, and so wasn't
1466         -- inlined, but after the join points had been inlined it looked smaller, and so
1467         -- was inlined.
1468         --
1469         -- But since the continuation is absorbed into the rhs, we only do this
1470         -- for a Stop continuation.
1471     returnSmpl ([], alt)
1472
1473 mkDupableAlt case_bndr case_bndr' cont alt@(con, bndrs, rhs)
1474   | otherwise
1475   =     -- Not worth checking whether the rhs is small; the
1476         -- inliner will inline it if so.
1477     simplBinders bndrs                                  $ \ bndrs' ->
1478     simplExprC rhs cont                                 `thenSmpl` \ rhs' ->
1479     let
1480         rhs_ty' = coreExprType rhs'
1481         (used_bndrs, used_bndrs')
1482            = unzip [pr | pr@(bndr,bndr') <- zip (case_bndr  : bndrs)
1483                                                 (case_bndr' : bndrs'),
1484                          not (isDeadBinder bndr)]
1485                 -- The new binders have lost their occurrence info,
1486                 -- so we have to extract it from the old ones
1487     in
1488     ( if null used_bndrs'
1489         -- If we try to lift a primitive-typed something out
1490         -- for let-binding-purposes, we will *caseify* it (!),
1491         -- with potentially-disastrous strictness results.  So
1492         -- instead we turn it into a function: \v -> e
1493         -- where v::State# RealWorld#.  The value passed to this function
1494         -- is realworld#, which generates (almost) no code.
1495
1496         -- There's a slight infelicity here: we pass the overall
1497         -- case_bndr to all the join points if it's used in *any* RHS,
1498         -- because we don't know its usage in each RHS separately
1499
1500         -- We used to say "&& isUnLiftedType rhs_ty'" here, but now
1501         -- we make the join point into a function whenever used_bndrs'
1502         -- is empty.  This makes the join-point more CPR friendly.
1503         -- Consider:    let j = if .. then I# 3 else I# 4
1504         --              in case .. of { A -> j; B -> j; C -> ... }
1505         --
1506         -- Now CPR should not w/w j because it's a thunk, so
1507         -- that means that the enclosing function can't w/w either,
1508         -- which is a lose.  Here's the example that happened in practice:
1509         --      kgmod :: Int -> Int -> Int
1510         --      kgmod x y = if x > 0 && y < 0 || x < 0 && y > 0
1511         --                  then 78
1512         --                  else 5
1513
1514         then newId realWorldStatePrimTy  $ \ rw_id ->
1515              returnSmpl ([rw_id], [Var realWorldPrimId])
1516         else
1517              returnSmpl (used_bndrs', map varToCoreExpr used_bndrs)
1518     )
1519         `thenSmpl` \ (final_bndrs', final_args) ->
1520
1521     newId (foldr (mkFunTy . idType) rhs_ty' final_bndrs')       $ \ join_bndr ->
1522
1523         -- Notice that we make the lambdas into one-shot-lambdas.  The
1524         -- join point is sure to be applied at most once, and doing so
1525         -- prevents the body of the join point being floated out by
1526         -- the full laziness pass
1527     returnSmpl ([NonRec join_bndr (mkLams (map setOneShotLambda final_bndrs') rhs')],
1528                 (con, bndrs, mkApps (Var join_bndr) final_args))
1529 \end{code}