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, simplRecIds, simplLetId, simplLamBinder,
   9         tryRhsTyLam, tryEtaExpansion,
  10         mkCase,
  11
  12         -- The continuation type
  13         SimplCont(..), DupFlag(..), contIsDupable, contResultType,
  14         countValArgs, countArgs, mkRhsStop, mkStop,
  15         getContArgs, interestingCallContext, interestingArg, isStrictType, discardInline
  16
  17     ) where
  18
  19 #include "HsVersions.h"
  20
  21 import CmdLineOpts      ( switchIsOn, SimplifierSwitch(..),
  22                           opt_SimplDoLambdaEtaExpansion, opt_SimplCaseMerge,
  23                           opt_UF_UpdateInPlace
  24                         )
  25 import CoreSyn
  26 import CoreUtils        ( exprIsTrivial, cheapEqExpr, exprType, exprIsCheap,
  27                           etaExpand, exprEtaExpandArity, bindNonRec, mkCoerce,
  28                           findDefault
  29                         )
  30 import Subst            ( InScopeSet, mkSubst, substExpr )
  31 import qualified Subst  ( simplBndrs, simplBndr, simplLetId, simplLamBndr )
  32 import Id               ( idType, idName,
  33                           idUnfolding, idNewStrictness,
  34                           mkLocalId, idInfo
  35                         )
  36 import Maybes           ( maybeToBool, catMaybes )
  37 import Name             ( setNameUnique )
  38 import NewDemand        ( isStrictDmd, isBotRes, splitStrictSig )
  39 import SimplMonad
  40 import Type             ( Type, mkForAllTys, seqType,
  41                           splitTyConApp_maybe, tyConAppArgs, mkTyVarTys,
  42                           isUnLiftedType, isStrictType,
  43                           splitRepFunTys
  44                         )
  45 import TyCon            ( tyConDataConsIfAvailable )
  46 import DataCon          ( dataConRepArity )
  47 import VarEnv           ( SubstEnv )
  48 import Util             ( lengthExceeds, mapAccumL )
  49 import Outputable
  50 \end{code}
  51
  52
  53 %************************************************************************
  54 %*                                                                      *
  55 \subsection{The continuation data type}
  56 %*                                                                      *
  57 %************************************************************************
  58
  59 \begin{code}
  60 data SimplCont          -- Strict contexts
  61   = Stop     OutType            -- Type of the result
  62              Bool               -- True => This is the RHS of a thunk whose type suggests
  63                                 --         that update-in-place would be possible
  64                                 --         (This makes the inliner a little keener.)
  65
  66   | CoerceIt OutType                    -- The To-type, simplified
  67              SimplCont
  68
  69   | InlinePlease                        -- This continuation makes a function very
  70              SimplCont                  -- keen to inline itelf
  71
  72   | ApplyTo  DupFlag
  73              InExpr SubstEnv            -- The argument, as yet unsimplified,
  74              SimplCont                  -- and its subst-env
  75
  76   | Select   DupFlag
  77              InId [InAlt] SubstEnv      -- The case binder, alts, and subst-env
  78              SimplCont
  79
  80   | ArgOf    DupFlag            -- An arbitrary strict context: the argument
  81                                 --      of a strict function, or a primitive-arg fn
  82                                 --      or a PrimOp
  83              OutType            -- cont_ty: the type of the expression being sought by the context
  84                                 --      f (error "foo") ==> coerce t (error "foo")
  85                                 -- when f is strict
  86                                 -- We need to know the type t, to which to coerce.
  87              (OutExpr -> SimplM OutExprStuff)   -- What to do with the result
  88                                 -- The result expression in the OutExprStuff has type cont_ty
  89
  90 instance Outputable SimplCont where
  91   ppr (Stop _ _)                     = ptext SLIT("Stop")
  92   ppr (ApplyTo dup arg se cont)      = (ptext SLIT("ApplyTo") <+> ppr dup <+> ppr arg) $$ ppr cont
  93   ppr (ArgOf   dup _ _)              = ptext SLIT("ArgOf...") <+> ppr dup
  94   ppr (Select dup bndr alts se cont) = (ptext SLIT("Select") <+> ppr dup <+> ppr bndr) $$
  95                                        (nest 4 (ppr alts)) $$ ppr cont
  96   ppr (CoerceIt ty cont)             = (ptext SLIT("CoerceIt") <+> ppr ty) $$ ppr cont
  97   ppr (InlinePlease cont)            = ptext SLIT("InlinePlease") $$ ppr cont
  98
  99 data DupFlag = OkToDup | NoDup
 100
 101 instance Outputable DupFlag where
 102   ppr OkToDup = ptext SLIT("ok")
 103   ppr NoDup   = ptext SLIT("nodup")
 104
 105
 106 -------------------
 107 mkRhsStop, mkStop :: OutType -> SimplCont
 108 mkStop    ty = Stop ty False
 109 mkRhsStop ty = Stop ty (canUpdateInPlace ty)
 110
 111
 112 -------------------
 113 contIsDupable :: SimplCont -> Bool
 114 contIsDupable (Stop _ _)                 = True
 115 contIsDupable (ApplyTo  OkToDup _ _ _)   = True
 116 contIsDupable (ArgOf    OkToDup _ _)     = True
 117 contIsDupable (Select   OkToDup _ _ _ _) = True
 118 contIsDupable (CoerceIt _ cont)          = contIsDupable cont
 119 contIsDupable (InlinePlease cont)        = contIsDupable cont
 120 contIsDupable other                      = False
 121
 122 -------------------
 123 discardInline :: SimplCont -> SimplCont
 124 discardInline (InlinePlease cont)  = cont
 125 discardInline (ApplyTo d e s cont) = ApplyTo d e s (discardInline cont)
 126 discardInline cont                 = cont
 127
 128 -------------------
 129 discardableCont :: SimplCont -> Bool
 130 discardableCont (Stop _ _)          = False
 131 discardableCont (CoerceIt _ cont)   = discardableCont cont
 132 discardableCont (InlinePlease cont) = discardableCont cont
 133 discardableCont other               = True
 134
 135 discardCont :: SimplCont        -- A continuation, expecting
 136             -> SimplCont        -- Replace the continuation with a suitable coerce
 137 discardCont cont = case cont of
 138                      Stop to_ty _ -> cont
 139                      other        -> CoerceIt to_ty (mkStop to_ty)
 140                  where
 141                    to_ty = contResultType cont
 142
 143 -------------------
 144 contResultType :: SimplCont -> OutType
 145 contResultType (Stop to_ty _)        = to_ty
 146 contResultType (ArgOf _ to_ty _)     = to_ty
 147 contResultType (ApplyTo _ _ _ cont)  = contResultType cont
 148 contResultType (CoerceIt _ cont)     = contResultType cont
 149 contResultType (InlinePlease cont)   = contResultType cont
 150 contResultType (Select _ _ _ _ cont) = contResultType cont
 151
 152 -------------------
 153 countValArgs :: SimplCont -> Int
 154 countValArgs (ApplyTo _ (Type ty) se cont) = countValArgs cont
 155 countValArgs (ApplyTo _ val_arg   se cont) = 1 + countValArgs cont
 156 countValArgs other                         = 0
 157
 158 countArgs :: SimplCont -> Int
 159 countArgs (ApplyTo _ arg se cont) = 1 + countArgs cont
 160 countArgs other                   = 0
 161 \end{code}
 162
 163
 164 \begin{code}
 165 getContArgs :: OutId -> SimplCont
 166             -> SimplM ([(InExpr, SubstEnv, Bool)],      -- Arguments; the Bool is true for strict args
 167                         SimplCont,                      -- Remaining continuation
 168                         Bool)                           -- Whether we came across an InlineCall
 169 -- getContArgs id k = (args, k', inl)
 170 --      args are the leading ApplyTo items in k
 171 --      (i.e. outermost comes first)
 172 --      augmented with demand info from the functionn
 173 getContArgs fun orig_cont
 174   = getSwitchChecker    `thenSmpl` \ chkr ->
 175     let
 176                 -- Ignore strictness info if the no-case-of-case
 177                 -- flag is on.  Strictness changes evaluation order
 178                 -- and that can change full laziness
 179         stricts | switchIsOn chkr NoCaseOfCase = vanilla_stricts
 180                 | otherwise                    = computed_stricts
 181     in
 182     go [] stricts False orig_cont
 183   where
 184     ----------------------------
 185
 186         -- Type argument
 187     go acc ss inl (ApplyTo _ arg@(Type _) se cont)
 188         = go ((arg,se,False) : acc) ss inl cont
 189                 -- NB: don't bother to instantiate the function type
 190
 191         -- Value argument
 192     go acc (s:ss) inl (ApplyTo _ arg se cont)
 193         = go ((arg,se,s) : acc) ss inl cont
 194
 195         -- An Inline continuation
 196     go acc ss inl (InlinePlease cont)
 197         = go acc ss True cont
 198
 199         -- We're run out of arguments, or else we've run out of demands
 200         -- The latter only happens if the result is guaranteed bottom
 201         -- This is the case for
 202         --      * case (error "hello") of { ... }
 203         --      * (error "Hello") arg
 204         --      * f (error "Hello") where f is strict
 205         --      etc
 206     go acc ss inl cont
 207         | null ss && discardableCont cont = tick BottomFound    `thenSmpl_`
 208                                             returnSmpl (reverse acc, discardCont cont, inl)
 209         | otherwise                       = returnSmpl (reverse acc, cont,             inl)
 210
 211     ----------------------------
 212     vanilla_stricts, computed_stricts :: [Bool]
 213     vanilla_stricts  = repeat False
 214     computed_stricts = zipWith (||) fun_stricts arg_stricts
 215
 216     ----------------------------
 217     (val_arg_tys, _) = splitRepFunTys (idType fun)
 218     arg_stricts      = map isStrictType val_arg_tys ++ repeat False
 219         -- These argument types are used as a cheap and cheerful way to find
 220         -- unboxed arguments, which must be strict.  But it's an InType
 221         -- and so there might be a type variable where we expect a function
 222         -- type (the substitution hasn't happened yet).  And we don't bother
 223         -- doing the type applications for a polymorphic function.
 224         -- Hence the split*Rep*FunTys
 225
 226     ----------------------------
 227         -- If fun_stricts is finite, it means the function returns bottom
 228         -- after that number of value args have been consumed
 229         -- Otherwise it's infinite, extended with False
 230     fun_stricts
 231       = case splitStrictSig (idNewStrictness fun) of
 232           (demands, result_info)
 233                 | not (demands `lengthExceeds` countValArgs orig_cont)
 234                 ->      -- Enough args, use the strictness given.
 235                         -- For bottoming functions we used to pretend that the arg
 236                         -- is lazy, so that we don't treat the arg as an
 237                         -- interesting context.  This avoids substituting
 238                         -- top-level bindings for (say) strings into
 239                         -- calls to error.  But now we are more careful about
 240                         -- inlining lone variables, so its ok (see SimplUtils.analyseCont)
 241                    if isBotRes result_info then
 242                         map isStrictDmd demands         -- Finite => result is bottom
 243                    else
 244                         map isStrictDmd demands ++ vanilla_stricts
 245
 246           other -> vanilla_stricts      -- Not enough args, or no strictness
 247
 248 -------------------
 249 interestingArg :: InScopeSet -> InExpr -> SubstEnv -> Bool
 250         -- An argument is interesting if it has *some* structure
 251         -- We are here trying to avoid unfolding a function that
 252         -- is applied only to variables that have no unfolding
 253         -- (i.e. they are probably lambda bound): f x y z
 254         -- There is little point in inlining f here.
 255 interestingArg in_scope arg subst
 256   = analyse (substExpr (mkSubst in_scope subst) arg)
 257         -- 'analyse' only looks at the top part of the result
 258         -- and substExpr is lazy, so this isn't nearly as brutal
 259         -- as it looks.
 260   where
 261     analyse (Var v)           = hasSomeUnfolding (idUnfolding v)
 262                                 -- Was: isValueUnfolding (idUnfolding v')
 263                                 -- But that seems over-pessimistic
 264     analyse (Type _)          = False
 265     analyse (App fn (Type _)) = analyse fn
 266     analyse (Note _ a)        = analyse a
 267     analyse other             = True
 268         -- Consider     let x = 3 in f x
 269         -- The substitution will contain (x -> ContEx 3), and we want to
 270         -- to say that x is an interesting argument.
 271         -- But consider also (\x. f x y) y
 272         -- The substitution will contain (x -> ContEx y), and we want to say
 273         -- that x is not interesting (assuming y has no unfolding)
 274 \end{code}
 275
 276 Comment about interestingCallContext
 277 ~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~
 278 We want to avoid inlining an expression where there can't possibly be
 279 any gain, such as in an argument position.  Hence, if the continuation
 280 is interesting (eg. a case scrutinee, application etc.) then we
 281 inline, otherwise we don't.
 282
 283 Previously some_benefit used to return True only if the variable was
 284 applied to some value arguments.  This didn't work:
 285
 286         let x = _coerce_ (T Int) Int (I# 3) in
 287         case _coerce_ Int (T Int) x of
 288                 I# y -> ....
 289
 290 we want to inline x, but can't see that it's a constructor in a case
 291 scrutinee position, and some_benefit is False.
 292
 293 Another example:
 294
 295 dMonadST = _/\_ t -> :Monad (g1 _@_ t, g2 _@_ t, g3 _@_ t)
 296
 297 ....  case dMonadST _@_ x0 of (a,b,c) -> ....
 298
 299 we'd really like to inline dMonadST here, but we *don't* want to
 300 inline if the case expression is just
 301
 302         case x of y { DEFAULT -> ... }
 303
 304 since we can just eliminate this case instead (x is in WHNF).  Similar
 305 applies when x is bound to a lambda expression.  Hence
 306 contIsInteresting looks for case expressions with just a single
 307 default case.
 308
 309 \begin{code}
 310 interestingCallContext :: Bool          -- False <=> no args at all
 311                        -> Bool          -- False <=> no value args
 312                        -> SimplCont -> Bool
 313         -- The "lone-variable" case is important.  I spent ages
 314         -- messing about with unsatisfactory varaints, but this is nice.
 315         -- The idea is that if a variable appear all alone
 316         --      as an arg of lazy fn, or rhs    Stop
 317         --      as scrutinee of a case          Select
 318         --      as arg of a strict fn           ArgOf
 319         -- then we should not inline it (unless there is some other reason,
 320         -- e.g. is is the sole occurrence).  We achieve this by making
 321         -- interestingCallContext return False for a lone variable.
 322         --
 323         -- Why?  At least in the case-scrutinee situation, turning
 324         --      let x = (a,b) in case x of y -> ...
 325         -- into
 326         --      let x = (a,b) in case (a,b) of y -> ...
 327         -- and thence to
 328         --      let x = (a,b) in let y = (a,b) in ...
 329         -- is bad if the binding for x will remain.
 330         --
 331         -- Another example: I discovered that strings
 332         -- were getting inlined straight back into applications of 'error'
 333         -- because the latter is strict.
 334         --      s = "foo"
 335         --      f = \x -> ...(error s)...
 336
 337         -- Fundamentally such contexts should not ecourage inlining becuase
 338         -- the context can ``see'' the unfolding of the variable (e.g. case or a RULE)
 339         -- so there's no gain.
 340         --
 341         -- However, even a type application or coercion isn't a lone variable.
 342         -- Consider
 343         --      case $fMonadST @ RealWorld of { :DMonad a b c -> c }
 344         -- We had better inline that sucker!  The case won't see through it.
 345         --
 346         -- For now, I'm treating treating a variable applied to types
 347         -- in a *lazy* context "lone". The motivating example was
 348         --      f = /\a. \x. BIG
 349         --      g = /\a. \y.  h (f a)
 350         -- There's no advantage in inlining f here, and perhaps
 351         -- a significant disadvantage.  Hence some_val_args in the Stop case
 352
 353 interestingCallContext some_args some_val_args cont
 354   = interesting cont
 355   where
 356     interesting (InlinePlease _)       = True
 357     interesting (Select _ _ _ _ _)     = some_args
 358     interesting (ApplyTo _ _ _ _)      = True   -- Can happen if we have (coerce t (f x)) y
 359                                                 -- Perhaps True is a bit over-keen, but I've
 360                                                 -- seen (coerce f) x, where f has an INLINE prag,
 361                                                 -- So we have to give some motivaiton for inlining it
 362     interesting (ArgOf _ _ _)          = some_val_args
 363     interesting (Stop ty upd_in_place) = some_val_args && upd_in_place
 364     interesting (CoerceIt _ cont)      = interesting cont
 365         -- If this call is the arg of a strict function, the context
 366         -- is a bit interesting.  If we inline here, we may get useful
 367         -- evaluation information to avoid repeated evals: e.g.
 368         --      x + (y * z)
 369         -- Here the contIsInteresting makes the '*' keener to inline,
 370         -- which in turn exposes a constructor which makes the '+' inline.
 371         -- Assuming that +,* aren't small enough to inline regardless.
 372         --
 373         -- It's also very important to inline in a strict context for things
 374         -- like
 375         --              foldr k z (f x)
 376         -- Here, the context of (f x) is strict, and if f's unfolding is
 377         -- a build it's *great* to inline it here.  So we must ensure that
 378         -- the context for (f x) is not totally uninteresting.
 379
 380
 381 -------------------
 382 canUpdateInPlace :: Type -> Bool
 383 -- Consider   let x = <wurble> in ...
 384 -- If <wurble> returns an explicit constructor, we might be able
 385 -- to do update in place.  So we treat even a thunk RHS context
 386 -- as interesting if update in place is possible.  We approximate
 387 -- this by seeing if the type has a single constructor with a
 388 -- small arity.  But arity zero isn't good -- we share the single copy
 389 -- for that case, so no point in sharing.
 390
 391 canUpdateInPlace ty
 392   | not opt_UF_UpdateInPlace = False
 393   | otherwise
 394   = case splitTyConApp_maybe ty of
 395         Nothing         -> False
 396         Just (tycon, _) -> case tyConDataConsIfAvailable tycon of
 397                                 [dc]  -> arity == 1 || arity == 2
 398                                       where
 399                                          arity = dataConRepArity dc
 400                                 other -> False
 401 \end{code}
 402
 403
 404
 405 %************************************************************************
 406 %*                                                                      *
 407 \section{Dealing with a single binder}
 408 %*                                                                      *
 409 %************************************************************************
 410
 411 \begin{code}
 412 simplBinders :: [InBinder] -> ([OutBinder] -> SimplM a) -> SimplM a
 413 simplBinders bndrs thing_inside
 414   = getSubst            `thenSmpl` \ subst ->
 415     let
 416         (subst', bndrs') = Subst.simplBndrs subst bndrs
 417     in
 418     seqBndrs bndrs'     `seq`
 419     setSubst subst' (thing_inside bndrs')
 420
 421 simplBinder :: InBinder -> (OutBinder -> SimplM a) -> SimplM a
 422 simplBinder bndr thing_inside
 423   = getSubst            `thenSmpl` \ subst ->
 424     let
 425         (subst', bndr') = Subst.simplBndr subst bndr
 426     in
 427     seqBndr bndr'       `seq`
 428     setSubst subst' (thing_inside bndr')
 429
 430
 431 simplLamBinder :: InBinder -> (OutBinder -> SimplM a) -> SimplM a
 432 simplLamBinder bndr thing_inside
 433   = getSubst            `thenSmpl` \ subst ->
 434     let
 435         (subst', bndr') = Subst.simplLamBndr subst bndr
 436     in
 437     seqBndr bndr'       `seq`
 438     setSubst subst' (thing_inside bndr')
 439
 440
 441 simplRecIds :: [InBinder] -> ([OutBinder] -> SimplM a) -> SimplM a
 442 simplRecIds ids thing_inside
 443   = getSubst            `thenSmpl` \ subst ->
 444     let
 445         (subst', ids') = mapAccumL Subst.simplLetId subst ids
 446     in
 447     seqBndrs ids'       `seq`
 448     setSubst subst' (thing_inside ids')
 449
 450 simplLetId :: InBinder -> (OutBinder -> SimplM a) -> SimplM a
 451 simplLetId id thing_inside
 452   = getSubst            `thenSmpl` \ subst ->
 453     let
 454         (subst', id') = Subst.simplLetId subst id
 455     in
 456     seqBndr id' `seq`
 457     setSubst subst' (thing_inside id')
 458
 459 seqBndrs [] = ()
 460 seqBndrs (b:bs) = seqBndr b `seq` seqBndrs bs
 461
 462 seqBndr b | isTyVar b = b `seq` ()
 463           | otherwise = seqType (idType b)      `seq`
 464                         idInfo b                `seq`
 465                         ()
 466 \end{code}
 467
 468
 469 %************************************************************************
 470 %*                                                                      *
 471 \subsection{Local tyvar-lifting}
 472 %*                                                                      *
 473 %************************************************************************
 474
 475 mkRhsTyLam tries this transformation, when the big lambda appears as
 476 the RHS of a let(rec) binding:
 477
 478         /\abc -> let(rec) x = e in b
 479    ==>
 480         let(rec) x' = /\abc -> let x = x' a b c in e
 481         in
 482         /\abc -> let x = x' a b c in b
 483
 484 This is good because it can turn things like:
 485
 486         let f = /\a -> letrec g = ... g ... in g
 487 into
 488         letrec g' = /\a -> ... g' a ...
 489         in
 490         let f = /\ a -> g' a
 491
 492 which is better.  In effect, it means that big lambdas don't impede
 493 let-floating.
 494
 495 This optimisation is CRUCIAL in eliminating the junk introduced by
 496 desugaring mutually recursive definitions.  Don't eliminate it lightly!
 497
 498 So far as the implementation is concerned:
 499
 500         Invariant: go F e = /\tvs -> F e
 501
 502         Equalities:
 503                 go F (Let x=e in b)
 504                 = Let x' = /\tvs -> F e
 505                   in
 506                   go G b
 507                 where
 508                     G = F . Let x = x' tvs
 509
 510                 go F (Letrec xi=ei in b)
 511                 = Letrec {xi' = /\tvs -> G ei}
 512                   in
 513                   go G b
 514                 where
 515                   G = F . Let {xi = xi' tvs}
 516
 517 [May 1999]  If we do this transformation *regardless* then we can
 518 end up with some pretty silly stuff.  For example,
 519
 520         let
 521             st = /\ s -> let { x1=r1 ; x2=r2 } in ...
 522         in ..
 523 becomes
 524         let y1 = /\s -> r1
 525             y2 = /\s -> r2
 526             st = /\s -> ...[y1 s/x1, y2 s/x2]
 527         in ..
 528
 529 Unless the "..." is a WHNF there is really no point in doing this.
 530 Indeed it can make things worse.  Suppose x1 is used strictly,
 531 and is of the form
 532
 533         x1* = case f y of { (a,b) -> e }
 534
 535 If we abstract this wrt the tyvar we then can't do the case inline
 536 as we would normally do.
 537
 538
 539 \begin{code}
 540 tryRhsTyLam :: OutExpr -> SimplM ([OutBind], OutExpr)
 541
 542 tryRhsTyLam rhs                         -- Only does something if there's a let
 543   | null tyvars || not (worth_it body)  -- inside a type lambda,
 544   = returnSmpl ([], rhs)                -- and a WHNF inside that
 545
 546   | otherwise
 547   = go (\x -> x) body           `thenSmpl` \ (binds, body') ->
 548     returnSmpl (binds,  mkLams tyvars body')
 549
 550   where
 551     (tyvars, body) = collectTyBinders rhs
 552
 553     worth_it e@(Let _ _) = whnf_in_middle e
 554     worth_it e           = False
 555
 556     whnf_in_middle (Let (NonRec x rhs) e) | isUnLiftedType (idType x) = False
 557     whnf_in_middle (Let _ e) = whnf_in_middle e
 558     whnf_in_middle e         = exprIsCheap e
 559
 560     go fn (Let bind@(NonRec var rhs) body)
 561       | exprIsTrivial rhs
 562       = go (fn . Let bind) body
 563
 564     go fn (Let (NonRec var rhs) body)
 565       = mk_poly tyvars_here var                         `thenSmpl` \ (var', rhs') ->
 566         go (fn . Let (mk_silly_bind var rhs')) body     `thenSmpl` \ (binds, body') ->
 567         returnSmpl (NonRec var' (mkLams tyvars_here (fn rhs)) : binds, body')
 568
 569       where
 570         tyvars_here = tyvars
 571                 --      main_tyvar_set = mkVarSet tyvars
 572                 --      var_ty = idType var
 573                 -- varSetElems (main_tyvar_set `intersectVarSet` tyVarsOfType var_ty)
 574                 -- tyvars_here was an attempt to reduce the number of tyvars
 575                 -- wrt which the new binding is abstracted.  But the naive
 576                 -- approach of abstract wrt the tyvars free in the Id's type
 577                 -- fails. Consider:
 578                 --      /\ a b -> let t :: (a,b) = (e1, e2)
 579                 --                    x :: a     = fst t
 580                 --                in ...
 581                 -- Here, b isn't free in x's type, but we must nevertheless
 582                 -- abstract wrt b as well, because t's type mentions b.
 583                 -- Since t is floated too, we'd end up with the bogus:
 584                 --      poly_t = /\ a b -> (e1, e2)
 585                 --      poly_x = /\ a   -> fst (poly_t a *b*)
 586                 -- So for now we adopt the even more naive approach of
 587                 -- abstracting wrt *all* the tyvars.  We'll see if that
 588                 -- gives rise to problems.   SLPJ June 98
 589
 590     go fn (Let (Rec prs) body)
 591        = mapAndUnzipSmpl (mk_poly tyvars_here) vars     `thenSmpl` \ (vars', rhss') ->
 592          let
 593             gn body  = fn (foldr Let body (zipWith mk_silly_bind vars rhss'))
 594             new_bind = Rec (vars' `zip` [mkLams tyvars_here (gn rhs) | rhs <- rhss])
 595          in
 596          go gn body                             `thenSmpl` \ (binds, body') ->
 597          returnSmpl (new_bind : binds, body')
 598        where
 599          (vars,rhss) = unzip prs
 600          tyvars_here = tyvars
 601                 -- varSetElems (main_tyvar_set `intersectVarSet` tyVarsOfTypes var_tys)
 602                 --       var_tys     = map idType vars
 603                 -- See notes with tyvars_here above
 604
 605     go fn body = returnSmpl ([], fn body)
 606
 607     mk_poly tyvars_here var
 608       = getUniqueSmpl           `thenSmpl` \ uniq ->
 609         let
 610             poly_name = setNameUnique (idName var) uniq         -- Keep same name
 611             poly_ty   = mkForAllTys tyvars_here (idType var)    -- But new type of course
 612             poly_id   = mkLocalId poly_name poly_ty
 613
 614                 -- In the olden days, it was crucial to copy the occInfo of the original var,
 615                 -- because we were looking at occurrence-analysed but as yet unsimplified code!
 616                 -- In particular, we mustn't lose the loop breakers.  BUT NOW we are looking
 617                 -- at already simplified code, so it doesn't matter
 618                 --
 619                 -- It's even right to retain single-occurrence or dead-var info:
 620                 -- Suppose we started with  /\a -> let x = E in B
 621                 -- where x occurs once in B. Then we transform to:
 622                 --      let x' = /\a -> E in /\a -> let x* = x' a in B
 623                 -- where x* has an INLINE prag on it.  Now, once x* is inlined,
 624                 -- the occurrences of x' will be just the occurrences originally
 625                 -- pinned on x.
 626         in
 627         returnSmpl (poly_id, mkTyApps (Var poly_id) (mkTyVarTys tyvars_here))
 628
 629     mk_silly_bind var rhs = NonRec var (Note InlineMe rhs)
 630                 -- Suppose we start with:
 631                 --
 632                 --      x = /\ a -> let g = G in E
 633                 --
 634                 -- Then we'll float to get
 635                 --
 636                 --      x = let poly_g = /\ a -> G
 637                 --          in /\ a -> let g = poly_g a in E
 638                 --
 639                 -- But now the occurrence analyser will see just one occurrence
 640                 -- of poly_g, not inside a lambda, so the simplifier will
 641                 -- PreInlineUnconditionally poly_g back into g!  Badk to square 1!
 642                 -- (I used to think that the "don't inline lone occurrences" stuff
 643                 --  would stop this happening, but since it's the *only* occurrence,
 644                 --  PreInlineUnconditionally kicks in first!)
 645                 --
 646                 -- Solution: put an INLINE note on g's RHS, so that poly_g seems
 647                 --           to appear many times.  (NB: mkInlineMe eliminates
 648                 --           such notes on trivial RHSs, so do it manually.)
 649 \end{code}
 650
 651
 652 %************************************************************************
 653 %*                                                                      *
 654 \subsection{Eta expansion}
 655 %*                                                                      *
 656 %************************************************************************
 657
 658         Try eta expansion for RHSs
 659
 660 We go for:
 661    Case 1    f = \x1..xn -> N  ==>   f = \x1..xn y1..ym -> N y1..ym
 662                  (n >= 0)
 663      OR
 664    Case 2    f = N E1..En      ==>   z1=E1
 665                  (n > 0)                 ..
 666                                      zn=En
 667                                      f = \y1..ym -> N z1..zn y1..ym
 668
 669 where (in both cases)
 670
 671         * The xi can include type variables
 672
 673         * The yi are all value variables
 674
 675         * N is a NORMAL FORM (i.e. no redexes anywhere)
 676           wanting a suitable number of extra args.
 677
 678         * the Ei must not have unlifted type
 679
 680 There is no point in looking for a combination of the two, because
 681 that would leave use with some lets sandwiched between lambdas; that's
 682 what the final test in the first equation is for.
 683
 684 In Case 1, we may have to sandwich some coerces between the lambdas
 685 to make the types work.   exprEtaExpandArity looks through coerces
 686 when computing arity; and etaExpand adds the coerces as necessary when
 687 actually computing the expansion.
 688
 689 \begin{code}
 690 tryEtaExpansion :: OutExpr -> OutType -> SimplM ([OutBind], OutExpr)
 691 tryEtaExpansion rhs rhs_ty
 692   |  not opt_SimplDoLambdaEtaExpansion          -- Not if switched off
 693   || exprIsTrivial rhs                          -- Not if RHS is trivial
 694   || final_arity == 0                           -- Not if arity is zero
 695   = returnSmpl ([], rhs)
 696
 697   | n_val_args == 0 && not arity_is_manifest
 698   =     -- Some lambdas but not enough: case 1
 699     getUniqSupplySmpl                           `thenSmpl` \ us ->
 700     returnSmpl ([], etaExpand final_arity us rhs rhs_ty)
 701
 702   | n_val_args > 0 && not (any cant_bind arg_infos)
 703   =     -- Partial application: case 2
 704     mapAndUnzipSmpl bind_z_arg arg_infos        `thenSmpl` \ (maybe_z_binds, z_args) ->
 705     getUniqSupplySmpl                           `thenSmpl` \ us ->
 706     returnSmpl (catMaybes maybe_z_binds,
 707                 etaExpand final_arity us (mkApps fun z_args) rhs_ty)
 708
 709   | otherwise
 710   = returnSmpl ([], rhs)
 711   where
 712     (fun, args)                    = collectArgs rhs
 713     n_val_args                     = valArgCount args
 714     (fun_arity, arity_is_manifest) = exprEtaExpandArity fun
 715     final_arity                    = 0 `max` (fun_arity - n_val_args)
 716     arg_infos                      = [(arg, exprType arg, exprIsTrivial arg) | arg <- args]
 717     cant_bind (_, ty, triv)        = not triv && isUnLiftedType ty
 718
 719     bind_z_arg (arg, arg_ty, trivial_arg)
 720         | trivial_arg = returnSmpl (Nothing, arg)
 721         | otherwise   = newId SLIT("z") arg_ty  $ \ z ->
 722                         returnSmpl (Just (NonRec z arg), Var z)
 723 \end{code}
 724
 725
 726 %************************************************************************
 727 %*                                                                      *
 728 \subsection{Case absorption and identity-case elimination}
 729 %*                                                                      *
 730 %************************************************************************
 731
 732 \begin{code}
 733 mkCase :: OutExpr -> OutId -> [OutAlt] -> SimplM OutExpr
 734 \end{code}
 735
 736 @mkCase@ tries the following transformation (if possible):
 737
 738 case e of b {             ==>   case e of b {
 739   p1 -> rhs1                      p1 -> rhs1
 740   ...                             ...
 741   pm -> rhsm                      pm -> rhsm
 742   _  -> case b of b' {            pn -> rhsn[b/b'] {or (alg)  let b=b' in rhsn}
 743                                                    {or (prim) case b of b' { _ -> rhsn}}
 744               pn -> rhsn          ...
 745               ...                 po -> rhso[b/b']
 746               po -> rhso          _  -> rhsd[b/b'] {or let b'=b in rhsd}
 747               _  -> rhsd
 748 }
 749
 750 which merges two cases in one case when -- the default alternative of
 751 the outer case scrutises the same variable as the outer case This
 752 transformation is called Case Merging.  It avoids that the same
 753 variable is scrutinised multiple times.
 754
 755 \begin{code}
 756 mkCase scrut outer_bndr outer_alts
 757   |  opt_SimplCaseMerge
 758   && maybeToBool maybe_case_in_default
 759
 760   = tick (CaseMerge outer_bndr)         `thenSmpl_`
 761     returnSmpl (Case scrut outer_bndr new_alts)
 762         -- Warning: don't call mkCase recursively!
 763         -- Firstly, there's no point, because inner alts have already had
 764         -- mkCase applied to them, so they won't have a case in their default
 765         -- Secondly, if you do, you get an infinite loop, because the bindNonRec
 766         -- in munge_rhs puts a case into the DEFAULT branch!
 767   where
 768     new_alts = add_default maybe_inner_default
 769                            (outer_alts_without_deflt ++ inner_con_alts)
 770
 771     maybe_case_in_default = case findDefault outer_alts of
 772                                 (outer_alts_without_default,
 773                                  Just (Case (Var scrut_var) inner_bndr inner_alts))
 774                                    | outer_bndr == scrut_var
 775                                    -> Just (outer_alts_without_default, inner_bndr, inner_alts)
 776                                 other -> Nothing
 777
 778     Just (outer_alts_without_deflt, inner_bndr, inner_alts) = maybe_case_in_default
 779
 780                 --  Eliminate any inner alts which are shadowed by the outer ones
 781     outer_cons = [con | (con,_,_) <- outer_alts_without_deflt]
 782
 783     munged_inner_alts = [ (con, args, munge_rhs rhs)
 784                         | (con, args, rhs) <- inner_alts,
 785                            not (con `elem` outer_cons)  -- Eliminate shadowed inner alts
 786                         ]
 787     munge_rhs rhs = bindNonRec inner_bndr (Var outer_bndr) rhs
 788
 789     (inner_con_alts, maybe_inner_default) = findDefault munged_inner_alts
 790
 791     add_default (Just rhs) alts = (DEFAULT,[],rhs) : alts
 792     add_default Nothing    alts = alts
 793 \end{code}
 794
 795 Now the identity-case transformation:
 796
 797         case e of               ===> e
 798                 True  -> True;
 799                 False -> False
 800
 801 and similar friends.
 802
 803 \begin{code}
 804 mkCase scrut case_bndr alts
 805   | all identity_alt alts
 806   = tick (CaseIdentity case_bndr)               `thenSmpl_`
 807     returnSmpl (re_note scrut)
 808   where
 809     identity_alt (con, args, rhs) = de_note rhs `cheapEqExpr` identity_rhs con args
 810
 811     identity_rhs (DataAlt con) args = mkConApp con (arg_tys ++ map varToCoreExpr args)
 812     identity_rhs (LitAlt lit)  _    = Lit lit
 813     identity_rhs DEFAULT       _    = Var case_bndr
 814
 815     arg_tys = map Type (tyConAppArgs (idType case_bndr))
 816
 817         -- We've seen this:
 818         --      case coerce T e of x { _ -> coerce T' x }
 819         -- And we definitely want to eliminate this case!
 820         -- So we throw away notes from the RHS, and reconstruct
 821         -- (at least an approximation) at the other end
 822     de_note (Note _ e) = de_note e
 823     de_note e          = e
 824
 825         -- re_note wraps a coerce if it might be necessary
 826     re_note scrut = case head alts of
 827                         (_,_,rhs1@(Note _ _)) -> mkCoerce (exprType rhs1) (idType case_bndr) scrut
 828                         other                 -> scrut
 829 \end{code}
 830
 831 The catch-all case.  We do a final transformation that I've
 832 occasionally seen making a big difference:
 833
 834         case e of               =====>     case e of
 835           C _ -> f x                         D v -> ....v....
 836           D v -> ....v....                   DEFAULT -> f x
 837           DEFAULT -> f x
 838
 839 The point is that we merge common RHSs, at least for the DEFAULT case.
 840 [One could do something more elaborate but I've never seen it needed.]
 841 The case where this came up was like this (lib/std/PrelCError.lhs):
 842
 843         x | p `is` 1 -> e1
 844           | p `is` 2 -> e2
 845         ...etc...
 846
 847 where @is@ was something like
 848
 849         p `is` n = p /= (-1) && p == n
 850
 851 This gave rise to a horrible sequence of cases
 852
 853         case p of
 854           (-1) -> $j p
 855           1    -> e1
 856           DEFAULT -> $j p
 857
 858 and similarly in cascade for all the join points!
 859
 860 \begin{code}
 861 mkCase other_scrut case_bndr other_alts
 862   = returnSmpl (Case other_scrut case_bndr (mergeDefault other_alts))
 863
 864 mergeDefault (deflt_alt@(DEFAULT,_,deflt_rhs) : con_alts)
 865   = deflt_alt : [alt | alt@(con,_,rhs) <- con_alts, not (rhs `cheapEqExpr` deflt_rhs)]
 866         -- NB: we can neglect the binders because we won't get equality if the
 867         -- binders are mentioned in rhs (no shadowing)
 868 mergeDefault other_alts
 869   = other_alts
 870 \end{code}