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