ghc/compiler/simplCore/SimplUtils.lhs

   1 %
   2 % (c) The AQUA Project, Glasgow University, 1993-1998
   3 %
   4 \section[SimplUtils]{The simplifier utilities}
   5
   6 \begin{code}
   7 module SimplUtils (
   8         simplBinder, simplBinders, simplRecBndrs, simplLetBndr,
   9         simplLamBndrs, simplTopBndrs,
  10         newId, mkLam, mkCase,
  11
  12         -- The continuation type
  13         SimplCont(..), DupFlag(..), LetRhsFlag(..),
  14         contIsDupable, contResultType,
  15         countValArgs, countArgs, pushContArgs,
  16         mkBoringStop, mkStop, contIsRhs, contIsRhsOrArg,
  17         getContArgs, interestingCallContext, interestingArg, isStrictType
  18
  19     ) where
  20
  21 #include "HsVersions.h"
  22
  23 import CmdLineOpts      ( SimplifierSwitch(..),
  24                           opt_SimplDoLambdaEtaExpansion, opt_SimplDoEtaReduction,
  25                           opt_SimplCaseMerge, opt_UF_UpdateInPlace
  26                         )
  27 import CoreSyn
  28 import CoreUtils        ( cheapEqExpr, exprType,
  29                           etaExpand, exprEtaExpandArity, bindNonRec, mkCoerce,
  30                           findDefault, exprOkForSpeculation, exprIsValue
  31                         )
  32 import qualified Subst  ( simplBndrs, simplBndr, simplLetId, simplLamBndr )
  33 import Id               ( Id, idType, idInfo, isLocalId,
  34                           mkSysLocal, hasNoBinding, isDeadBinder, idNewDemandInfo,
  35                           idUnfolding, idNewStrictness
  36                         )
  37 import NewDemand        ( isStrictDmd, isBotRes, splitStrictSig )
  38 import SimplMonad
  39 import Type             ( Type, seqType,
  40                           splitTyConApp_maybe, tyConAppArgs, mkTyVarTys,
  41                           splitRepFunTys, isStrictType
  42                         )
  43 import OccName          ( UserFS )
  44 import TyCon            ( tyConDataConsIfAvailable, isAlgTyCon, isNewTyCon )
  45 import DataCon          ( dataConRepArity, dataConSig, dataConArgTys )
  46 import Var              ( mkSysTyVar, tyVarKind )
  47 import Util             ( lengthExceeds, mapAccumL )
  48 import Outputable
  49 \end{code}
  50
  51
  52 %************************************************************************
  53 %*                                                                      *
  54 \subsection{The continuation data type}
  55 %*                                                                      *
  56 %************************************************************************
  57
  58 \begin{code}
  59 data SimplCont          -- Strict contexts
  60   = Stop     OutType            -- Type of the result
  61              LetRhsFlag
  62              Bool               -- True <=> This is the RHS of a thunk whose type suggests
  63                                 --          that update-in-place would be possible
  64                                 --          (This makes the inliner a little keener.)
  65
  66   | CoerceIt OutType                    -- The To-type, simplified
  67              SimplCont
  68
  69   | InlinePlease                        -- This continuation makes a function very
  70              SimplCont                  -- keen to inline itelf
  71
  72   | ApplyTo  DupFlag
  73              InExpr SimplEnv            -- The argument, as yet unsimplified,
  74              SimplCont                  -- and its environment
  75
  76   | Select   DupFlag
  77              InId [InAlt] SimplEnv      -- The case binder, alts, and subst-env
  78              SimplCont
  79
  80   | ArgOf    DupFlag            -- An arbitrary strict context: the argument
  81                                 --      of a strict function, or a primitive-arg fn
  82                                 --      or a PrimOp
  83              LetRhsFlag
  84              OutType            -- cont_ty: the type of the expression being sought by the context
  85                                 --      f (error "foo") ==> coerce t (error "foo")
  86                                 -- when f is strict
  87                                 -- We need to know the type t, to which to coerce.
  88              (SimplEnv -> OutExpr -> SimplM FloatsWithExpr)     -- What to do with the result
  89                                 -- The result expression in the OutExprStuff has type cont_ty
  90
  91 data LetRhsFlag = AnArg         -- It's just an argument not a let RHS
  92                 | AnRhs         -- It's the RHS of a let (so please float lets out of big lambdas)
  93
  94 instance Outputable LetRhsFlag where
  95   ppr AnArg = ptext SLIT("arg")
  96   ppr AnRhs = ptext SLIT("rhs")
  97
  98 instance Outputable SimplCont where
  99   ppr (Stop _ is_rhs _)              = ptext SLIT("Stop") <> brackets (ppr is_rhs)
 100   ppr (ApplyTo dup arg se cont)      = (ptext SLIT("ApplyTo") <+> ppr dup <+> ppr arg) $$ ppr cont
 101   ppr (ArgOf   dup _ _ _)            = ptext SLIT("ArgOf...") <+> ppr dup
 102   ppr (Select dup bndr alts se cont) = (ptext SLIT("Select") <+> ppr dup <+> ppr bndr) $$
 103                                        (nest 4 (ppr alts)) $$ ppr cont
 104   ppr (CoerceIt ty cont)             = (ptext SLIT("CoerceIt") <+> ppr ty) $$ ppr cont
 105   ppr (InlinePlease cont)            = ptext SLIT("InlinePlease") $$ ppr cont
 106
 107 data DupFlag = OkToDup | NoDup
 108
 109 instance Outputable DupFlag where
 110   ppr OkToDup = ptext SLIT("ok")
 111   ppr NoDup   = ptext SLIT("nodup")
 112
 113
 114 -------------------
 115 mkBoringStop :: OutType -> SimplCont
 116 mkBoringStop ty = Stop ty AnArg (canUpdateInPlace ty)
 117
 118 mkStop :: OutType -> LetRhsFlag -> SimplCont
 119 mkStop ty is_rhs = Stop ty is_rhs (canUpdateInPlace ty)
 120
 121 contIsRhs :: SimplCont -> Bool
 122 contIsRhs (Stop _ AnRhs _)    = True
 123 contIsRhs (ArgOf _ AnRhs _ _) = True
 124 contIsRhs other               = False
 125
 126 contIsRhsOrArg (Stop _ _ _)    = True
 127 contIsRhsOrArg (ArgOf _ _ _ _) = True
 128 contIsRhsOrArg other           = False
 129
 130 -------------------
 131 contIsDupable :: SimplCont -> Bool
 132 contIsDupable (Stop _ _ _)               = True
 133 contIsDupable (ApplyTo  OkToDup _ _ _)   = True
 134 contIsDupable (ArgOf    OkToDup _ _ _)   = True
 135 contIsDupable (Select   OkToDup _ _ _ _) = True
 136 contIsDupable (CoerceIt _ cont)          = contIsDupable cont
 137 contIsDupable (InlinePlease cont)        = contIsDupable cont
 138 contIsDupable other                      = False
 139
 140 -------------------
 141 discardableCont :: SimplCont -> Bool
 142 discardableCont (Stop _ _ _)        = False
 143 discardableCont (CoerceIt _ cont)   = discardableCont cont
 144 discardableCont (InlinePlease cont) = discardableCont cont
 145 discardableCont other               = True
 146
 147 discardCont :: SimplCont        -- A continuation, expecting
 148             -> SimplCont        -- Replace the continuation with a suitable coerce
 149 discardCont cont = case cont of
 150                      Stop to_ty is_rhs _ -> cont
 151                      other               -> CoerceIt to_ty (mkBoringStop to_ty)
 152                  where
 153                    to_ty = contResultType cont
 154
 155 -------------------
 156 contResultType :: SimplCont -> OutType
 157 contResultType (Stop to_ty _ _)      = to_ty
 158 contResultType (ArgOf _ _ to_ty _)   = to_ty
 159 contResultType (ApplyTo _ _ _ cont)  = contResultType cont
 160 contResultType (CoerceIt _ cont)     = contResultType cont
 161 contResultType (InlinePlease cont)   = contResultType cont
 162 contResultType (Select _ _ _ _ cont) = contResultType cont
 163
 164 -------------------
 165 countValArgs :: SimplCont -> Int
 166 countValArgs (ApplyTo _ (Type ty) se cont) = countValArgs cont
 167 countValArgs (ApplyTo _ val_arg   se cont) = 1 + countValArgs cont
 168 countValArgs other                         = 0
 169
 170 countArgs :: SimplCont -> Int
 171 countArgs (ApplyTo _ arg se cont) = 1 + countArgs cont
 172 countArgs other                   = 0
 173
 174 -------------------
 175 pushContArgs :: SimplEnv -> [OutArg] -> SimplCont -> SimplCont
 176 -- Pushes args with the specified environment
 177 pushContArgs env []           cont = cont
 178 pushContArgs env (arg : args) cont = ApplyTo NoDup arg env (pushContArgs env args cont)
 179 \end{code}
 180
 181
 182 \begin{code}
 183 getContArgs :: SwitchChecker
 184             -> OutId -> SimplCont
 185             -> ([(InExpr, SimplEnv, Bool)],     -- Arguments; the Bool is true for strict args
 186                 SimplCont,                      -- Remaining continuation
 187                 Bool)                           -- Whether we came across an InlineCall
 188 -- getContArgs id k = (args, k', inl)
 189 --      args are the leading ApplyTo items in k
 190 --      (i.e. outermost comes first)
 191 --      augmented with demand info from the functionn
 192 getContArgs chkr fun orig_cont
 193   = let
 194                 -- Ignore strictness info if the no-case-of-case
 195                 -- flag is on.  Strictness changes evaluation order
 196                 -- and that can change full laziness
 197         stricts | switchIsOn chkr NoCaseOfCase = vanilla_stricts
 198                 | otherwise                    = computed_stricts
 199     in
 200     go [] stricts False orig_cont
 201   where
 202     ----------------------------
 203
 204         -- Type argument
 205     go acc ss inl (ApplyTo _ arg@(Type _) se cont)
 206         = go ((arg,se,False) : acc) ss inl cont
 207                 -- NB: don't bother to instantiate the function type
 208
 209         -- Value argument
 210     go acc (s:ss) inl (ApplyTo _ arg se cont)
 211         = go ((arg,se,s) : acc) ss inl cont
 212
 213         -- An Inline continuation
 214     go acc ss inl (InlinePlease cont)
 215         = go acc ss True cont
 216
 217         -- We're run out of arguments, or else we've run out of demands
 218         -- The latter only happens if the result is guaranteed bottom
 219         -- This is the case for
 220         --      * case (error "hello") of { ... }
 221         --      * (error "Hello") arg
 222         --      * f (error "Hello") where f is strict
 223         --      etc
 224     go acc ss inl cont
 225         | null ss && discardableCont cont = (reverse acc, discardCont cont, inl)
 226         | otherwise                       = (reverse acc, cont,             inl)
 227
 228     ----------------------------
 229     vanilla_stricts, computed_stricts :: [Bool]
 230     vanilla_stricts  = repeat False
 231     computed_stricts = zipWith (||) fun_stricts arg_stricts
 232
 233     ----------------------------
 234     (val_arg_tys, _) = splitRepFunTys (idType fun)
 235     arg_stricts      = map isStrictType val_arg_tys ++ repeat False
 236         -- These argument types are used as a cheap and cheerful way to find
 237         -- unboxed arguments, which must be strict.  But it's an InType
 238         -- and so there might be a type variable where we expect a function
 239         -- type (the substitution hasn't happened yet).  And we don't bother
 240         -- doing the type applications for a polymorphic function.
 241         -- Hence the split*Rep*FunTys
 242
 243     ----------------------------
 244         -- If fun_stricts is finite, it means the function returns bottom
 245         -- after that number of value args have been consumed
 246         -- Otherwise it's infinite, extended with False
 247     fun_stricts
 248       = case splitStrictSig (idNewStrictness fun) of
 249           (demands, result_info)
 250                 | not (demands `lengthExceeds` countValArgs orig_cont)
 251                 ->      -- Enough args, use the strictness given.
 252                         -- For bottoming functions we used to pretend that the arg
 253                         -- is lazy, so that we don't treat the arg as an
 254                         -- interesting context.  This avoids substituting
 255                         -- top-level bindings for (say) strings into
 256                         -- calls to error.  But now we are more careful about
 257                         -- inlining lone variables, so its ok (see SimplUtils.analyseCont)
 258                    if isBotRes result_info then
 259                         map isStrictDmd demands         -- Finite => result is bottom
 260                    else
 261                         map isStrictDmd demands ++ vanilla_stricts
 262
 263           other -> vanilla_stricts      -- Not enough args, or no strictness
 264
 265 -------------------
 266 interestingArg :: OutExpr -> Bool
 267         -- An argument is interesting if it has *some* structure
 268         -- We are here trying to avoid unfolding a function that
 269         -- is applied only to variables that have no unfolding
 270         -- (i.e. they are probably lambda bound): f x y z
 271         -- There is little point in inlining f here.
 272 interestingArg (Var v)           = hasSomeUnfolding (idUnfolding v)
 273                                         -- Was: isValueUnfolding (idUnfolding v')
 274                                         -- But that seems over-pessimistic
 275 interestingArg (Type _)          = False
 276 interestingArg (App fn (Type _)) = interestingArg fn
 277 interestingArg (Note _ a)        = interestingArg a
 278 interestingArg other             = True
 279         -- Consider     let x = 3 in f x
 280         -- The substitution will contain (x -> ContEx 3), and we want to
 281         -- to say that x is an interesting argument.
 282         -- But consider also (\x. f x y) y
 283         -- The substitution will contain (x -> ContEx y), and we want to say
 284         -- that x is not interesting (assuming y has no unfolding)
 285 \end{code}
 286
 287 Comment about interestingCallContext
 288 ~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~
 289 We want to avoid inlining an expression where there can't possibly be
 290 any gain, such as in an argument position.  Hence, if the continuation
 291 is interesting (eg. a case scrutinee, application etc.) then we
 292 inline, otherwise we don't.
 293
 294 Previously some_benefit used to return True only if the variable was
 295 applied to some value arguments.  This didn't work:
 296
 297         let x = _coerce_ (T Int) Int (I# 3) in
 298         case _coerce_ Int (T Int) x of
 299                 I# y -> ....
 300
 301 we want to inline x, but can't see that it's a constructor in a case
 302 scrutinee position, and some_benefit is False.
 303
 304 Another example:
 305
 306 dMonadST = _/\_ t -> :Monad (g1 _@_ t, g2 _@_ t, g3 _@_ t)
 307
 308 ....  case dMonadST _@_ x0 of (a,b,c) -> ....
 309
 310 we'd really like to inline dMonadST here, but we *don't* want to
 311 inline if the case expression is just
 312
 313         case x of y { DEFAULT -> ... }
 314
 315 since we can just eliminate this case instead (x is in WHNF).  Similar
 316 applies when x is bound to a lambda expression.  Hence
 317 contIsInteresting looks for case expressions with just a single
 318 default case.
 319
 320 \begin{code}
 321 interestingCallContext :: Bool          -- False <=> no args at all
 322                        -> Bool          -- False <=> no value args
 323                        -> SimplCont -> Bool
 324         -- The "lone-variable" case is important.  I spent ages
 325         -- messing about with unsatisfactory varaints, but this is nice.
 326         -- The idea is that if a variable appear all alone
 327         --      as an arg of lazy fn, or rhs    Stop
 328         --      as scrutinee of a case          Select
 329         --      as arg of a strict fn           ArgOf
 330         -- then we should not inline it (unless there is some other reason,
 331         -- e.g. is is the sole occurrence).  We achieve this by making
 332         -- interestingCallContext return False for a lone variable.
 333         --
 334         -- Why?  At least in the case-scrutinee situation, turning
 335         --      let x = (a,b) in case x of y -> ...
 336         -- into
 337         --      let x = (a,b) in case (a,b) of y -> ...
 338         -- and thence to
 339         --      let x = (a,b) in let y = (a,b) in ...
 340         -- is bad if the binding for x will remain.
 341         --
 342         -- Another example: I discovered that strings
 343         -- were getting inlined straight back into applications of 'error'
 344         -- because the latter is strict.
 345         --      s = "foo"
 346         --      f = \x -> ...(error s)...
 347
 348         -- Fundamentally such contexts should not ecourage inlining because
 349         -- the context can ``see'' the unfolding of the variable (e.g. case or a RULE)
 350         -- so there's no gain.
 351         --
 352         -- However, even a type application or coercion isn't a lone variable.
 353         -- Consider
 354         --      case $fMonadST @ RealWorld of { :DMonad a b c -> c }
 355         -- We had better inline that sucker!  The case won't see through it.
 356         --
 357         -- For now, I'm treating treating a variable applied to types
 358         -- in a *lazy* context "lone". The motivating example was
 359         --      f = /\a. \x. BIG
 360         --      g = /\a. \y.  h (f a)
 361         -- There's no advantage in inlining f here, and perhaps
 362         -- a significant disadvantage.  Hence some_val_args in the Stop case
 363
 364 interestingCallContext some_args some_val_args cont
 365   = interesting cont
 366   where
 367     interesting (InlinePlease _)       = True
 368     interesting (Select _ _ _ _ _)     = some_args
 369     interesting (ApplyTo _ _ _ _)      = True   -- Can happen if we have (coerce t (f x)) y
 370                                                 -- Perhaps True is a bit over-keen, but I've
 371                                                 -- seen (coerce f) x, where f has an INLINE prag,
 372                                                 -- So we have to give some motivaiton for inlining it
 373     interesting (ArgOf _ _ _ _)          = some_val_args
 374     interesting (Stop ty _ upd_in_place) = some_val_args && upd_in_place
 375     interesting (CoerceIt _ cont)        = interesting cont
 376         -- If this call is the arg of a strict function, the context
 377         -- is a bit interesting.  If we inline here, we may get useful
 378         -- evaluation information to avoid repeated evals: e.g.
 379         --      x + (y * z)
 380         -- Here the contIsInteresting makes the '*' keener to inline,
 381         -- which in turn exposes a constructor which makes the '+' inline.
 382         -- Assuming that +,* aren't small enough to inline regardless.
 383         --
 384         -- It's also very important to inline in a strict context for things
 385         -- like
 386         --              foldr k z (f x)
 387         -- Here, the context of (f x) is strict, and if f's unfolding is
 388         -- a build it's *great* to inline it here.  So we must ensure that
 389         -- the context for (f x) is not totally uninteresting.
 390
 391
 392 -------------------
 393 canUpdateInPlace :: Type -> Bool
 394 -- Consider   let x = <wurble> in ...
 395 -- If <wurble> returns an explicit constructor, we might be able
 396 -- to do update in place.  So we treat even a thunk RHS context
 397 -- as interesting if update in place is possible.  We approximate
 398 -- this by seeing if the type has a single constructor with a
 399 -- small arity.  But arity zero isn't good -- we share the single copy
 400 -- for that case, so no point in sharing.
 401
 402 canUpdateInPlace ty
 403   | not opt_UF_UpdateInPlace = False
 404   | otherwise
 405   = case splitTyConApp_maybe ty of
 406         Nothing         -> False
 407         Just (tycon, _) -> case tyConDataConsIfAvailable tycon of
 408                                 [dc]  -> arity == 1 || arity == 2
 409                                       where
 410                                          arity = dataConRepArity dc
 411                                 other -> False
 412 \end{code}
 413
 414
 415
 416 %************************************************************************
 417 %*                                                                      *
 418 \section{Dealing with a single binder}
 419 %*                                                                      *
 420 %************************************************************************
 421
 422 These functions are in the monad only so that they can be made strict via seq.
 423
 424 \begin{code}
 425 simplBinders :: SimplEnv -> [InBinder] -> SimplM (SimplEnv, [OutBinder])
 426 simplBinders env bndrs
 427   = let
 428         (subst', bndrs') = Subst.simplBndrs (getSubst env) bndrs
 429     in
 430     seqBndrs bndrs'     `seq`
 431     returnSmpl (setSubst env subst', bndrs')
 432
 433 simplBinder :: SimplEnv -> InBinder -> SimplM (SimplEnv, OutBinder)
 434 simplBinder env bndr
 435   = let
 436         (subst', bndr') = Subst.simplBndr (getSubst env) bndr
 437     in
 438     seqBndr bndr'       `seq`
 439     returnSmpl (setSubst env subst', bndr')
 440
 441
 442 simplLetBndr :: SimplEnv -> InBinder -> SimplM (SimplEnv, OutBinder)
 443 simplLetBndr env id
 444   = let
 445         (subst', id') = Subst.simplLetId (getSubst env) id
 446     in
 447     seqBndr id'         `seq`
 448     returnSmpl (setSubst env subst', id')
 449
 450 simplTopBndrs, simplLamBndrs, simplRecBndrs
 451         :: SimplEnv -> [InBinder] -> SimplM (SimplEnv, [OutBinder])
 452 simplTopBndrs = simplBndrs simplTopBinder
 453 simplRecBndrs = simplBndrs Subst.simplLetId
 454 simplLamBndrs = simplBndrs Subst.simplLamBndr
 455
 456 -- For top-level binders, don't use simplLetId for GlobalIds.
 457 -- There are some of these, notably consructor wrappers, and we don't
 458 -- want to clone them or fiddle with them at all.
 459 -- Rather tiresomely, the specialiser may float a use of a constructor
 460 -- wrapper to before its definition (which shouldn't really matter)
 461 -- because it doesn't see the constructor wrapper as free in the binding
 462 -- it is floating (because it's a GlobalId).
 463 -- Then the simplifier brings all top level Ids into scope at the
 464 -- beginning, and we don't want to lose the IdInfo on the constructor
 465 -- wrappers.  It would also be Bad to clone it!
 466 simplTopBinder subst bndr
 467   | isLocalId bndr = Subst.simplLetId subst bndr
 468   | otherwise      = (subst, bndr)
 469
 470 simplBndrs simpl_bndr env bndrs
 471   = let
 472         (subst', bndrs') = mapAccumL simpl_bndr (getSubst env) bndrs
 473     in
 474     seqBndrs bndrs'     `seq`
 475     returnSmpl (setSubst env subst', bndrs')
 476
 477 seqBndrs [] = ()
 478 seqBndrs (b:bs) = seqBndr b `seq` seqBndrs bs
 479
 480 seqBndr b | isTyVar b = b `seq` ()
 481           | otherwise = seqType (idType b)      `seq`
 482                         idInfo b                `seq`
 483                         ()
 484 \end{code}
 485
 486
 487 \begin{code}
 488 newId :: UserFS -> Type -> SimplM Id
 489 newId fs ty = getUniqueSmpl     `thenSmpl` \ uniq ->
 490               returnSmpl (mkSysLocal fs uniq ty)
 491 \end{code}
 492
 493
 494 %************************************************************************
 495 %*                                                                      *
 496 \subsection{Rebuilding a lambda}
 497 %*                                                                      *
 498 %************************************************************************
 499
 500 \begin{code}
 501 mkLam :: SimplEnv -> [OutBinder] -> OutExpr -> SimplCont -> SimplM FloatsWithExpr
 502 \end{code}
 503
 504 Try three things
 505         a) eta reduction, if that gives a trivial expression
 506         b) eta expansion [only if there are some value lambdas]
 507         c) floating lets out through big lambdas
 508                 [only if all tyvar lambdas, and only if this lambda
 509                  is the RHS of a let]
 510
 511 \begin{code}
 512 mkLam env bndrs body cont
 513  | opt_SimplDoEtaReduction,
 514    Just etad_lam <- tryEtaReduce bndrs body
 515  = tick (EtaReduction (head bndrs))     `thenSmpl_`
 516    returnSmpl (emptyFloats env, etad_lam)
 517
 518  | opt_SimplDoLambdaEtaExpansion,
 519    any isRuntimeVar bndrs
 520  = tryEtaExpansion body         `thenSmpl` \ body' ->
 521    returnSmpl (emptyFloats env, mkLams bndrs body')
 522
 523 {-      Sept 01: I'm experimenting with getting the
 524         full laziness pass to float out past big lambdsa
 525  | all isTyVar bndrs,   -- Only for big lambdas
 526    contIsRhs cont       -- Only try the rhs type-lambda floating
 527                         -- if this is indeed a right-hand side; otherwise
 528                         -- we end up floating the thing out, only for float-in
 529                         -- to float it right back in again!
 530  = tryRhsTyLam env bndrs body           `thenSmpl` \ (floats, body') ->
 531    returnSmpl (floats, mkLams bndrs body')
 532 -}
 533
 534  | otherwise
 535  = returnSmpl (emptyFloats env, mkLams bndrs body)
 536 \end{code}
 537
 538
 539 %************************************************************************
 540 %*                                                                      *
 541 \subsection{Eta expansion and reduction}
 542 %*                                                                      *
 543 %************************************************************************
 544
 545 We try for eta reduction here, but *only* if we get all the
 546 way to an exprIsTrivial expression.
 547 We don't want to remove extra lambdas unless we are going
 548 to avoid allocating this thing altogether
 549
 550 \begin{code}
 551 tryEtaReduce :: [OutBinder] -> OutExpr -> Maybe OutExpr
 552 tryEtaReduce bndrs body
 553         -- We don't use CoreUtils.etaReduce, because we can be more
 554         -- efficient here:
 555         --  (a) we already have the binders
 556         --  (b) we can do the triviality test before computing the free vars
 557         --      [in fact I take the simple path and look for just a variable]
 558   = go (reverse bndrs) body
 559   where
 560     go (b : bs) (App fun arg) | ok_arg b arg = go bs fun        -- Loop round
 561     go []       (Var fun)     | ok_fun fun   = Just (Var fun)   -- Success!
 562     go _        _                            = Nothing          -- Failure!
 563
 564     ok_fun fun   = not (fun `elem` bndrs) && not (hasNoBinding fun)
 565                         -- Note the awkward "hasNoBinding" test
 566                         -- Details with exprIsTrivial
 567     ok_arg b arg = varToCoreExpr b `cheapEqExpr` arg
 568 \end{code}
 569
 570
 571         Try eta expansion for RHSs
 572
 573 We go for:
 574    f = \x1..xn -> N  ==>   f = \x1..xn y1..ym -> N y1..ym
 575                                  (n >= 0)
 576
 577 where (in both cases)
 578
 579         * The xi can include type variables
 580
 581         * The yi are all value variables
 582
 583         * N is a NORMAL FORM (i.e. no redexes anywhere)
 584           wanting a suitable number of extra args.
 585
 586 We may have to sandwich some coerces between the lambdas
 587 to make the types work.   exprEtaExpandArity looks through coerces
 588 when computing arity; and etaExpand adds the coerces as necessary when
 589 actually computing the expansion.
 590
 591 \begin{code}
 592 tryEtaExpansion :: OutExpr -> SimplM OutExpr
 593 -- There is at least one runtime binder in the binders
 594 tryEtaExpansion body
 595   = getUniquesSmpl                      `thenSmpl` \ us ->
 596     returnSmpl (etaExpand fun_arity us body (exprType body))
 597   where
 598     fun_arity = exprEtaExpandArity body
 599 \end{code}
 600
 601
 602 %************************************************************************
 603 %*                                                                      *
 604 \subsection{Floating lets out of big lambdas}
 605 %*                                                                      *
 606 %************************************************************************
 607
 608 tryRhsTyLam tries this transformation, when the big lambda appears as
 609 the RHS of a let(rec) binding:
 610
 611         /\abc -> let(rec) x = e in b
 612    ==>
 613         let(rec) x' = /\abc -> let x = x' a b c in e
 614         in
 615         /\abc -> let x = x' a b c in b
 616
 617 This is good because it can turn things like:
 618
 619         let f = /\a -> letrec g = ... g ... in g
 620 into
 621         letrec g' = /\a -> ... g' a ...
 622         in
 623         let f = /\ a -> g' a
 624
 625 which is better.  In effect, it means that big lambdas don't impede
 626 let-floating.
 627
 628 This optimisation is CRUCIAL in eliminating the junk introduced by
 629 desugaring mutually recursive definitions.  Don't eliminate it lightly!
 630
 631 So far as the implementation is concerned:
 632
 633         Invariant: go F e = /\tvs -> F e
 634
 635         Equalities:
 636                 go F (Let x=e in b)
 637                 = Let x' = /\tvs -> F e
 638                   in
 639                   go G b
 640                 where
 641                     G = F . Let x = x' tvs
 642
 643                 go F (Letrec xi=ei in b)
 644                 = Letrec {xi' = /\tvs -> G ei}
 645                   in
 646                   go G b
 647                 where
 648                   G = F . Let {xi = xi' tvs}
 649
 650 [May 1999]  If we do this transformation *regardless* then we can
 651 end up with some pretty silly stuff.  For example,
 652
 653         let
 654             st = /\ s -> let { x1=r1 ; x2=r2 } in ...
 655         in ..
 656 becomes
 657         let y1 = /\s -> r1
 658             y2 = /\s -> r2
 659             st = /\s -> ...[y1 s/x1, y2 s/x2]
 660         in ..
 661
 662 Unless the "..." is a WHNF there is really no point in doing this.
 663 Indeed it can make things worse.  Suppose x1 is used strictly,
 664 and is of the form
 665
 666         x1* = case f y of { (a,b) -> e }
 667
 668 If we abstract this wrt the tyvar we then can't do the case inline
 669 as we would normally do.
 670
 671
 672 \begin{code}
 673 {-      Trying to do this in full laziness
 674
 675 tryRhsTyLam :: SimplEnv -> [OutTyVar] -> OutExpr -> SimplM FloatsWithExpr
 676 -- Call ensures that all the binders are type variables
 677
 678 tryRhsTyLam env tyvars body             -- Only does something if there's a let
 679   |  not (all isTyVar tyvars)
 680   || not (worth_it body)                -- inside a type lambda,
 681   = returnSmpl (emptyFloats env, body)  -- and a WHNF inside that
 682
 683   | otherwise
 684   = go env (\x -> x) body
 685
 686   where
 687     worth_it e@(Let _ _) = whnf_in_middle e
 688     worth_it e           = False
 689
 690     whnf_in_middle (Let (NonRec x rhs) e) | isUnLiftedType (idType x) = False
 691     whnf_in_middle (Let _ e) = whnf_in_middle e
 692     whnf_in_middle e         = exprIsCheap e
 693
 694     main_tyvar_set = mkVarSet tyvars
 695
 696     go env fn (Let bind@(NonRec var rhs) body)
 697       | exprIsTrivial rhs
 698       = go env (fn . Let bind) body
 699
 700     go env fn (Let (NonRec var rhs) body)
 701       = mk_poly tyvars_here var                                                 `thenSmpl` \ (var', rhs') ->
 702         addAuxiliaryBind env (NonRec var' (mkLams tyvars_here (fn rhs)))        $ \ env ->
 703         go env (fn . Let (mk_silly_bind var rhs')) body
 704
 705       where
 706
 707         tyvars_here = varSetElems (main_tyvar_set `intersectVarSet` exprSomeFreeVars isTyVar rhs)
 708                 -- Abstract only over the type variables free in the rhs
 709                 -- wrt which the new binding is abstracted.  But the naive
 710                 -- approach of abstract wrt the tyvars free in the Id's type
 711                 -- fails. Consider:
 712                 --      /\ a b -> let t :: (a,b) = (e1, e2)
 713                 --                    x :: a     = fst t
 714                 --                in ...
 715                 -- Here, b isn't free in x's type, but we must nevertheless
 716                 -- abstract wrt b as well, because t's type mentions b.
 717                 -- Since t is floated too, we'd end up with the bogus:
 718                 --      poly_t = /\ a b -> (e1, e2)
 719                 --      poly_x = /\ a   -> fst (poly_t a *b*)
 720                 -- So for now we adopt the even more naive approach of
 721                 -- abstracting wrt *all* the tyvars.  We'll see if that
 722                 -- gives rise to problems.   SLPJ June 98
 723
 724     go env fn (Let (Rec prs) body)
 725        = mapAndUnzipSmpl (mk_poly tyvars_here) vars     `thenSmpl` \ (vars', rhss') ->
 726          let
 727             gn body = fn (foldr Let body (zipWith mk_silly_bind vars rhss'))
 728             pairs   = vars' `zip` [mkLams tyvars_here (gn rhs) | rhs <- rhss]
 729          in
 730          addAuxiliaryBind env (Rec pairs)               $ \ env ->
 731          go env gn body
 732        where
 733          (vars,rhss) = unzip prs
 734          tyvars_here = varSetElems (main_tyvar_set `intersectVarSet` exprsSomeFreeVars isTyVar (map snd prs))
 735                 -- See notes with tyvars_here above
 736
 737     go env fn body = returnSmpl (emptyFloats env, fn body)
 738
 739     mk_poly tyvars_here var
 740       = getUniqueSmpl           `thenSmpl` \ uniq ->
 741         let
 742             poly_name = setNameUnique (idName var) uniq         -- Keep same name
 743             poly_ty   = mkForAllTys tyvars_here (idType var)    -- But new type of course
 744             poly_id   = mkLocalId poly_name poly_ty
 745
 746                 -- In the olden days, it was crucial to copy the occInfo of the original var,
 747                 -- because we were looking at occurrence-analysed but as yet unsimplified code!
 748                 -- In particular, we mustn't lose the loop breakers.  BUT NOW we are looking
 749                 -- at already simplified code, so it doesn't matter
 750                 --
 751                 -- It's even right to retain single-occurrence or dead-var info:
 752                 -- Suppose we started with  /\a -> let x = E in B
 753                 -- where x occurs once in B. Then we transform to:
 754                 --      let x' = /\a -> E in /\a -> let x* = x' a in B
 755                 -- where x* has an INLINE prag on it.  Now, once x* is inlined,
 756                 -- the occurrences of x' will be just the occurrences originally
 757                 -- pinned on x.
 758         in
 759         returnSmpl (poly_id, mkTyApps (Var poly_id) (mkTyVarTys tyvars_here))
 760
 761     mk_silly_bind var rhs = NonRec var (Note InlineMe rhs)
 762                 -- Suppose we start with:
 763                 --
 764                 --      x = /\ a -> let g = G in E
 765                 --
 766                 -- Then we'll float to get
 767                 --
 768                 --      x = let poly_g = /\ a -> G
 769                 --          in /\ a -> let g = poly_g a in E
 770                 --
 771                 -- But now the occurrence analyser will see just one occurrence
 772                 -- of poly_g, not inside a lambda, so the simplifier will
 773                 -- PreInlineUnconditionally poly_g back into g!  Badk to square 1!
 774                 -- (I used to think that the "don't inline lone occurrences" stuff
 775                 --  would stop this happening, but since it's the *only* occurrence,
 776                 --  PreInlineUnconditionally kicks in first!)
 777                 --
 778                 -- Solution: put an INLINE note on g's RHS, so that poly_g seems
 779                 --           to appear many times.  (NB: mkInlineMe eliminates
 780                 --           such notes on trivial RHSs, so do it manually.)
 781 -}
 782 \end{code}
 783
 784
 785 %************************************************************************
 786 %*                                                                      *
 787 \subsection{Case absorption and identity-case elimination}
 788 %*                                                                      *
 789 %************************************************************************
 790
 791 mkCase puts a case expression back together, trying various transformations first.
 792
 793 \begin{code}
 794 mkCase :: OutExpr -> [AltCon] -> OutId -> [OutAlt] -> SimplM OutExpr
 795
 796 mkCase scrut handled_cons case_bndr alts
 797   = mkAlts scrut handled_cons case_bndr alts    `thenSmpl` \ better_alts ->
 798     mkCase1 scrut case_bndr better_alts
 799 \end{code}
 800
 801
 802 mkAlts tries these things:
 803
 804 1.  If several alternatives are identical, merge them into
 805     a single DEFAULT alternative.  I've occasionally seen this
 806     making a big difference:
 807
 808         case e of               =====>     case e of
 809           C _ -> f x                         D v -> ....v....
 810           D v -> ....v....                   DEFAULT -> f x
 811           DEFAULT -> f x
 812
 813    The point is that we merge common RHSs, at least for the DEFAULT case.
 814    [One could do something more elaborate but I've never seen it needed.]
 815    To avoid an expensive test, we just merge branches equal to the *first*
 816    alternative; this picks up the common cases
 817         a) all branches equal
 818         b) some branches equal to the DEFAULT (which occurs first)
 819
 820 2.  If the DEFAULT alternative can match only one possible constructor,
 821     then make that constructor explicit.
 822     e.g.
 823         case e of x { DEFAULT -> rhs }
 824      ===>
 825         case e of x { (a,b) -> rhs }
 826     where the type is a single constructor type.  This gives better code
 827     when rhs also scrutinises x or e.
 828
 829 3.  Case merging:
 830        case e of b {             ==>   case e of b {
 831          p1 -> rhs1                      p1 -> rhs1
 832          ...                             ...
 833          pm -> rhsm                      pm -> rhsm
 834          _  -> case b of b' {            pn -> let b'=b in rhsn
 835                      pn -> rhsn          ...
 836                      ...                 po -> let b'=b in rhso
 837                      po -> rhso          _  -> let b'=b in rhsd
 838                      _  -> rhsd
 839        }
 840
 841     which merges two cases in one case when -- the default alternative of
 842     the outer case scrutises the same variable as the outer case This
 843     transformation is called Case Merging.  It avoids that the same
 844     variable is scrutinised multiple times.
 845
 846
 847 The case where transformation (1) showed up was like this (lib/std/PrelCError.lhs):
 848
 849         x | p `is` 1 -> e1
 850           | p `is` 2 -> e2
 851         ...etc...
 852
 853 where @is@ was something like
 854
 855         p `is` n = p /= (-1) && p == n
 856
 857 This gave rise to a horrible sequence of cases
 858
 859         case p of
 860           (-1) -> $j p
 861           1    -> e1
 862           DEFAULT -> $j p
 863
 864 and similarly in cascade for all the join points!
 865
 866
 867
 868 \begin{code}
 869 --------------------------------------------------
 870 --      1. Merge identical branches
 871 --------------------------------------------------
 872 mkAlts scrut handled_cons case_bndr alts@((con1,bndrs1,rhs1) : con_alts)
 873   | all isDeadBinder bndrs1,                    -- Remember the default
 874     length filtered_alts < length con_alts      -- alternative comes first
 875   = tick (AltMerge case_bndr)                   `thenSmpl_`
 876     returnSmpl better_alts
 877   where
 878     filtered_alts        = filter keep con_alts
 879     keep (con,bndrs,rhs) = not (all isDeadBinder bndrs && rhs `cheapEqExpr` rhs1)
 880     better_alts          = (DEFAULT, [], rhs1) : filtered_alts
 881
 882
 883 --------------------------------------------------
 884 --      2. Fill in missing constructor
 885 --------------------------------------------------
 886
 887 mkAlts scrut handled_cons case_bndr alts
 888   | (alts_no_deflt, Just rhs) <- findDefault alts,
 889                         -- There is a DEFAULT case
 890
 891     Just (tycon, inst_tys) <- splitTyConApp_maybe (idType case_bndr),
 892     isAlgTyCon tycon,           -- It's a data type, tuple, or unboxed tuples.
 893     not (isNewTyCon tycon),     -- We can have a newtype, if we are just doing an eval:
 894                                 --      case x of { DEFAULT -> e }
 895                                 -- and we don't want to fill in a default for them!
 896
 897     [missing_con] <- [con | con <- tyConDataConsIfAvailable tycon,
 898                             not (con `elem` handled_data_cons)]
 899                         -- There is just one missing constructor!
 900
 901   = tick (FillInCaseDefault case_bndr)  `thenSmpl_`
 902     getUniquesSmpl                      `thenSmpl` \ tv_uniqs ->
 903     getUniquesSmpl                      `thenSmpl` \ id_uniqs ->
 904     let
 905         (_,_,ex_tyvars,_,_,_) = dataConSig missing_con
 906         ex_tyvars'  = zipWith mk tv_uniqs ex_tyvars
 907         mk uniq tv  = mkSysTyVar uniq (tyVarKind tv)
 908         arg_ids     = zipWith (mkSysLocal SLIT("a")) id_uniqs arg_tys
 909         arg_tys     = dataConArgTys missing_con (inst_tys ++ mkTyVarTys ex_tyvars')
 910         better_alts = (DataAlt missing_con, ex_tyvars' ++ arg_ids, rhs) : alts_no_deflt
 911     in
 912     returnSmpl better_alts
 913   where
 914     handled_data_cons = [data_con | DataAlt data_con <- handled_cons]
 915
 916 --------------------------------------------------
 917 --      3.  Merge nested cases
 918 --------------------------------------------------
 919
 920 mkAlts scrut handled_cons outer_bndr outer_alts
 921   | opt_SimplCaseMerge,
 922     (outer_alts_without_deflt, maybe_outer_deflt)   <- findDefault outer_alts,
 923     Just (Case (Var scrut_var) inner_bndr inner_alts) <- maybe_outer_deflt,
 924     scruting_same_var scrut_var
 925
 926   = let     --  Eliminate any inner alts which are shadowed by the outer ones
 927         outer_cons = [con | (con,_,_) <- outer_alts_without_deflt]
 928
 929         munged_inner_alts = [ (con, args, munge_rhs rhs)
 930                             | (con, args, rhs) <- inner_alts,
 931                                not (con `elem` outer_cons)      -- Eliminate shadowed inner alts
 932                             ]
 933         munge_rhs rhs = bindCaseBndr inner_bndr (Var outer_bndr) rhs
 934
 935         (inner_con_alts, maybe_inner_default) = findDefault munged_inner_alts
 936
 937         new_alts = add_default maybe_inner_default
 938                                (outer_alts_without_deflt ++ inner_con_alts)
 939     in
 940     tick (CaseMerge outer_bndr)                         `thenSmpl_`
 941     returnSmpl new_alts
 942         -- Warning: don't call mkAlts recursively!
 943         -- Firstly, there's no point, because inner alts have already had
 944         -- mkCase applied to them, so they won't have a case in their default
 945         -- Secondly, if you do, you get an infinite loop, because the bindCaseBndr
 946         -- in munge_rhs may put a case into the DEFAULT branch!
 947   where
 948         -- We are scrutinising the same variable if it's
 949         -- the outer case-binder, or if the outer case scrutinises a variable
 950         -- (and it's the same).  Testing both allows us not to replace the
 951         -- outer scrut-var with the outer case-binder (Simplify.simplCaseBinder).
 952     scruting_same_var = case scrut of
 953                           Var outer_scrut -> \ v -> v == outer_bndr || v == outer_scrut
 954                           other           -> \ v -> v == outer_bndr
 955
 956     add_default (Just rhs) alts = (DEFAULT,[],rhs) : alts
 957     add_default Nothing    alts = alts
 958
 959
 960 --------------------------------------------------
 961 --      Catch-all
 962 --------------------------------------------------
 963
 964 mkAlts scrut handled_cons case_bndr other_alts = returnSmpl other_alts
 965 \end{code}
 966
 967
 968
 969 =================================================================================
 970
 971 mkCase1 tries these things
 972
 973 1.  Eliminate the case altogether if possible
 974
 975 2.  Case-identity:
 976
 977         case e of               ===> e
 978                 True  -> True;
 979                 False -> False
 980
 981     and similar friends.
 982
 983
 984 Start with a simple situation:
 985
 986         case x# of      ===>   e[x#/y#]
 987           y# -> e
 988
 989 (when x#, y# are of primitive type, of course).  We can't (in general)
 990 do this for algebraic cases, because we might turn bottom into
 991 non-bottom!
 992
 993 Actually, we generalise this idea to look for a case where we're
 994 scrutinising a variable, and we know that only the default case can
 995 match.  For example:
 996 \begin{verbatim}
 997         case x of
 998           0#    -> ...
 999           other -> ...(case x of
1000                          0#    -> ...
1001                          other -> ...) ...
1002 \end{code}
1003 Here the inner case can be eliminated.  This really only shows up in
1004 eliminating error-checking code.
1005
1006 We also make sure that we deal with this very common case:
1007
1008         case e of
1009           x -> ...x...
1010
1011 Here we are using the case as a strict let; if x is used only once
1012 then we want to inline it.  We have to be careful that this doesn't
1013 make the program terminate when it would have diverged before, so we
1014 check that
1015         - x is used strictly, or
1016         - e is already evaluated (it may so if e is a variable)
1017
1018 Lastly, we generalise the transformation to handle this:
1019
1020         case e of       ===> r
1021            True  -> r
1022            False -> r
1023
1024 We only do this for very cheaply compared r's (constructors, literals
1025 and variables).  If pedantic bottoms is on, we only do it when the
1026 scrutinee is a PrimOp which can't fail.
1027
1028 We do it *here*, looking at un-simplified alternatives, because we
1029 have to check that r doesn't mention the variables bound by the
1030 pattern in each alternative, so the binder-info is rather useful.
1031
1032 So the case-elimination algorithm is:
1033
1034         1. Eliminate alternatives which can't match
1035
1036         2. Check whether all the remaining alternatives
1037                 (a) do not mention in their rhs any of the variables bound in their pattern
1038            and  (b) have equal rhss
1039
1040         3. Check we can safely ditch the case:
1041                    * PedanticBottoms is off,
1042                 or * the scrutinee is an already-evaluated variable
1043                 or * the scrutinee is a primop which is ok for speculation
1044                         -- ie we want to preserve divide-by-zero errors, and
1045                         -- calls to error itself!
1046
1047                 or * [Prim cases] the scrutinee is a primitive variable
1048
1049                 or * [Alg cases] the scrutinee is a variable and
1050                      either * the rhs is the same variable
1051                         (eg case x of C a b -> x  ===>   x)
1052                      or     * there is only one alternative, the default alternative,
1053                                 and the binder is used strictly in its scope.
1054                                 [NB this is helped by the "use default binder where
1055                                  possible" transformation; see below.]
1056
1057
1058 If so, then we can replace the case with one of the rhss.
1059
1060
1061 \begin{code}
1062 --------------------------------------------------
1063 --      1. Eliminate the case altogether if poss
1064 --------------------------------------------------
1065
1066 mkCase1 scrut case_bndr [(con,bndrs,rhs)]
1067   -- See if we can get rid of the case altogether
1068   -- See the extensive notes on case-elimination above
1069   -- mkCase made sure that if all the alternatives are equal,
1070   -- then there is now only one (DEFAULT) rhs
1071  |  all isDeadBinder bndrs,
1072
1073         -- Check that the scrutinee can be let-bound instead of case-bound
1074     exprOkForSpeculation scrut
1075                 -- OK not to evaluate it
1076                 -- This includes things like (==# a# b#)::Bool
1077                 -- so that we simplify
1078                 --      case ==# a# b# of { True -> x; False -> x }
1079                 -- to just
1080                 --      x
1081                 -- This particular example shows up in default methods for
1082                 -- comparision operations (e.g. in (>=) for Int.Int32)
1083         || exprIsValue scrut                    -- It's already evaluated
1084         || var_demanded_later scrut             -- It'll be demanded later
1085
1086 --      || not opt_SimplPedanticBottoms)        -- Or we don't care!
1087 --      We used to allow improving termination by discarding cases, unless -fpedantic-bottoms was on,
1088 --      but that breaks badly for the dataToTag# primop, which relies on a case to evaluate
1089 --      its argument:  case x of { y -> dataToTag# y }
1090 --      Here we must *not* discard the case, because dataToTag# just fetches the tag from
1091 --      the info pointer.  So we'll be pedantic all the time, and see if that gives any
1092 --      other problems
1093   = tick (CaseElim case_bndr)                   `thenSmpl_`
1094     returnSmpl (bindCaseBndr case_bndr scrut rhs)
1095
1096   where
1097         -- The case binder is going to be evaluated later,
1098         -- and the scrutinee is a simple variable
1099     var_demanded_later (Var v) = isStrictDmd (idNewDemandInfo case_bndr)
1100     var_demanded_later other   = False
1101
1102
1103 --------------------------------------------------
1104 --      2. Identity case
1105 --------------------------------------------------
1106
1107 mkCase1 scrut case_bndr alts    -- Identity case
1108   | all identity_alt alts
1109   = tick (CaseIdentity case_bndr)               `thenSmpl_`
1110     returnSmpl (re_note scrut)
1111   where
1112     identity_alt (con, args, rhs) = de_note rhs `cheapEqExpr` identity_rhs con args
1113
1114     identity_rhs (DataAlt con) args = mkConApp con (arg_tys ++ map varToCoreExpr args)
1115     identity_rhs (LitAlt lit)  _    = Lit lit
1116     identity_rhs DEFAULT       _    = Var case_bndr
1117
1118     arg_tys = map Type (tyConAppArgs (idType case_bndr))
1119
1120         -- We've seen this:
1121         --      case coerce T e of x { _ -> coerce T' x }
1122         -- And we definitely want to eliminate this case!
1123         -- So we throw away notes from the RHS, and reconstruct
1124         -- (at least an approximation) at the other end
1125     de_note (Note _ e) = de_note e
1126     de_note e          = e
1127
1128         -- re_note wraps a coerce if it might be necessary
1129     re_note scrut = case head alts of
1130                         (_,_,rhs1@(Note _ _)) -> mkCoerce (exprType rhs1) (idType case_bndr) scrut
1131                         other                 -> scrut
1132
1133
1134 --------------------------------------------------
1135 --      Catch-all
1136 --------------------------------------------------
1137 mkCase1 scrut bndr alts = returnSmpl (Case scrut bndr alts)
1138 \end{code}
1139
1140
1141 When adding auxiliary bindings for the case binder, it's worth checking if
1142 its dead, because it often is, and occasionally these mkCase transformations
1143 cascade rather nicely.
1144
1145 \begin{code}
1146 bindCaseBndr bndr rhs body
1147   | isDeadBinder bndr = body
1148   | otherwise         = bindNonRec bndr rhs body
1149 \end{code}