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