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