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         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, opt_DictsStrict,
  23                           opt_UF_UpdateInPlace
  24                         )
  25 import CoreSyn
  26 import CoreUnfold       ( isValueUnfolding )
  27 import CoreUtils        ( exprIsTrivial, cheapEqExpr, exprType, exprIsCheap, exprEtaExpandArity, bindNonRec )
  28 import Subst            ( InScopeSet, mkSubst, substBndrs, substBndr, substIds, substExpr )
  29 import Id               ( Id, idType, isId, idName,
  30                           idOccInfo, idUnfolding, idStrictness,
  31                           mkId, idInfo
  32                         )
  33 import IdInfo           ( StrictnessInfo(..), ArityInfo, atLeastArity, setOccInfo, vanillaIdInfo )
  34 import Maybes           ( maybeToBool, catMaybes )
  35 import Name             ( setNameUnique )
  36 import Demand           ( Demand, isStrict, wwLazy, wwLazy )
  37 import SimplMonad
  38 import Type             ( Type, tyVarsOfType, tyVarsOfTypes, mkForAllTys, seqType, repType,
  39                           splitTyConApp_maybe, mkTyVarTys, applyTys, splitFunTys, mkFunTys,
  40                           isDictTy, isDataType, applyTy, splitFunTy, isUnLiftedType,
  41                           splitRepFunTys
  42                         )
  43 import TyCon            ( tyConDataConsIfAvailable )
  44 import DataCon          ( dataConRepArity )
  45 import VarSet
  46 import VarEnv           ( SubstEnv, SubstResult(..) )
  47 import Util             ( lengthExceeds )
  48 import BasicTypes       ( Arity )
  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 idStrictness fun of
 232           StrictnessInfo demands result_bot
 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 result_bot then
 242                         map isStrict demands            -- Finite => result is bottom
 243                    else
 244                         map isStrict demands ++ vanilla_stricts
 245
 246           other -> vanilla_stricts      -- Not enough args, or no strictness
 247
 248
 249 -------------------
 250 isStrictType :: Type -> Bool
 251         -- isStrictType computes whether an argument (or let RHS) should
 252         -- be computed strictly or lazily, based only on its type
 253 isStrictType ty
 254   | isUnLiftedType ty                               = True
 255   | opt_DictsStrict && isDictTy ty && isDataType ty = True
 256   | otherwise                                       = False
 257         -- Return true only for dictionary types where the dictionary
 258         -- has more than one component (else we risk poking on the component
 259         -- of a newtype dictionary)
 260
 261 -------------------
 262 interestingArg :: InScopeSet -> InExpr -> SubstEnv -> Bool
 263         -- An argument is interesting if it has *some* structure
 264         -- We are here trying to avoid unfolding a function that
 265         -- is applied only to variables that have no unfolding
 266         -- (i.e. they are probably lambda bound): f x y z
 267         -- There is little point in inlining f here.
 268 interestingArg in_scope arg subst
 269   = analyse (substExpr (mkSubst in_scope subst) arg)
 270         -- 'analyse' only looks at the top part of the result
 271         -- and substExpr is lazy, so this isn't nearly as brutal
 272         -- as it looks.
 273   where
 274     analyse (Var v)           = hasSomeUnfolding (idUnfolding v)
 275                                 -- Was: isValueUnfolding (idUnfolding v')
 276                                 -- But that seems over-pessimistic
 277     analyse (Type _)          = False
 278     analyse (App fn (Type _)) = analyse fn
 279     analyse (Note _ a)        = analyse a
 280     analyse other             = True
 281         -- Consider     let x = 3 in f x
 282         -- The substitution will contain (x -> ContEx 3), and we want to
 283         -- to say that x is an interesting argument.
 284         -- But consider also (\x. f x y) y
 285         -- The substitution will contain (x -> ContEx y), and we want to say
 286         -- that x is not interesting (assuming y has no unfolding)
 287 \end{code}
 288
 289 Comment about interestingCallContext
 290 ~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~
 291 We want to avoid inlining an expression where there can't possibly be
 292 any gain, such as in an argument position.  Hence, if the continuation
 293 is interesting (eg. a case scrutinee, application etc.) then we
 294 inline, otherwise we don't.
 295
 296 Previously some_benefit used to return True only if the variable was
 297 applied to some value arguments.  This didn't work:
 298
 299         let x = _coerce_ (T Int) Int (I# 3) in
 300         case _coerce_ Int (T Int) x of
 301                 I# y -> ....
 302
 303 we want to inline x, but can't see that it's a constructor in a case
 304 scrutinee position, and some_benefit is False.
 305
 306 Another example:
 307
 308 dMonadST = _/\_ t -> :Monad (g1 _@_ t, g2 _@_ t, g3 _@_ t)
 309
 310 ....  case dMonadST _@_ x0 of (a,b,c) -> ....
 311
 312 we'd really like to inline dMonadST here, but we *don't* want to
 313 inline if the case expression is just
 314
 315         case x of y { DEFAULT -> ... }
 316
 317 since we can just eliminate this case instead (x is in WHNF).  Similar
 318 applies when x is bound to a lambda expression.  Hence
 319 contIsInteresting looks for case expressions with just a single
 320 default case.
 321
 322 \begin{code}
 323 interestingCallContext :: Bool          -- False <=> no args at all
 324                        -> Bool          -- False <=> no value args
 325                        -> SimplCont -> Bool
 326         -- The "lone-variable" case is important.  I spent ages
 327         -- messing about with unsatisfactory varaints, but this is nice.
 328         -- The idea is that if a variable appear all alone
 329         --      as an arg of lazy fn, or rhs    Stop
 330         --      as scrutinee of a case          Select
 331         --      as arg of a strict fn           ArgOf
 332         -- then we should not inline it (unless there is some other reason,
 333         -- e.g. is is the sole occurrence).  We achieve this by making
 334         -- interestingCallContext return False for a lone variable.
 335         --
 336         -- Why?  At least in the case-scrutinee situation, turning
 337         --      let x = (a,b) in case x of y -> ...
 338         -- into
 339         --      let x = (a,b) in case (a,b) of y -> ...
 340         -- and thence to
 341         --      let x = (a,b) in let y = (a,b) in ...
 342         -- is bad if the binding for x will remain.
 343         --
 344         -- Another example: I discovered that strings
 345         -- were getting inlined straight back into applications of 'error'
 346         -- because the latter is strict.
 347         --      s = "foo"
 348         --      f = \x -> ...(error s)...
 349
 350         -- Fundamentally such contexts should not ecourage inlining becuase
 351         -- the context can ``see'' the unfolding of the variable (e.g. case or a RULE)
 352         -- so there's no gain.
 353         --
 354         -- However, even a type application or coercion isn't a lone variable.
 355         -- Consider
 356         --      case $fMonadST @ RealWorld of { :DMonad a b c -> c }
 357         -- We had better inline that sucker!  The case won't see through it.
 358         --
 359         -- For now, I'm treating treating a variable applied to types
 360         -- in a *lazy* context "lone". The motivating example was
 361         --      f = /\a. \x. BIG
 362         --      g = /\a. \y.  h (f a)
 363         -- There's no advantage in inlining f here, and perhaps
 364         -- a significant disadvantage.  Hence some_val_args in the Stop case
 365
 366 interestingCallContext some_args some_val_args cont
 367   = interesting cont
 368   where
 369     interesting (InlinePlease _)       = True
 370     interesting (Select _ _ _ _ _)     = some_args
 371     interesting (ApplyTo _ _ _ _)      = some_args      -- Can happen if we have (coerce t (f x)) y
 372     interesting (ArgOf _ _ _)          = some_val_args
 373     interesting (Stop ty upd_in_place) = some_val_args && upd_in_place
 374     interesting (CoerceIt _ cont)      = interesting cont
 375         -- If this call is the arg of a strict function, the context
 376         -- is a bit interesting.  If we inline here, we may get useful
 377         -- evaluation information to avoid repeated evals: e.g.
 378         --      x + (y * z)
 379         -- Here the contIsInteresting makes the '*' keener to inline,
 380         -- which in turn exposes a constructor which makes the '+' inline.
 381         -- Assuming that +,* aren't small enough to inline regardless.
 382         --
 383         -- It's also very important to inline in a strict context for things
 384         -- like
 385         --              foldr k z (f x)
 386         -- Here, the context of (f x) is strict, and if f's unfolding is
 387         -- a build it's *great* to inline it here.  So we must ensure that
 388         -- the context for (f x) is not totally uninteresting.
 389
 390
 391 -------------------
 392 canUpdateInPlace :: Type -> Bool
 393 -- Consider   let x = <wurble> in ...
 394 -- If <wurble> returns an explicit constructor, we might be able
 395 -- to do update in place.  So we treat even a thunk RHS context
 396 -- as interesting if update in place is possible.  We approximate
 397 -- this by seeing if the type has a single constructor with a
 398 -- small arity.  But arity zero isn't good -- we share the single copy
 399 -- for that case, so no point in sharing.
 400
 401 -- Note the repType: we want to look through newtypes for this purpose
 402
 403 canUpdateInPlace ty
 404   | not opt_UF_UpdateInPlace = False
 405   | otherwise
 406   = case splitTyConApp_maybe (repType ty) of {
 407                         Nothing         -> False ;
 408                         Just (tycon, _) ->
 409
 410                       case tyConDataConsIfAvailable tycon of
 411                         [dc]  -> arity == 1 || arity == 2
 412                               where
 413                                  arity = dataConRepArity dc
 414                         other -> False
 415                       }
 416 \end{code}
 417
 418
 419
 420 %************************************************************************
 421 %*                                                                      *
 422 \section{Dealing with a single binder}
 423 %*                                                                      *
 424 %************************************************************************
 425
 426 \begin{code}
 427 simplBinders :: [InBinder] -> ([OutBinder] -> SimplM a) -> SimplM a
 428 simplBinders bndrs thing_inside
 429   = getSubst            `thenSmpl` \ subst ->
 430     let
 431         (subst', bndrs') = substBndrs subst bndrs
 432     in
 433     seqBndrs bndrs'     `seq`
 434     setSubst subst' (thing_inside bndrs')
 435
 436 simplBinder :: InBinder -> (OutBinder -> SimplM a) -> SimplM a
 437 simplBinder bndr thing_inside
 438   = getSubst            `thenSmpl` \ subst ->
 439     let
 440         (subst', bndr') = substBndr subst bndr
 441     in
 442     seqBndr bndr'       `seq`
 443     setSubst subst' (thing_inside bndr')
 444
 445
 446 -- Same semantics as simplBinders, but a little less
 447 -- plumbing and hence a little more efficient.
 448 -- Maybe not worth the candle?
 449 simplIds :: [InBinder] -> ([OutBinder] -> SimplM a) -> SimplM a
 450 simplIds ids thing_inside
 451   = getSubst            `thenSmpl` \ subst ->
 452     let
 453         (subst', bndrs') = substIds subst ids
 454     in
 455     seqBndrs bndrs'     `seq`
 456     setSubst subst' (thing_inside bndrs')
 457
 458 seqBndrs [] = ()
 459 seqBndrs (b:bs) = seqBndr b `seq` seqBndrs bs
 460
 461 seqBndr b | isTyVar b = b `seq` ()
 462           | otherwise = seqType (idType b)      `seq`
 463                         idInfo b                `seq`
 464                         ()
 465 \end{code}
 466
 467
 468 %************************************************************************
 469 %*                                                                      *
 470 \subsection{Transform a RHS}
 471 %*                                                                      *
 472 %************************************************************************
 473
 474 Try (a) eta expansion
 475     (b) type-lambda swizzling
 476
 477 \begin{code}
 478 transformRhs :: OutExpr
 479              -> (ArityInfo -> OutExpr -> SimplM (OutStuff a))
 480              -> SimplM (OutStuff a)
 481
 482 transformRhs rhs thing_inside
 483   = tryRhsTyLam rhs                     $ \ rhs1 ->
 484     tryEtaExpansion rhs1 thing_inside
 485 \end{code}
 486
 487
 488 %************************************************************************
 489 %*                                                                      *
 490 \subsection{Local tyvar-lifting}
 491 %*                                                                      *
 492 %************************************************************************
 493
 494 mkRhsTyLam tries this transformation, when the big lambda appears as
 495 the RHS of a let(rec) binding:
 496
 497         /\abc -> let(rec) x = e in b
 498    ==>
 499         let(rec) x' = /\abc -> let x = x' a b c in e
 500         in
 501         /\abc -> let x = x' a b c in b
 502
 503 This is good because it can turn things like:
 504
 505         let f = /\a -> letrec g = ... g ... in g
 506 into
 507         letrec g' = /\a -> ... g' a ...
 508         in
 509         let f = /\ a -> g' a
 510
 511 which is better.  In effect, it means that big lambdas don't impede
 512 let-floating.
 513
 514 This optimisation is CRUCIAL in eliminating the junk introduced by
 515 desugaring mutually recursive definitions.  Don't eliminate it lightly!
 516
 517 So far as the implementation is concerned:
 518
 519         Invariant: go F e = /\tvs -> F e
 520
 521         Equalities:
 522                 go F (Let x=e in b)
 523                 = Let x' = /\tvs -> F e
 524                   in
 525                   go G b
 526                 where
 527                     G = F . Let x = x' tvs
 528
 529                 go F (Letrec xi=ei in b)
 530                 = Letrec {xi' = /\tvs -> G ei}
 531                   in
 532                   go G b
 533                 where
 534                   G = F . Let {xi = xi' tvs}
 535
 536 [May 1999]  If we do this transformation *regardless* then we can
 537 end up with some pretty silly stuff.  For example,
 538
 539         let
 540             st = /\ s -> let { x1=r1 ; x2=r2 } in ...
 541         in ..
 542 becomes
 543         let y1 = /\s -> r1
 544             y2 = /\s -> r2
 545             st = /\s -> ...[y1 s/x1, y2 s/x2]
 546         in ..
 547
 548 Unless the "..." is a WHNF there is really no point in doing this.
 549 Indeed it can make things worse.  Suppose x1 is used strictly,
 550 and is of the form
 551
 552         x1* = case f y of { (a,b) -> e }
 553
 554 If we abstract this wrt the tyvar we then can't do the case inline
 555 as we would normally do.
 556
 557
 558 \begin{code}
 559 tryRhsTyLam rhs thing_inside            -- Only does something if there's a let
 560   | null tyvars || not (worth_it body)  -- inside a type lambda, and a WHNF inside that
 561   = thing_inside rhs
 562   | otherwise
 563   = go (\x -> x) body           $ \ body' ->
 564     thing_inside (mkLams tyvars body')
 565
 566   where
 567     (tyvars, body) = collectTyBinders rhs
 568
 569     worth_it (Let _ e)       = whnf_in_middle e
 570     worth_it other           = False
 571     whnf_in_middle (Let _ e) = whnf_in_middle e
 572     whnf_in_middle e         = exprIsCheap e
 573
 574
 575     go fn (Let bind@(NonRec var rhs) body) thing_inside
 576       | exprIsTrivial rhs
 577       = go (fn . Let bind) body thing_inside
 578
 579     go fn (Let bind@(NonRec var rhs) body) thing_inside
 580       = mk_poly tyvars_here var                                         `thenSmpl` \ (var', rhs') ->
 581         addAuxiliaryBind (NonRec var' (mkLams tyvars_here (fn rhs)))    $
 582         go (fn . Let (mk_silly_bind var rhs')) body thing_inside
 583
 584       where
 585         tyvars_here = tyvars
 586                 --      main_tyvar_set = mkVarSet tyvars
 587                 --      var_ty = idType var
 588                 -- varSetElems (main_tyvar_set `intersectVarSet` tyVarsOfType var_ty)
 589                 -- tyvars_here was an attempt to reduce the number of tyvars
 590                 -- wrt which the new binding is abstracted.  But the naive
 591                 -- approach of abstract wrt the tyvars free in the Id's type
 592                 -- fails. Consider:
 593                 --      /\ a b -> let t :: (a,b) = (e1, e2)
 594                 --                    x :: a     = fst t
 595                 --                in ...
 596                 -- Here, b isn't free in x's type, but we must nevertheless
 597                 -- abstract wrt b as well, because t's type mentions b.
 598                 -- Since t is floated too, we'd end up with the bogus:
 599                 --      poly_t = /\ a b -> (e1, e2)
 600                 --      poly_x = /\ a   -> fst (poly_t a *b*)
 601                 -- So for now we adopt the even more naive approach of
 602                 -- abstracting wrt *all* the tyvars.  We'll see if that
 603                 -- gives rise to problems.   SLPJ June 98
 604
 605     go fn (Let (Rec prs) body) thing_inside
 606        = mapAndUnzipSmpl (mk_poly tyvars_here) vars     `thenSmpl` \ (vars', rhss') ->
 607          let
 608             gn body = fn (foldr Let body (zipWith mk_silly_bind vars rhss'))
 609          in
 610          addAuxiliaryBind (Rec (vars' `zip` [mkLams tyvars_here (gn rhs) | rhs <- rhss]))       $
 611          go gn body thing_inside
 612        where
 613          (vars,rhss) = unzip prs
 614          tyvars_here = tyvars
 615                 -- varSetElems (main_tyvar_set `intersectVarSet` tyVarsOfTypes var_tys)
 616                 --       var_tys     = map idType vars
 617                 -- See notes with tyvars_here above
 618
 619
 620     go fn body thing_inside = thing_inside (fn body)
 621
 622     mk_poly tyvars_here var
 623       = getUniqueSmpl           `thenSmpl` \ uniq ->
 624         let
 625             poly_name = setNameUnique (idName var) uniq         -- Keep same name
 626             poly_ty   = mkForAllTys tyvars_here (idType var)    -- But new type of course
 627             poly_id   = mkId poly_name poly_ty vanillaIdInfo
 628
 629                 -- In the olden days, it was crucial to copy the occInfo of the original var,
 630                 -- because we were looking at occurrence-analysed but as yet unsimplified code!
 631                 -- In particular, we mustn't lose the loop breakers.  BUT NOW we are looking
 632                 -- at already simplified code, so it doesn't matter
 633                 --
 634                 -- It's even right to retain single-occurrence or dead-var info:
 635                 -- Suppose we started with  /\a -> let x = E in B
 636                 -- where x occurs once in B. Then we transform to:
 637                 --      let x' = /\a -> E in /\a -> let x* = x' a in B
 638                 -- where x* has an INLINE prag on it.  Now, once x* is inlined,
 639                 -- the occurrences of x' will be just the occurrences originally
 640                 -- pinned on x.
 641                 --         poly_info = vanillaIdInfo `setOccInfo` idOccInfo var
 642         in
 643         returnSmpl (poly_id, mkTyApps (Var poly_id) (mkTyVarTys tyvars_here))
 644
 645     mk_silly_bind var rhs = NonRec var rhs
 646                 -- Suppose we start with:
 647                 --
 648                 --      x = let g = /\a -> \x -> f x x
 649                 --          in
 650                 --          /\ b -> let g* = g b in E
 651                 --
 652                 -- Then:        * the binding for g gets floated out
 653                 --              * but then it MIGHT get inlined into the rhs of g*
 654                 --              * then the binding for g* is floated out of the /\b
 655                 --              * so we're back to square one
 656                 -- We rely on the simplifier not to inline g into the RHS of g*,
 657                 -- because it's a "lone" occurrence, and there is no benefit in
 658                 -- inlining.  But it's a slightly delicate property; hence this comment
 659 \end{code}
 660
 661
 662 %************************************************************************
 663 %*                                                                      *
 664 \subsection{Eta expansion}
 665 %*                                                                      *
 666 %************************************************************************
 667
 668         Try eta expansion for RHSs
 669
 670 We go for:
 671    Case 1    f = \x1..xn -> N  ==>   f = \x1..xn y1..ym -> N y1..ym
 672                  (n >= 0)
 673      OR
 674    Case 2    f = N E1..En      ==>   z1=E1
 675                  (n > 0)                 ..
 676                                      zn=En
 677                                      f = \y1..ym -> N z1..zn y1..ym
 678
 679 where (in both cases)
 680
 681         * The xi can include type variables
 682
 683         * The yi are all value variables
 684
 685         * N is a NORMAL FORM (i.e. no redexes anywhere)
 686           wanting a suitable number of extra args.
 687
 688         * the Ei must not have unlifted type
 689
 690 There is no point in looking for a combination of the two, because
 691 that would leave use with some lets sandwiched between lambdas; that's
 692 what the final test in the first equation is for.
 693
 694 \begin{code}
 695 tryEtaExpansion :: OutExpr
 696                 -> (ArityInfo -> OutExpr -> SimplM (OutStuff a))
 697                 -> SimplM (OutStuff a)
 698 tryEtaExpansion rhs thing_inside
 699   |  not opt_SimplDoLambdaEtaExpansion
 700   || null y_tys                         -- No useful expansion
 701   || not (is_case1 || is_case2)         -- Neither case matches
 702   = thing_inside final_arity rhs        -- So, no eta expansion, but
 703                                         -- return a good arity
 704
 705   | is_case1
 706   = make_y_bndrs                        $ \ y_bndrs ->
 707     thing_inside final_arity
 708                  (mkLams x_bndrs $ mkLams y_bndrs $
 709                   mkApps body (map Var y_bndrs))
 710
 711   | otherwise   -- Must be case 2
 712   = mapAndUnzipSmpl bind_z_arg arg_infos                `thenSmpl` \ (maybe_z_binds, z_args) ->
 713     addAuxiliaryBinds (catMaybes maybe_z_binds)         $
 714     make_y_bndrs                                        $  \ y_bndrs ->
 715     thing_inside final_arity
 716                  (mkLams y_bndrs $
 717                   mkApps (mkApps fun z_args) (map Var y_bndrs))
 718   where
 719     all_trivial_args = all is_trivial arg_infos
 720     is_case1         = all_trivial_args
 721     is_case2         = null x_bndrs && not (any unlifted_non_trivial arg_infos)
 722
 723     (x_bndrs, body)  = collectBinders rhs       -- NB: x_bndrs can include type variables
 724     x_arity          = valBndrCount x_bndrs
 725
 726     (fun, args)      = collectArgs body
 727     arg_infos        = [(arg, exprType arg, exprIsTrivial arg) | arg <- args]
 728
 729     is_trivial           (_, _,  triv) = triv
 730     unlifted_non_trivial (_, ty, triv) = not triv && isUnLiftedType ty
 731
 732     fun_arity        = exprEtaExpandArity fun
 733
 734     final_arity | all_trivial_args = atLeastArity (x_arity + extra_args_wanted)
 735                 | otherwise        = atLeastArity x_arity
 736         -- Arity can be more than the number of lambdas
 737         -- because of coerces. E.g.  \x -> coerce t (\y -> e)
 738         -- will have arity at least 2
 739         -- The worker/wrapper pass will bring the coerce out to the top
 740
 741     bind_z_arg (arg, arg_ty, trivial_arg)
 742         | trivial_arg = returnSmpl (Nothing, arg)
 743         | otherwise   = newId SLIT("z") arg_ty  $ \ z ->
 744                         returnSmpl (Just (NonRec z arg), Var z)
 745
 746     make_y_bndrs thing_inside
 747         = ASSERT( not (exprIsTrivial rhs) )
 748           newIds SLIT("y") y_tys                        $ \ y_bndrs ->
 749           tick (EtaExpansion (head y_bndrs))            `thenSmpl_`
 750           thing_inside y_bndrs
 751
 752     (potential_extra_arg_tys, _) = splitFunTys (exprType body)
 753
 754     y_tys :: [InType]
 755     y_tys  = take extra_args_wanted potential_extra_arg_tys
 756
 757     extra_args_wanted :: Int    -- Number of extra args we want
 758     extra_args_wanted = 0 `max` (fun_arity - valArgCount args)
 759
 760         -- We used to expand the arity to the previous arity fo the
 761         -- function; but this is pretty dangerous.  Consdier
 762         --      f = \xy -> e
 763         -- so that f has arity 2.  Now float something into f's RHS:
 764         --      f = let z = BIG in \xy -> e
 765         -- The last thing we want to do now is to put some lambdas
 766         -- outside, to get
 767         --      f = \xy -> let z = BIG in e
 768         --
 769         -- (bndr_arity - no_of_xs)              `max`
 770 \end{code}
 771
 772
 773 %************************************************************************
 774 %*                                                                      *
 775 \subsection{Case absorption and identity-case elimination}
 776 %*                                                                      *
 777 %************************************************************************
 778
 779 \begin{code}
 780 mkCase :: OutExpr -> OutId -> [OutAlt] -> SimplM OutExpr
 781 \end{code}
 782
 783 @mkCase@ tries the following transformation (if possible):
 784
 785 case e of b {             ==>   case e of b {
 786   p1 -> rhs1                      p1 -> rhs1
 787   ...                             ...
 788   pm -> rhsm                      pm -> rhsm
 789   _  -> case b of b' {            pn -> rhsn[b/b'] {or (alg)  let b=b' in rhsn}
 790                                                    {or (prim) case b of b' { _ -> rhsn}}
 791               pn -> rhsn          ...
 792               ...                 po -> rhso[b/b']
 793               po -> rhso          _  -> rhsd[b/b'] {or let b'=b in rhsd}
 794               _  -> rhsd
 795 }
 796
 797 which merges two cases in one case when -- the default alternative of
 798 the outer case scrutises the same variable as the outer case This
 799 transformation is called Case Merging.  It avoids that the same
 800 variable is scrutinised multiple times.
 801
 802 \begin{code}
 803 mkCase scrut outer_bndr outer_alts
 804   |  opt_SimplCaseMerge
 805   && maybeToBool maybe_case_in_default
 806
 807   = tick (CaseMerge outer_bndr)         `thenSmpl_`
 808     returnSmpl (Case scrut outer_bndr new_alts)
 809         -- Warning: don't call mkCase recursively!
 810         -- Firstly, there's no point, because inner alts have already had
 811         -- mkCase applied to them, so they won't have a case in their default
 812         -- Secondly, if you do, you get an infinite loop, because the bindNonRec
 813         -- in munge_rhs puts a case into the DEFAULT branch!
 814   where
 815     new_alts = outer_alts_without_deflt ++ munged_inner_alts
 816     maybe_case_in_default = case findDefault outer_alts of
 817                                 (outer_alts_without_default,
 818                                  Just (Case (Var scrut_var) inner_bndr inner_alts))
 819
 820                                    | outer_bndr == scrut_var
 821                                    -> Just (outer_alts_without_default, inner_bndr, inner_alts)
 822                                 other -> Nothing
 823
 824     Just (outer_alts_without_deflt, inner_bndr, inner_alts) = maybe_case_in_default
 825
 826                 --  Eliminate any inner alts which are shadowed by the outer ones
 827     outer_cons = [con | (con,_,_) <- outer_alts_without_deflt]
 828
 829     munged_inner_alts = [ (con, args, munge_rhs rhs)
 830                         | (con, args, rhs) <- inner_alts,
 831                            not (con `elem` outer_cons)  -- Eliminate shadowed inner alts
 832                         ]
 833     munge_rhs rhs = bindNonRec inner_bndr (Var outer_bndr) rhs
 834 \end{code}
 835
 836 Now the identity-case transformation:
 837
 838         case e of               ===> e
 839                 True -> True;
 840                 False -> False
 841
 842 and similar friends.
 843
 844 \begin{code}
 845 mkCase scrut case_bndr alts
 846   | all identity_alt alts
 847   = tick (CaseIdentity case_bndr)               `thenSmpl_`
 848     returnSmpl scrut
 849   where
 850     identity_alt (DEFAULT, [], Var v)     = v == case_bndr
 851     identity_alt (DataAlt con, args, rhs) = cheapEqExpr rhs
 852                                                         (mkConApp con (map Type arg_tys ++ map varToCoreExpr args))
 853     identity_alt other                    = False
 854
 855     arg_tys = case splitTyConApp_maybe (idType case_bndr) of
 856                 Just (tycon, arg_tys) -> arg_tys
 857 \end{code}
 858
 859 The catch-all case
 860
 861 \begin{code}
 862 mkCase other_scrut case_bndr other_alts
 863   = returnSmpl (Case other_scrut case_bndr other_alts)
 864 \end{code}
 865
 866
 867 \begin{code}
 868 findDefault :: [CoreAlt] -> ([CoreAlt], Maybe CoreExpr)
 869 findDefault []                          = ([], Nothing)
 870 findDefault ((DEFAULT,args,rhs) : alts) = ASSERT( null alts && null args )
 871                                           ([], Just rhs)
 872 findDefault (alt : alts)                = case findDefault alts of
 873                                             (alts', deflt) -> (alt : alts', deflt)
 874
 875 findAlt :: AltCon -> [CoreAlt] -> CoreAlt
 876 findAlt con alts
 877   = go alts
 878   where
 879     go []           = pprPanic "Missing alternative" (ppr con $$ vcat (map ppr alts))
 880     go (alt : alts) | matches alt = alt
 881                     | otherwise   = go alts
 882
 883     matches (DEFAULT, _, _) = True
 884     matches (con1, _, _)    = con == con1
 885 \end{code}