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