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, simplIds,
   9         transformRhs,
  10         mkCase, findAlt, findDefault,
  11
  12         -- The continuation type
  13         SimplCont(..), DupFlag(..), contIsDupable, contResultType,
  14         pushArgs, discardCont, countValArgs, countArgs,
  15         analyseCont, discardInline
  16
  17     ) where
  18
  19 #include "HsVersions.h"
  20
  21 import BinderInfo
  22 import CmdLineOpts      ( opt_SimplDoLambdaEtaExpansion, opt_SimplCaseMerge )
  23 import CoreSyn
  24 import CoreUnfold       ( isValueUnfolding )
  25 import CoreFVs          ( exprFreeVars )
  26 import CoreUtils        ( exprIsTrivial, cheapEqExpr, exprType, exprIsCheap, exprEtaExpandArity )
  27 import Subst            ( InScopeSet, mkSubst, substBndrs, substBndr, substIds, lookupIdSubst )
  28 import Id               ( Id, idType, isId, idName,
  29                           idOccInfo, idUnfolding,
  30                           idDemandInfo, mkId, idInfo
  31                         )
  32 import IdInfo           ( arityLowerBound, setOccInfo, vanillaIdInfo )
  33 import Maybes           ( maybeToBool, catMaybes )
  34 import Name             ( isLocalName, setNameUnique )
  35 import SimplMonad
  36 import Type             ( Type, tyVarsOfType, tyVarsOfTypes, mkForAllTys, seqType,
  37                           splitTyConApp_maybe, splitAlgTyConApp_maybe, mkTyVarTys, applyTys, splitFunTys, mkFunTys
  38                         )
  39 import PprType          ( {- instance Outputable Type -} )
  40 import DataCon          ( dataConRepArity )
  41 import TysPrim          ( statePrimTyCon )
  42 import Var              ( setVarUnique )
  43 import VarSet
  44 import VarEnv           ( SubstEnv, SubstResult(..) )
  45 import UniqSupply       ( splitUniqSupply, uniqFromSupply )
  46 import Util             ( zipWithEqual, mapAccumL )
  47 import Outputable
  48 \end{code}
  49
  50
  51 %************************************************************************
  52 %*                                                                      *
  53 \subsection{The continuation data type}
  54 %*                                                                      *
  55 %************************************************************************
  56
  57 \begin{code}
  58 data SimplCont          -- Strict contexts
  59   = Stop OutType                -- Type of the result
  60
  61   | CoerceIt OutType                    -- The To-type, simplified
  62              SimplCont
  63
  64   | InlinePlease                        -- This continuation makes a function very
  65              SimplCont                  -- keen to inline itelf
  66
  67   | ApplyTo  DupFlag
  68              InExpr SubstEnv            -- The argument, as yet unsimplified,
  69              SimplCont                  -- and its subst-env
  70
  71   | Select   DupFlag
  72              InId [InAlt] SubstEnv      -- The case binder, alts, and subst-env
  73              SimplCont
  74
  75   | ArgOf    DupFlag            -- An arbitrary strict context: the argument
  76                                 --      of a strict function, or a primitive-arg fn
  77                                 --      or a PrimOp
  78              OutType            -- The type of the expression being sought by the context
  79                                 --      f (error "foo") ==> coerce t (error "foo")
  80                                 -- when f is strict
  81                                 -- We need to know the type t, to which to coerce.
  82              (OutExpr -> SimplM OutExprStuff)   -- What to do with the result
  83
  84 instance Outputable SimplCont where
  85   ppr (Stop _)                       = ptext SLIT("Stop")
  86   ppr (ApplyTo dup arg se cont)      = (ptext SLIT("ApplyTo") <+> ppr dup <+> ppr arg) $$ ppr cont
  87   ppr (ArgOf   dup _ _)              = ptext SLIT("ArgOf...") <+> ppr dup
  88   ppr (Select dup bndr alts se cont) = (ptext SLIT("Select") <+> ppr dup <+> ppr bndr) $$
  89                                        (nest 4 (ppr alts)) $$ ppr cont
  90   ppr (CoerceIt ty cont)             = (ptext SLIT("CoerceIt") <+> ppr ty) $$ ppr cont
  91   ppr (InlinePlease cont)            = ptext SLIT("InlinePlease") $$ ppr cont
  92
  93 data DupFlag = OkToDup | NoDup
  94
  95 instance Outputable DupFlag where
  96   ppr OkToDup = ptext SLIT("ok")
  97   ppr NoDup   = ptext SLIT("nodup")
  98
  99 contIsDupable :: SimplCont -> Bool
 100 contIsDupable (Stop _)                   = True
 101 contIsDupable (ApplyTo  OkToDup _ _ _)   = True
 102 contIsDupable (ArgOf    OkToDup _ _)     = True
 103 contIsDupable (Select   OkToDup _ _ _ _) = True
 104 contIsDupable (CoerceIt _ cont)          = contIsDupable cont
 105 contIsDupable (InlinePlease cont)        = contIsDupable cont
 106 contIsDupable other                      = False
 107
 108 pushArgs :: SubstEnv -> [InExpr] -> SimplCont -> SimplCont
 109 pushArgs se []         cont = cont
 110 pushArgs se (arg:args) cont = ApplyTo NoDup arg se (pushArgs se args cont)
 111
 112 discardCont :: SimplCont        -- A continuation, expecting
 113             -> SimplCont        -- Replace the continuation with a suitable coerce
 114 discardCont (Stop to_ty) = Stop to_ty
 115 discardCont cont         = CoerceIt to_ty (Stop to_ty)
 116                          where
 117                            to_ty = contResultType cont
 118
 119 contResultType :: SimplCont -> OutType
 120 contResultType (Stop to_ty)          = to_ty
 121 contResultType (ArgOf _ to_ty _)     = to_ty
 122 contResultType (ApplyTo _ _ _ cont)  = contResultType cont
 123 contResultType (CoerceIt _ cont)     = contResultType cont
 124 contResultType (InlinePlease cont)   = contResultType cont
 125 contResultType (Select _ _ _ _ cont) = contResultType cont
 126
 127 countValArgs :: SimplCont -> Int
 128 countValArgs (ApplyTo _ (Type ty) se cont) = countValArgs cont
 129 countValArgs (ApplyTo _ val_arg   se cont) = 1 + countValArgs cont
 130 countValArgs other                         = 0
 131
 132 countArgs :: SimplCont -> Int
 133 countArgs (ApplyTo _ arg se cont) = 1 + countArgs cont
 134 countArgs other                   = 0
 135 \end{code}
 136
 137
 138 Comment about analyseCont
 139 ~~~~~~~~~~~~~~~~~~~~~~~~~
 140 We want to avoid inlining an expression where there can't possibly be
 141 any gain, such as in an argument position.  Hence, if the continuation
 142 is interesting (eg. a case scrutinee, application etc.) then we
 143 inline, otherwise we don't.
 144
 145 Previously some_benefit used to return True only if the variable was
 146 applied to some value arguments.  This didn't work:
 147
 148         let x = _coerce_ (T Int) Int (I# 3) in
 149         case _coerce_ Int (T Int) x of
 150                 I# y -> ....
 151
 152 we want to inline x, but can't see that it's a constructor in a case
 153 scrutinee position, and some_benefit is False.
 154
 155 Another example:
 156
 157 dMonadST = _/\_ t -> :Monad (g1 _@_ t, g2 _@_ t, g3 _@_ t)
 158
 159 ....  case dMonadST _@_ x0 of (a,b,c) -> ....
 160
 161 we'd really like to inline dMonadST here, but we *don't* want to
 162 inline if the case expression is just
 163
 164         case x of y { DEFAULT -> ... }
 165
 166 since we can just eliminate this case instead (x is in WHNF).  Similar
 167 applies when x is bound to a lambda expression.  Hence
 168 contIsInteresting looks for case expressions with just a single
 169 default case.
 170
 171 \begin{code}
 172 analyseCont :: InScopeSet -> SimplCont
 173             -> ([Bool],         -- Arg-info flags; one for each value argument
 174                 Bool,           -- Context of the result of the call is interesting
 175                 Bool)           -- There was an InlinePlease
 176
 177 analyseCont in_scope cont
 178   = case cont of
 179         -- The "lone-variable" case is important.  I spent ages
 180         -- messing about with unsatisfactory varaints, but this is nice.
 181         -- The idea is that if a variable appear all alone
 182         --      as an arg of lazy fn, or rhs    Stop
 183         --      as scrutinee of a case          Select
 184         --      as arg of a strict fn           ArgOf
 185         -- then we should not inline it (unless there is some other reason,
 186         -- e.g. is is the sole occurrence).
 187         -- Why not?  At least in the case-scrutinee situation, turning
 188         --      case x of y -> ...
 189         -- into
 190         --      let y = (a,b) in ...
 191         -- is bad if the binding for x will remain.
 192         --
 193         -- Another example: I discovered that strings
 194         -- were getting inlined straight back into applications of 'error'
 195         -- because the latter is strict.
 196         --      s = "foo"
 197         --      f = \x -> ...(error s)...
 198
 199         -- Fundamentally such contexts should not ecourage inlining becuase
 200         -- the context can ``see'' the unfolding of the variable (e.g. case or a RULE)
 201         -- so there's no gain.
 202         --
 203         -- However, even a type application isn't a lone variable.  Consider
 204         --      case $fMonadST @ RealWorld of { :DMonad a b c -> c }
 205         -- We had better inline that sucker!  The case won't see through it.
 206
 207       (Stop _)                    -> boring_result              -- Don't inline a lone variable
 208       (Select _ _ _ _ _)          -> boring_result              -- Ditto
 209       (ArgOf _ _ _)               -> boring_result              -- Ditto
 210       (ApplyTo _ (Type _) _ cont) -> analyse_ty_app cont
 211       other                       -> analyse_app cont
 212   where
 213     boring_result = ([], False, False)
 214
 215                 -- For now, I'm treating not treating a variable applied to types as
 216                 -- "lone". The motivating example was
 217                 --      f = /\a. \x. BIG
 218                 --      g = /\a. \y.  h (f a)
 219                 -- There's no advantage in inlining f here, and perhaps
 220                 -- a significant disadvantage.
 221     analyse_ty_app (Stop _)                     = boring_result
 222     analyse_ty_app (ArgOf _ _ _)                = boring_result
 223     analyse_ty_app (Select _ _ _ _ _)           = ([], True, False)     -- See the $fMonadST example above
 224     analyse_ty_app (ApplyTo _ (Type _) _ cont)  = analyse_ty_app cont
 225     analyse_ty_app cont                         = analyse_app cont
 226
 227     analyse_app (InlinePlease cont)
 228         = case analyse_app cont of
 229                  (infos, icont, inline) -> (infos, icont, True)
 230
 231     analyse_app (ApplyTo _ arg subst cont)
 232         | isValArg arg = case analyse_app cont of
 233                            (infos, icont, inline) -> (analyse_arg subst arg : infos, icont, inline)
 234         | otherwise    = analyse_app cont
 235
 236     analyse_app cont = ([], interesting_call_context cont, False)
 237
 238         -- An argument is interesting if it has *some* structure
 239         -- We are here trying to avoid unfolding a function that
 240         -- is applied only to variables that have no unfolding
 241         -- (i.e. they are probably lambda bound): f x y z
 242         -- There is little point in inlining f here.
 243     analyse_arg :: SubstEnv -> InExpr -> Bool
 244     analyse_arg subst (Var v)           = case lookupIdSubst (mkSubst in_scope subst) v of
 245                                                 DoneId v' _ -> isValueUnfolding (idUnfolding v')
 246                                                 other       -> False
 247     analyse_arg subst (Type _)          = False
 248     analyse_arg subst (App fn (Type _)) = analyse_arg subst fn
 249     analyse_arg subst (Note _ a)        = analyse_arg subst a
 250     analyse_arg subst other             = True
 251
 252     interesting_call_context (Stop ty)                   = canUpdateInPlace ty
 253     interesting_call_context (InlinePlease _)            = True
 254     interesting_call_context (Select _ _ _ _ _)          = True
 255     interesting_call_context (CoerceIt _ cont)           = interesting_call_context cont
 256     interesting_call_context (ApplyTo _ (Type _) _ cont) = interesting_call_context cont
 257     interesting_call_context (ApplyTo _ _        _ _)    = True
 258     interesting_call_context (ArgOf _ _ _)               = True
 259         -- If this call is the arg of a strict function, the context
 260         -- is a bit interesting.  If we inline here, we may get useful
 261         -- evaluation information to avoid repeated evals: e.g.
 262         --      x + (y * z)
 263         -- Here the contIsInteresting makes the '*' keener to inline,
 264         -- which in turn exposes a constructor which makes the '+' inline.
 265         -- Assuming that +,* aren't small enough to inline regardless.
 266         --
 267         -- It's also very important to inline in a strict context for things
 268         -- like
 269         --              foldr k z (f x)
 270         -- Here, the context of (f x) is strict, and if f's unfolding is
 271         -- a build it's *great* to inline it here.  So we must ensure that
 272         -- the context for (f x) is not totally uninteresting.
 273
 274
 275 discardInline :: SimplCont -> SimplCont
 276 discardInline (InlinePlease cont)  = cont
 277 discardInline (ApplyTo d e s cont) = ApplyTo d e s (discardInline cont)
 278 discardInline cont                 = cont
 279
 280 -- Consider   let x = <wurble> in ...
 281 -- If <wurble> returns an explicit constructor, we might be able
 282 -- to do update in place.  So we treat even a thunk RHS context
 283 -- as interesting if update in place is possible.  We approximate
 284 -- this by seeing if the type has a single constructor with a
 285 -- small arity.  But arity zero isn't good -- we share the single copy
 286 -- for that case, so no point in sharing.
 287
 288 canUpdateInPlace ty = case splitAlgTyConApp_maybe ty of
 289                         Just (_, _, [dc]) -> arity == 1 || arity == 2
 290                                           where
 291                                              arity = dataConRepArity dc
 292                         other -> False
 293 \end{code}
 294
 295
 296
 297 %************************************************************************
 298 %*                                                                      *
 299 \section{Dealing with a single binder}
 300 %*                                                                      *
 301 %************************************************************************
 302
 303 \begin{code}
 304 simplBinders :: [InBinder] -> ([OutBinder] -> SimplM a) -> SimplM a
 305 simplBinders bndrs thing_inside
 306   = getSubst            `thenSmpl` \ subst ->
 307     let
 308         (subst', bndrs') = substBndrs subst bndrs
 309     in
 310     seqBndrs bndrs'     `seq`
 311     setSubst subst' (thing_inside bndrs')
 312
 313 simplBinder :: InBinder -> (OutBinder -> SimplM a) -> SimplM a
 314 simplBinder bndr thing_inside
 315   = getSubst            `thenSmpl` \ subst ->
 316     let
 317         (subst', bndr') = substBndr subst bndr
 318     in
 319     seqBndr bndr'       `seq`
 320     setSubst subst' (thing_inside bndr')
 321
 322
 323 -- Same semantics as simplBinders, but a little less
 324 -- plumbing and hence a little more efficient.
 325 -- Maybe not worth the candle?
 326 simplIds :: [InBinder] -> ([OutBinder] -> SimplM a) -> SimplM a
 327 simplIds ids thing_inside
 328   = getSubst            `thenSmpl` \ subst ->
 329     let
 330         (subst', bndrs') = substIds subst ids
 331     in
 332     seqBndrs bndrs'     `seq`
 333     setSubst subst' (thing_inside bndrs')
 334
 335 seqBndrs [] = ()
 336 seqBndrs (b:bs) = seqBndr b `seq` seqBndrs bs
 337
 338 seqBndr b | isTyVar b = b `seq` ()
 339           | otherwise = seqType (idType b)      `seq`
 340                         idInfo b                `seq`
 341                         ()
 342 \end{code}
 343
 344
 345 %************************************************************************
 346 %*                                                                      *
 347 \subsection{Transform a RHS}
 348 %*                                                                      *
 349 %************************************************************************
 350
 351 Try (a) eta expansion
 352     (b) type-lambda swizzling
 353
 354 \begin{code}
 355 transformRhs :: InExpr -> SimplM InExpr
 356 transformRhs rhs
 357   = tryEtaExpansion body                `thenSmpl` \ body' ->
 358     mkRhsTyLam tyvars body'
 359   where
 360     (tyvars, body) = collectTyBinders rhs
 361 \end{code}
 362
 363
 364 %************************************************************************
 365 %*                                                                      *
 366 \subsection{Local tyvar-lifting}
 367 %*                                                                      *
 368 %************************************************************************
 369
 370 mkRhsTyLam tries this transformation, when the big lambda appears as
 371 the RHS of a let(rec) binding:
 372
 373         /\abc -> let(rec) x = e in b
 374    ==>
 375         let(rec) x' = /\abc -> let x = x' a b c in e
 376         in
 377         /\abc -> let x = x' a b c in b
 378
 379 This is good because it can turn things like:
 380
 381         let f = /\a -> letrec g = ... g ... in g
 382 into
 383         letrec g' = /\a -> ... g' a ...
 384         in
 385         let f = /\ a -> g' a
 386
 387 which is better.  In effect, it means that big lambdas don't impede
 388 let-floating.
 389
 390 This optimisation is CRUCIAL in eliminating the junk introduced by
 391 desugaring mutually recursive definitions.  Don't eliminate it lightly!
 392
 393 So far as the implemtation is concerned:
 394
 395         Invariant: go F e = /\tvs -> F e
 396
 397         Equalities:
 398                 go F (Let x=e in b)
 399                 = Let x' = /\tvs -> F e
 400                   in
 401                   go G b
 402                 where
 403                     G = F . Let x = x' tvs
 404
 405                 go F (Letrec xi=ei in b)
 406                 = Letrec {xi' = /\tvs -> G ei}
 407                   in
 408                   go G b
 409                 where
 410                   G = F . Let {xi = xi' tvs}
 411
 412 [May 1999]  If we do this transformation *regardless* then we can
 413 end up with some pretty silly stuff.  For example,
 414
 415         let
 416             st = /\ s -> let { x1=r1 ; x2=r2 } in ...
 417         in ..
 418 becomes
 419         let y1 = /\s -> r1
 420             y2 = /\s -> r2
 421             st = /\s -> ...[y1 s/x1, y2 s/x2]
 422         in ..
 423
 424 Unless the "..." is a WHNF there is really no point in doing this.
 425 Indeed it can make things worse.  Suppose x1 is used strictly,
 426 and is of the form
 427
 428         x1* = case f y of { (a,b) -> e }
 429
 430 If we abstract this wrt the tyvar we then can't do the case inline
 431 as we would normally do.
 432
 433
 434 \begin{code}
 435 mkRhsTyLam tyvars body                  -- Only does something if there's a let
 436   | null tyvars || not (worth_it body)  -- inside a type lambda, and a WHNF inside that
 437   = returnSmpl (mkLams tyvars body)
 438   | otherwise
 439   = go (\x -> x) body
 440   where
 441     worth_it (Let _ e)       = whnf_in_middle e
 442     worth_it other           = False
 443     whnf_in_middle (Let _ e) = whnf_in_middle e
 444     whnf_in_middle e         = exprIsCheap e
 445
 446     main_tyvar_set = mkVarSet tyvars
 447
 448     go fn (Let bind@(NonRec var rhs) body) | exprIsTrivial rhs
 449       = go (fn . Let bind) body
 450
 451     go fn (Let bind@(NonRec var rhs) body)
 452       = mk_poly tyvars_here var                         `thenSmpl` \ (var', rhs') ->
 453         go (fn . Let (mk_silly_bind var rhs')) body     `thenSmpl` \ body' ->
 454         returnSmpl (Let (NonRec var' (mkLams tyvars_here (fn rhs))) body')
 455       where
 456         tyvars_here = tyvars
 457                 -- varSetElems (main_tyvar_set `intersectVarSet` tyVarsOfType var_ty)
 458                 -- tyvars_here was an attempt to reduce the number of tyvars
 459                 -- wrt which the new binding is abstracted.  But the naive
 460                 -- approach of abstract wrt the tyvars free in the Id's type
 461                 -- fails. Consider:
 462                 --      /\ a b -> let t :: (a,b) = (e1, e2)
 463                 --                    x :: a     = fst t
 464                 --                in ...
 465                 -- Here, b isn't free in x's type, but we must nevertheless
 466                 -- abstract wrt b as well, because t's type mentions b.
 467                 -- Since t is floated too, we'd end up with the bogus:
 468                 --      poly_t = /\ a b -> (e1, e2)
 469                 --      poly_x = /\ a   -> fst (poly_t a *b*)
 470                 -- So for now we adopt the even more naive approach of
 471                 -- abstracting wrt *all* the tyvars.  We'll see if that
 472                 -- gives rise to problems.   SLPJ June 98
 473
 474         var_ty = idType var
 475
 476     go fn (Let (Rec prs) body)
 477        = mapAndUnzipSmpl (mk_poly tyvars_here) vars     `thenSmpl` \ (vars', rhss') ->
 478          let
 479             gn body = fn $ foldr Let body (zipWith mk_silly_bind vars rhss')
 480          in
 481          go gn body                             `thenSmpl` \ body' ->
 482          returnSmpl (Let (Rec (vars' `zip` [mkLams tyvars_here (gn rhs) | rhs <- rhss])) body')
 483        where
 484          (vars,rhss) = unzip prs
 485          tyvars_here = tyvars
 486                 -- varSetElems (main_tyvar_set `intersectVarSet` tyVarsOfTypes var_tys)
 487                 -- See notes with tyvars_here above
 488
 489          var_tys     = map idType vars
 490
 491     go fn body = returnSmpl (mkLams tyvars (fn body))
 492
 493     mk_poly tyvars_here var
 494       = getUniqueSmpl           `thenSmpl` \ uniq ->
 495         let
 496             poly_name = setNameUnique (idName var) uniq         -- Keep same name
 497             poly_ty   = mkForAllTys tyvars_here (idType var)    -- But new type of course
 498
 499                 -- It's crucial to copy the occInfo of the original var, because
 500                 -- we're looking at occurrence-analysed but as yet unsimplified code!
 501                 -- In particular, we mustn't lose the loop breakers.
 502                 --
 503                 -- It's even right to retain single-occurrence or dead-var info:
 504                 -- Suppose we started with  /\a -> let x = E in B
 505                 -- where x occurs once in E. Then we transform to:
 506                 --      let x' = /\a -> E in /\a -> let x* = x' a in B
 507                 -- where x* has an INLINE prag on it.  Now, once x* is inlined,
 508                 -- the occurrences of x' will be just the occurrences originaly
 509                 -- pinned on x.
 510             poly_info = vanillaIdInfo `setOccInfo` idOccInfo var
 511
 512             poly_id   = mkId poly_name poly_ty poly_info
 513         in
 514         returnSmpl (poly_id, mkTyApps (Var poly_id) (mkTyVarTys tyvars_here))
 515
 516     mk_silly_bind var rhs = NonRec var rhs
 517                 -- The Inline note is really important!  If we don't say
 518                 -- INLINE on these silly little bindings then look what happens!
 519                 -- Suppose we start with:
 520                 --
 521                 --      x = let g = /\a -> \x -> f x x
 522                 --          in
 523                 --          /\ b -> let g* = g b in E
 524                 --
 525                 -- Then:        * the binding for g gets floated out
 526                 --              * but then it gets inlined into the rhs of g*
 527                 --              * then the binding for g* is floated out of the /\b
 528                 --              * so we're back to square one
 529                 -- The silly binding for g* must be INLINEd, so that
 530                 -- we simply substitute for g* throughout.
 531 \end{code}
 532
 533
 534 %************************************************************************
 535 %*                                                                      *
 536 \subsection{Eta expansion}
 537 %*                                                                      *
 538 %************************************************************************
 539
 540         Try eta expansion for RHSs
 541
 542 We go for:
 543                 \x1..xn -> N    ==>   \x1..xn y1..ym -> N y1..ym
 544         AND
 545                 N E1..En        ==>   let z1=E1 .. zn=En in \y1..ym -> N z1..zn y1..ym
 546
 547 where (in both cases) N is a NORMAL FORM (i.e. no redexes anywhere)
 548 wanting a suitable number of extra args.
 549
 550 NB: the Ei may have unlifted type, but the simplifier (which is applied
 551 to the result) deals OK with this.
 552
 553 There is no point in looking for a combination of the two,
 554 because that would leave use with some lets sandwiched between lambdas;
 555 that's what the final test in the first equation is for.
 556
 557 \begin{code}
 558 tryEtaExpansion :: InExpr -> SimplM InExpr
 559 tryEtaExpansion rhs
 560   |  not opt_SimplDoLambdaEtaExpansion
 561   || exprIsTrivial rhs                          -- Don't eta-expand a trival RHS
 562   || null y_tys                                 -- No useful expansion
 563   || not (null x_bndrs || and trivial_args)     -- Not (no x-binders or no z-binds)
 564   = returnSmpl rhs
 565
 566   | otherwise   -- Consider eta expansion
 567   = newIds y_tys                                                $ ( \ y_bndrs ->
 568     tick (EtaExpansion (head y_bndrs))                          `thenSmpl_`
 569     mapAndUnzipSmpl bind_z_arg (args `zip` trivial_args)        `thenSmpl` (\ (maybe_z_binds, z_args) ->
 570     returnSmpl (mkLams x_bndrs                          $
 571                 mkLets (catMaybes maybe_z_binds)        $
 572                 mkLams y_bndrs                          $
 573                 mkApps (mkApps fun z_args) (map Var y_bndrs))))
 574   where
 575     (x_bndrs, body) = collectValBinders rhs
 576     (fun, args)     = collectArgs body
 577     trivial_args    = map exprIsTrivial args
 578     fun_arity       = exprEtaExpandArity fun
 579
 580     bind_z_arg (arg, trivial_arg)
 581         | trivial_arg = returnSmpl (Nothing, arg)
 582         | otherwise   = newId (exprType arg)    $ \ z ->
 583                         returnSmpl (Just (NonRec z arg), Var z)
 584
 585         -- Note: I used to try to avoid the exprType call by using
 586         -- the type of the binder.  But this type doesn't necessarily
 587         -- belong to the same substitution environment as this rhs;
 588         -- and we are going to make extra term binders (y_bndrs) from the type
 589         -- which will be processed with the rhs substitution environment.
 590         -- This only went wrong in a mind bendingly complicated case.
 591     (potential_extra_arg_tys, inner_ty) = splitFunTys (exprType body)
 592
 593     y_tys :: [InType]
 594     y_tys  = take no_extras_wanted potential_extra_arg_tys
 595
 596     no_extras_wanted :: Int
 597     no_extras_wanted = 0 `max`
 598
 599         -- We used to expand the arity to the previous arity fo the
 600         -- function; but this is pretty dangerous.  Consdier
 601         --      f = \xy -> e
 602         -- so that f has arity 2.  Now float something into f's RHS:
 603         --      f = let z = BIG in \xy -> e
 604         -- The last thing we want to do now is to put some lambdas
 605         -- outside, to get
 606         --      f = \xy -> let z = BIG in e
 607         --
 608         -- (bndr_arity - no_of_xs)              `max`
 609
 610         -- See if the body could obviously do with more args
 611         (fun_arity - valArgCount args)
 612
 613 -- This case is now deal with by exprEtaExpandArity
 614         -- Finally, see if it's a state transformer, and xs is non-null
 615         -- (so it's also a function not a thunk) in which
 616         -- case we eta-expand on principle! This can waste work,
 617         -- but usually doesn't.
 618         -- I originally checked for a singleton type [ty] in this case
 619         -- but then I found a situation in which I had
 620         --      \ x -> let {..} in \ s -> f (...) s
 621         -- AND f RETURNED A FUNCTION.  That is, 's' wasn't the only
 622         -- potential extra arg.
 623 --      case (x_bndrs, potential_extra_arg_tys) of
 624 --          (_:_, ty:_)  -> case splitTyConApp_maybe ty of
 625 --                                Just (tycon,_) | tycon == statePrimTyCon -> 1
 626 --                                other                                    -> 0
 627 --          other -> 0
 628 \end{code}
 629
 630
 631 %************************************************************************
 632 %*                                                                      *
 633 \subsection{Case absorption and identity-case elimination}
 634 %*                                                                      *
 635 %************************************************************************
 636
 637 \begin{code}
 638 mkCase :: OutExpr -> OutId -> [OutAlt] -> SimplM OutExpr
 639 \end{code}
 640
 641 @mkCase@ tries the following transformation (if possible):
 642
 643 case e of b {             ==>   case e of b {
 644   p1 -> rhs1                      p1 -> rhs1
 645   ...                             ...
 646   pm -> rhsm                      pm -> rhsm
 647   _  -> case b of b' {            pn -> rhsn[b/b'] {or (alg)  let b=b' in rhsn}
 648                                                    {or (prim) case b of b' { _ -> rhsn}}
 649               pn -> rhsn          ...
 650               ...                 po -> rhso[b/b']
 651               po -> rhso          _  -> rhsd[b/b'] {or let b'=b in rhsd}
 652               _  -> rhsd
 653 }
 654
 655 which merges two cases in one case when -- the default alternative of
 656 the outer case scrutises the same variable as the outer case This
 657 transformation is called Case Merging.  It avoids that the same
 658 variable is scrutinised multiple times.
 659
 660 \begin{code}
 661 mkCase scrut outer_bndr outer_alts
 662   |  opt_SimplCaseMerge
 663   && maybeToBool maybe_case_in_default
 664
 665   = tick (CaseMerge outer_bndr)         `thenSmpl_`
 666     returnSmpl (Case scrut outer_bndr new_alts)
 667         -- Warning: don't call mkCase recursively!
 668         -- Firstly, there's no point, because inner alts have already had
 669         -- mkCase applied to them, so they won't have a case in their default
 670         -- Secondly, if you do, you get an infinite loop, because the bindNonRec
 671         -- in munge_rhs puts a case into the DEFAULT branch!
 672   where
 673     new_alts = outer_alts_without_deflt ++ munged_inner_alts
 674     maybe_case_in_default = case findDefault outer_alts of
 675                                 (outer_alts_without_default,
 676                                  Just (Case (Var scrut_var) inner_bndr inner_alts))
 677
 678                                    | outer_bndr == scrut_var
 679                                    -> Just (outer_alts_without_default, inner_bndr, inner_alts)
 680                                 other -> Nothing
 681
 682     Just (outer_alts_without_deflt, inner_bndr, inner_alts) = maybe_case_in_default
 683
 684                 --  Eliminate any inner alts which are shadowed by the outer ones
 685     outer_cons = [con | (con,_,_) <- outer_alts_without_deflt]
 686
 687     munged_inner_alts = [ (con, args, munge_rhs rhs)
 688                         | (con, args, rhs) <- inner_alts,
 689                            not (con `elem` outer_cons)  -- Eliminate shadowed inner alts
 690                         ]
 691     munge_rhs rhs = bindNonRec inner_bndr (Var outer_bndr) rhs
 692 \end{code}
 693
 694 Now the identity-case transformation:
 695
 696         case e of               ===> e
 697                 True -> True;
 698                 False -> False
 699
 700 and similar friends.
 701
 702 \begin{code}
 703 mkCase scrut case_bndr alts
 704   | all identity_alt alts
 705   = tick (CaseIdentity case_bndr)               `thenSmpl_`
 706     returnSmpl scrut
 707   where
 708     identity_alt (DEFAULT, [], Var v)     = v == case_bndr
 709     identity_alt (DataAlt con, args, rhs) = cheapEqExpr rhs
 710                                                         (mkConApp con (map Type arg_tys ++ map varToCoreExpr args))
 711     identity_alt other                    = False
 712
 713     arg_tys = case splitTyConApp_maybe (idType case_bndr) of
 714                 Just (tycon, arg_tys) -> arg_tys
 715 \end{code}
 716
 717 The catch-all case
 718
 719 \begin{code}
 720 mkCase other_scrut case_bndr other_alts
 721   = returnSmpl (Case other_scrut case_bndr other_alts)
 722 \end{code}
 723
 724
 725 \begin{code}
 726 findDefault :: [CoreAlt] -> ([CoreAlt], Maybe CoreExpr)
 727 findDefault []                          = ([], Nothing)
 728 findDefault ((DEFAULT,args,rhs) : alts) = ASSERT( null alts && null args )
 729                                           ([], Just rhs)
 730 findDefault (alt : alts)                = case findDefault alts of
 731                                             (alts', deflt) -> (alt : alts', deflt)
 732
 733 findAlt :: AltCon -> [CoreAlt] -> CoreAlt
 734 findAlt con alts
 735   = go alts
 736   where
 737     go []           = pprPanic "Missing alternative" (ppr con $$ vcat (map ppr alts))
 738     go (alt : alts) | matches alt = alt
 739                     | otherwise   = go alts
 740
 741     matches (DEFAULT, _, _) = True
 742     matches (con1, _, _)    = con == con1
 743 \end{code}