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