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