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