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