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 CmdLineOpts      ( opt_SimplDoLambdaEtaExpansion, opt_SimplCaseMerge )
  22 import CoreSyn
  23 import CoreUnfold       ( isValueUnfolding )
  24 import CoreUtils        ( exprIsTrivial, cheapEqExpr, exprType, exprIsCheap, exprEtaExpandArity, bindNonRec )
  25 import Subst            ( InScopeSet, mkSubst, substBndrs, substBndr, substIds, lookupIdSubst )
  26 import Id               ( Id, idType, isId, idName,
  27                           idOccInfo, idUnfolding,
  28                           mkId, idInfo
  29                         )
  30 import IdInfo           ( arityLowerBound, setOccInfo, vanillaIdInfo )
  31 import Maybes           ( maybeToBool, catMaybes )
  32 import Name             ( isLocalName, setNameUnique )
  33 import SimplMonad
  34 import Type             ( Type, tyVarsOfType, tyVarsOfTypes, mkForAllTys, seqType, repType,
  35                           splitTyConApp_maybe, mkTyVarTys, applyTys, splitFunTys, mkFunTys
  36                         )
  37 import TyCon            ( tyConDataConsIfAvailable )
  38 import DataCon          ( dataConRepArity )
  39 import VarSet
  40 import VarEnv           ( SubstEnv, SubstResult(..) )
  41 import Outputable
  42 \end{code}
  43
  44
  45 %************************************************************************
  46 %*                                                                      *
  47 \subsection{The continuation data type}
  48 %*                                                                      *
  49 %************************************************************************
  50
  51 \begin{code}
  52 data SimplCont          -- Strict contexts
  53   = Stop OutType                -- Type of the result
  54
  55   | CoerceIt OutType                    -- The To-type, simplified
  56              SimplCont
  57
  58   | InlinePlease                        -- This continuation makes a function very
  59              SimplCont                  -- keen to inline itelf
  60
  61   | ApplyTo  DupFlag
  62              InExpr SubstEnv            -- The argument, as yet unsimplified,
  63              SimplCont                  -- and its subst-env
  64
  65   | Select   DupFlag
  66              InId [InAlt] SubstEnv      -- The case binder, alts, and subst-env
  67              SimplCont
  68
  69   | ArgOf    DupFlag            -- An arbitrary strict context: the argument
  70                                 --      of a strict function, or a primitive-arg fn
  71                                 --      or a PrimOp
  72              OutType            -- The type of the expression being sought by the context
  73                                 --      f (error "foo") ==> coerce t (error "foo")
  74                                 -- when f is strict
  75                                 -- We need to know the type t, to which to coerce.
  76              (OutExpr -> SimplM OutExprStuff)   -- What to do with the result
  77
  78 instance Outputable SimplCont where
  79   ppr (Stop _)                       = ptext SLIT("Stop")
  80   ppr (ApplyTo dup arg se cont)      = (ptext SLIT("ApplyTo") <+> ppr dup <+> ppr arg) $$ ppr cont
  81   ppr (ArgOf   dup _ _)              = ptext SLIT("ArgOf...") <+> ppr dup
  82   ppr (Select dup bndr alts se cont) = (ptext SLIT("Select") <+> ppr dup <+> ppr bndr) $$
  83                                        (nest 4 (ppr alts)) $$ ppr cont
  84   ppr (CoerceIt ty cont)             = (ptext SLIT("CoerceIt") <+> ppr ty) $$ ppr cont
  85   ppr (InlinePlease cont)            = ptext SLIT("InlinePlease") $$ ppr cont
  86
  87 data DupFlag = OkToDup | NoDup
  88
  89 instance Outputable DupFlag where
  90   ppr OkToDup = ptext SLIT("ok")
  91   ppr NoDup   = ptext SLIT("nodup")
  92
  93 contIsDupable :: SimplCont -> Bool
  94 contIsDupable (Stop _)                   = True
  95 contIsDupable (ApplyTo  OkToDup _ _ _)   = True
  96 contIsDupable (ArgOf    OkToDup _ _)     = True
  97 contIsDupable (Select   OkToDup _ _ _ _) = True
  98 contIsDupable (CoerceIt _ cont)          = contIsDupable cont
  99 contIsDupable (InlinePlease cont)        = contIsDupable cont
 100 contIsDupable other                      = False
 101
 102 pushArgs :: SubstEnv -> [InExpr] -> SimplCont -> SimplCont
 103 pushArgs se []         cont = cont
 104 pushArgs se (arg:args) cont = ApplyTo NoDup arg se (pushArgs se args cont)
 105
 106 discardCont :: SimplCont        -- A continuation, expecting
 107             -> SimplCont        -- Replace the continuation with a suitable coerce
 108 discardCont (Stop to_ty) = Stop to_ty
 109 discardCont cont         = CoerceIt to_ty (Stop to_ty)
 110                          where
 111                            to_ty = contResultType cont
 112
 113 contResultType :: SimplCont -> OutType
 114 contResultType (Stop to_ty)          = to_ty
 115 contResultType (ArgOf _ to_ty _)     = to_ty
 116 contResultType (ApplyTo _ _ _ cont)  = contResultType cont
 117 contResultType (CoerceIt _ cont)     = contResultType cont
 118 contResultType (InlinePlease cont)   = contResultType cont
 119 contResultType (Select _ _ _ _ cont) = contResultType cont
 120
 121 countValArgs :: SimplCont -> Int
 122 countValArgs (ApplyTo _ (Type ty) se cont) = countValArgs cont
 123 countValArgs (ApplyTo _ val_arg   se cont) = 1 + countValArgs cont
 124 countValArgs other                         = 0
 125
 126 countArgs :: SimplCont -> Int
 127 countArgs (ApplyTo _ arg se cont) = 1 + countArgs cont
 128 countArgs other                   = 0
 129 \end{code}
 130
 131
 132 Comment about analyseCont
 133 ~~~~~~~~~~~~~~~~~~~~~~~~~
 134 We want to avoid inlining an expression where there can't possibly be
 135 any gain, such as in an argument position.  Hence, if the continuation
 136 is interesting (eg. a case scrutinee, application etc.) then we
 137 inline, otherwise we don't.
 138
 139 Previously some_benefit used to return True only if the variable was
 140 applied to some value arguments.  This didn't work:
 141
 142         let x = _coerce_ (T Int) Int (I# 3) in
 143         case _coerce_ Int (T Int) x of
 144                 I# y -> ....
 145
 146 we want to inline x, but can't see that it's a constructor in a case
 147 scrutinee position, and some_benefit is False.
 148
 149 Another example:
 150
 151 dMonadST = _/\_ t -> :Monad (g1 _@_ t, g2 _@_ t, g3 _@_ t)
 152
 153 ....  case dMonadST _@_ x0 of (a,b,c) -> ....
 154
 155 we'd really like to inline dMonadST here, but we *don't* want to
 156 inline if the case expression is just
 157
 158         case x of y { DEFAULT -> ... }
 159
 160 since we can just eliminate this case instead (x is in WHNF).  Similar
 161 applies when x is bound to a lambda expression.  Hence
 162 contIsInteresting looks for case expressions with just a single
 163 default case.
 164
 165 \begin{code}
 166 analyseCont :: InScopeSet -> SimplCont
 167             -> ([Bool],         -- Arg-info flags; one for each value argument
 168                 Bool,           -- Context of the result of the call is interesting
 169                 Bool)           -- There was an InlinePlease
 170
 171 analyseCont in_scope cont
 172   = case cont of
 173         -- The "lone-variable" case is important.  I spent ages
 174         -- messing about with unsatisfactory varaints, but this is nice.
 175         -- The idea is that if a variable appear all alone
 176         --      as an arg of lazy fn, or rhs    Stop
 177         --      as scrutinee of a case          Select
 178         --      as arg of a strict fn           ArgOf
 179         -- then we should not inline it (unless there is some other reason,
 180         -- e.g. is is the sole occurrence).
 181         -- Why not?  At least in the case-scrutinee situation, turning
 182         --      case x of y -> ...
 183         -- into
 184         --      let y = (a,b) in ...
 185         -- is bad if the binding for x will remain.
 186         --
 187         -- Another example: I discovered that strings
 188         -- were getting inlined straight back into applications of 'error'
 189         -- because the latter is strict.
 190         --      s = "foo"
 191         --      f = \x -> ...(error s)...
 192
 193         -- Fundamentally such contexts should not ecourage inlining becuase
 194         -- the context can ``see'' the unfolding of the variable (e.g. case or a RULE)
 195         -- so there's no gain.
 196         --
 197         -- However, even a type application isn't a lone variable.  Consider
 198         --      case $fMonadST @ RealWorld of { :DMonad a b c -> c }
 199         -- We had better inline that sucker!  The case won't see through it.
 200
 201       (Stop _)                    -> boring_result              -- Don't inline a lone variable
 202       (Select _ _ _ _ _)          -> boring_result              -- Ditto
 203       (ArgOf _ _ _)               -> boring_result              -- Ditto
 204       (ApplyTo _ (Type _) _ cont) -> analyse_ty_app cont
 205       other                       -> analyse_app cont
 206   where
 207     boring_result = ([], False, False)
 208
 209                 -- For now, I'm treating not treating a variable applied to types as
 210                 -- "lone". The motivating example was
 211                 --      f = /\a. \x. BIG
 212                 --      g = /\a. \y.  h (f a)
 213                 -- There's no advantage in inlining f here, and perhaps
 214                 -- a significant disadvantage.
 215     analyse_ty_app (Stop _)                     = boring_result
 216     analyse_ty_app (ArgOf _ _ _)                = boring_result
 217     analyse_ty_app (Select _ _ _ _ _)           = ([], True, False)     -- See the $fMonadST example above
 218     analyse_ty_app (ApplyTo _ (Type _) _ cont)  = analyse_ty_app cont
 219     analyse_ty_app cont                         = analyse_app cont
 220
 221     analyse_app (InlinePlease cont)
 222         = case analyse_app cont of
 223                  (infos, icont, inline) -> (infos, icont, True)
 224
 225     analyse_app (ApplyTo _ arg subst cont)
 226         | isValArg arg = case analyse_app cont of
 227                            (infos, icont, inline) -> (analyse_arg subst arg : infos, icont, inline)
 228         | otherwise    = analyse_app cont
 229
 230     analyse_app cont = ([], interesting_call_context cont, False)
 231
 232         -- An argument is interesting if it has *some* structure
 233         -- We are here trying to avoid unfolding a function that
 234         -- is applied only to variables that have no unfolding
 235         -- (i.e. they are probably lambda bound): f x y z
 236         -- There is little point in inlining f here.
 237     analyse_arg :: SubstEnv -> InExpr -> Bool
 238     analyse_arg subst (Var v)           = case lookupIdSubst (mkSubst in_scope subst) v of
 239                                                 DoneId v' _ -> isValueUnfolding (idUnfolding v')
 240                                                 other       -> False
 241     analyse_arg subst (Type _)          = False
 242     analyse_arg subst (App fn (Type _)) = analyse_arg subst fn
 243     analyse_arg subst (Note _ a)        = analyse_arg subst a
 244     analyse_arg subst other             = True
 245
 246     interesting_call_context (Stop ty)                   = canUpdateInPlace ty
 247     interesting_call_context (InlinePlease _)            = True
 248     interesting_call_context (Select _ _ _ _ _)          = True
 249     interesting_call_context (CoerceIt _ cont)           = interesting_call_context cont
 250     interesting_call_context (ApplyTo _ (Type _) _ cont) = interesting_call_context cont
 251     interesting_call_context (ApplyTo _ _        _ _)    = True
 252     interesting_call_context (ArgOf _ _ _)               = True
 253         -- If this call is the arg of a strict function, the context
 254         -- is a bit interesting.  If we inline here, we may get useful
 255         -- evaluation information to avoid repeated evals: e.g.
 256         --      x + (y * z)
 257         -- Here the contIsInteresting makes the '*' keener to inline,
 258         -- which in turn exposes a constructor which makes the '+' inline.
 259         -- Assuming that +,* aren't small enough to inline regardless.
 260         --
 261         -- It's also very important to inline in a strict context for things
 262         -- like
 263         --              foldr k z (f x)
 264         -- Here, the context of (f x) is strict, and if f's unfolding is
 265         -- a build it's *great* to inline it here.  So we must ensure that
 266         -- the context for (f x) is not totally uninteresting.
 267
 268
 269 discardInline :: SimplCont -> SimplCont
 270 discardInline (InlinePlease cont)  = cont
 271 discardInline (ApplyTo d e s cont) = ApplyTo d e s (discardInline cont)
 272 discardInline cont                 = cont
 273
 274 -- Consider   let x = <wurble> in ...
 275 -- If <wurble> returns an explicit constructor, we might be able
 276 -- to do update in place.  So we treat even a thunk RHS context
 277 -- as interesting if update in place is possible.  We approximate
 278 -- this by seeing if the type has a single constructor with a
 279 -- small arity.  But arity zero isn't good -- we share the single copy
 280 -- for that case, so no point in sharing.
 281
 282 -- Note the repType: we want to look through newtypes for this purpose
 283
 284 canUpdateInPlace ty = case splitTyConApp_maybe (repType ty) of {
 285                         Nothing         -> False ;
 286                         Just (tycon, _) ->
 287
 288                       case tyConDataConsIfAvailable tycon of
 289                         [dc]  -> arity == 1 || arity == 2
 290                               where
 291                                  arity = dataConRepArity dc
 292                         other -> False
 293                       }
 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
 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                 --      main_tyvar_set = mkVarSet tyvars
 458                 --      var_ty = idType var
 459                 -- varSetElems (main_tyvar_set `intersectVarSet` tyVarsOfType var_ty)
 460                 -- tyvars_here was an attempt to reduce the number of tyvars
 461                 -- wrt which the new binding is abstracted.  But the naive
 462                 -- approach of abstract wrt the tyvars free in the Id's type
 463                 -- fails. Consider:
 464                 --      /\ a b -> let t :: (a,b) = (e1, e2)
 465                 --                    x :: a     = fst t
 466                 --                in ...
 467                 -- Here, b isn't free in x's type, but we must nevertheless
 468                 -- abstract wrt b as well, because t's type mentions b.
 469                 -- Since t is floated too, we'd end up with the bogus:
 470                 --      poly_t = /\ a b -> (e1, e2)
 471                 --      poly_x = /\ a   -> fst (poly_t a *b*)
 472                 -- So for now we adopt the even more naive approach of
 473                 -- abstracting wrt *all* the tyvars.  We'll see if that
 474                 -- gives rise to problems.   SLPJ June 98
 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                 --       var_tys     = map idType vars
 488                 -- See notes with tyvars_here above
 489
 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 SLIT("y") 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 SLIT("z") (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, _) = 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}