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