ghc/compiler/simplCore/SimplUtils.lhs

   1 %
   2 % (c) The AQUA Project, Glasgow University, 1993-1998
   3 %
   4 \section[SimplUtils]{The simplifier utilities}
   5
   6 \begin{code}
   7 module SimplUtils (
   8         simplBinder, simplBinders, simplRecIds, simplLetId, simplLamBinders,
   9         newId, mkLam, mkCase,
  10
  11         -- The continuation type
  12         SimplCont(..), DupFlag(..), LetRhsFlag(..),
  13         contIsDupable, contResultType,
  14         countValArgs, countArgs, pushContArgs,
  15         mkBoringStop, mkStop, contIsRhs, contIsRhsOrArg,
  16         getContArgs, interestingCallContext, interestingArg, isStrictType
  17
  18     ) where
  19
  20 #include "HsVersions.h"
  21
  22 import CmdLineOpts      ( SimplifierSwitch(..),
  23                           opt_SimplDoLambdaEtaExpansion, opt_SimplDoEtaReduction,
  24                           opt_SimplCaseMerge, opt_UF_UpdateInPlace
  25                         )
  26 import CoreSyn
  27 import CoreUtils        ( cheapEqExpr, exprType,
  28                           etaExpand, exprEtaExpandArity, bindNonRec, mkCoerce,
  29                           findDefault, exprOkForSpeculation, exprIsValue
  30                         )
  31 import qualified Subst  ( simplBndrs, simplBndr, simplLetId, simplLamBndr )
  32 import Id               ( Id, idType, idInfo,
  33                           mkSysLocal, hasNoBinding, isDeadBinder, idNewDemandInfo,
  34                           idUnfolding, idNewStrictness
  35                         )
  36 import NewDemand        ( isStrictDmd, isBotRes, splitStrictSig )
  37 import SimplMonad
  38 import Type             ( Type, seqType,
  39                           splitTyConApp_maybe, tyConAppArgs, mkTyVarTys,
  40                           splitRepFunTys, isStrictType
  41                         )
  42 import OccName          ( UserFS )
  43 import TyCon            ( tyConDataConsIfAvailable, isDataTyCon )
  44 import DataCon          ( dataConRepArity, dataConSig, dataConArgTys )
  45 import Var              ( mkSysTyVar, tyVarKind )
  46 import Util             ( lengthExceeds, mapAccumL )
  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              LetRhsFlag
  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 SimplEnv            -- The argument, as yet unsimplified,
  73              SimplCont                  -- and its environment
  74
  75   | Select   DupFlag
  76              InId [InAlt] SimplEnv      -- 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              LetRhsFlag
  83              OutType            -- cont_ty: the type of the expression being sought by the context
  84                                 --      f (error "foo") ==> coerce t (error "foo")
  85                                 -- when f is strict
  86                                 -- We need to know the type t, to which to coerce.
  87              (SimplEnv -> OutExpr -> SimplM FloatsWithExpr)     -- What to do with the result
  88                                 -- The result expression in the OutExprStuff has type cont_ty
  89
  90 data LetRhsFlag = AnArg         -- It's just an argument not a let RHS
  91                 | AnRhs         -- It's the RHS of a let (so please float lets out of big lambdas)
  92
  93 instance Outputable LetRhsFlag where
  94   ppr AnArg = ptext SLIT("arg")
  95   ppr AnRhs = ptext SLIT("rhs")
  96
  97 instance Outputable SimplCont where
  98   ppr (Stop _ is_rhs _)              = ptext SLIT("Stop") <> brackets (ppr is_rhs)
  99   ppr (ApplyTo dup arg se cont)      = (ptext SLIT("ApplyTo") <+> ppr dup <+> ppr arg) $$ ppr cont
 100   ppr (ArgOf   dup _ _ _)            = ptext SLIT("ArgOf...") <+> ppr dup
 101   ppr (Select dup bndr alts se cont) = (ptext SLIT("Select") <+> ppr dup <+> ppr bndr) $$
 102                                        (nest 4 (ppr alts)) $$ ppr cont
 103   ppr (CoerceIt ty cont)             = (ptext SLIT("CoerceIt") <+> ppr ty) $$ ppr cont
 104   ppr (InlinePlease cont)            = ptext SLIT("InlinePlease") $$ ppr cont
 105
 106 data DupFlag = OkToDup | NoDup
 107
 108 instance Outputable DupFlag where
 109   ppr OkToDup = ptext SLIT("ok")
 110   ppr NoDup   = ptext SLIT("nodup")
 111
 112
 113 -------------------
 114 mkBoringStop :: OutType -> SimplCont
 115 mkBoringStop ty = Stop ty AnArg (canUpdateInPlace ty)
 116
 117 mkStop :: OutType -> LetRhsFlag -> SimplCont
 118 mkStop ty is_rhs = Stop ty is_rhs (canUpdateInPlace ty)
 119
 120 contIsRhs :: SimplCont -> Bool
 121 contIsRhs (Stop _ AnRhs _)    = True
 122 contIsRhs (ArgOf _ AnRhs _ _) = True
 123 contIsRhs other               = False
 124
 125 contIsRhsOrArg (Stop _ _ _)    = True
 126 contIsRhsOrArg (ArgOf _ _ _ _) = True
 127 contIsRhsOrArg other           = False
 128
 129 -------------------
 130 contIsDupable :: SimplCont -> Bool
 131 contIsDupable (Stop _ _ _)               = True
 132 contIsDupable (ApplyTo  OkToDup _ _ _)   = True
 133 contIsDupable (ArgOf    OkToDup _ _ _)   = True
 134 contIsDupable (Select   OkToDup _ _ _ _) = True
 135 contIsDupable (CoerceIt _ cont)          = contIsDupable cont
 136 contIsDupable (InlinePlease cont)        = contIsDupable cont
 137 contIsDupable other                      = False
 138
 139 -------------------
 140 discardableCont :: SimplCont -> Bool
 141 discardableCont (Stop _ _ _)        = False
 142 discardableCont (CoerceIt _ cont)   = discardableCont cont
 143 discardableCont (InlinePlease cont) = discardableCont cont
 144 discardableCont other               = True
 145
 146 discardCont :: SimplCont        -- A continuation, expecting
 147             -> SimplCont        -- Replace the continuation with a suitable coerce
 148 discardCont cont = case cont of
 149                      Stop to_ty is_rhs _ -> cont
 150                      other               -> CoerceIt to_ty (mkBoringStop to_ty)
 151                  where
 152                    to_ty = contResultType cont
 153
 154 -------------------
 155 contResultType :: SimplCont -> OutType
 156 contResultType (Stop to_ty _ _)      = to_ty
 157 contResultType (ArgOf _ _ to_ty _)   = to_ty
 158 contResultType (ApplyTo _ _ _ cont)  = contResultType cont
 159 contResultType (CoerceIt _ cont)     = contResultType cont
 160 contResultType (InlinePlease cont)   = contResultType cont
 161 contResultType (Select _ _ _ _ cont) = contResultType cont
 162
 163 -------------------
 164 countValArgs :: SimplCont -> Int
 165 countValArgs (ApplyTo _ (Type ty) se cont) = countValArgs cont
 166 countValArgs (ApplyTo _ val_arg   se cont) = 1 + countValArgs cont
 167 countValArgs other                         = 0
 168
 169 countArgs :: SimplCont -> Int
 170 countArgs (ApplyTo _ arg se cont) = 1 + countArgs cont
 171 countArgs other                   = 0
 172
 173 -------------------
 174 pushContArgs :: SimplEnv -> [OutArg] -> SimplCont -> SimplCont
 175 -- Pushes args with the specified environment
 176 pushContArgs env []           cont = cont
 177 pushContArgs env (arg : args) cont = ApplyTo NoDup arg env (pushContArgs env args cont)
 178 \end{code}
 179
 180
 181 \begin{code}
 182 getContArgs :: SwitchChecker
 183             -> OutId -> SimplCont
 184             -> ([(InExpr, SimplEnv, Bool)],     -- Arguments; the Bool is true for strict args
 185                 SimplCont,                      -- Remaining continuation
 186                 Bool)                           -- Whether we came across an InlineCall
 187 -- getContArgs id k = (args, k', inl)
 188 --      args are the leading ApplyTo items in k
 189 --      (i.e. outermost comes first)
 190 --      augmented with demand info from the functionn
 191 getContArgs chkr fun orig_cont
 192   = let
 193                 -- Ignore strictness info if the no-case-of-case
 194                 -- flag is on.  Strictness changes evaluation order
 195                 -- and that can change full laziness
 196         stricts | switchIsOn chkr NoCaseOfCase = vanilla_stricts
 197                 | otherwise                    = computed_stricts
 198     in
 199     go [] stricts False orig_cont
 200   where
 201     ----------------------------
 202
 203         -- Type argument
 204     go acc ss inl (ApplyTo _ arg@(Type _) se cont)
 205         = go ((arg,se,False) : acc) ss inl cont
 206                 -- NB: don't bother to instantiate the function type
 207
 208         -- Value argument
 209     go acc (s:ss) inl (ApplyTo _ arg se cont)
 210         = go ((arg,se,s) : acc) ss inl cont
 211
 212         -- An Inline continuation
 213     go acc ss inl (InlinePlease cont)
 214         = go acc ss True cont
 215
 216         -- We're run out of arguments, or else we've run out of demands
 217         -- The latter only happens if the result is guaranteed bottom
 218         -- This is the case for
 219         --      * case (error "hello") of { ... }
 220         --      * (error "Hello") arg
 221         --      * f (error "Hello") where f is strict
 222         --      etc
 223     go acc ss inl cont
 224         | null ss && discardableCont cont = (reverse acc, discardCont cont, inl)
 225         | otherwise                       = (reverse acc, cont,             inl)
 226
 227     ----------------------------
 228     vanilla_stricts, computed_stricts :: [Bool]
 229     vanilla_stricts  = repeat False
 230     computed_stricts = zipWith (||) fun_stricts arg_stricts
 231
 232     ----------------------------
 233     (val_arg_tys, _) = splitRepFunTys (idType fun)
 234     arg_stricts      = map isStrictType val_arg_tys ++ repeat False
 235         -- These argument types are used as a cheap and cheerful way to find
 236         -- unboxed arguments, which must be strict.  But it's an InType
 237         -- and so there might be a type variable where we expect a function
 238         -- type (the substitution hasn't happened yet).  And we don't bother
 239         -- doing the type applications for a polymorphic function.
 240         -- Hence the split*Rep*FunTys
 241
 242     ----------------------------
 243         -- If fun_stricts is finite, it means the function returns bottom
 244         -- after that number of value args have been consumed
 245         -- Otherwise it's infinite, extended with False
 246     fun_stricts
 247       = case splitStrictSig (idNewStrictness fun) of
 248           (demands, result_info)
 249                 | not (demands `lengthExceeds` countValArgs orig_cont)
 250                 ->      -- Enough args, use the strictness given.
 251                         -- For bottoming functions we used to pretend that the arg
 252                         -- is lazy, so that we don't treat the arg as an
 253                         -- interesting context.  This avoids substituting
 254                         -- top-level bindings for (say) strings into
 255                         -- calls to error.  But now we are more careful about
 256                         -- inlining lone variables, so its ok (see SimplUtils.analyseCont)
 257                    if isBotRes result_info then
 258                         map isStrictDmd demands         -- Finite => result is bottom
 259                    else
 260                         map isStrictDmd demands ++ vanilla_stricts
 261
 262           other -> vanilla_stricts      -- Not enough args, or no strictness
 263
 264 -------------------
 265 interestingArg :: OutExpr -> Bool
 266         -- An argument is interesting if it has *some* structure
 267         -- We are here trying to avoid unfolding a function that
 268         -- is applied only to variables that have no unfolding
 269         -- (i.e. they are probably lambda bound): f x y z
 270         -- There is little point in inlining f here.
 271 interestingArg (Var v)           = hasSomeUnfolding (idUnfolding v)
 272                                         -- Was: isValueUnfolding (idUnfolding v')
 273                                         -- But that seems over-pessimistic
 274 interestingArg (Type _)          = False
 275 interestingArg (App fn (Type _)) = interestingArg fn
 276 interestingArg (Note _ a)        = interestingArg a
 277 interestingArg other             = True
 278         -- Consider     let x = 3 in f x
 279         -- The substitution will contain (x -> ContEx 3), and we want to
 280         -- to say that x is an interesting argument.
 281         -- But consider also (\x. f x y) y
 282         -- The substitution will contain (x -> ContEx y), and we want to say
 283         -- that x is not interesting (assuming y has no unfolding)
 284 \end{code}
 285
 286 Comment about interestingCallContext
 287 ~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~
 288 We want to avoid inlining an expression where there can't possibly be
 289 any gain, such as in an argument position.  Hence, if the continuation
 290 is interesting (eg. a case scrutinee, application etc.) then we
 291 inline, otherwise we don't.
 292
 293 Previously some_benefit used to return True only if the variable was
 294 applied to some value arguments.  This didn't work:
 295
 296         let x = _coerce_ (T Int) Int (I# 3) in
 297         case _coerce_ Int (T Int) x of
 298                 I# y -> ....
 299
 300 we want to inline x, but can't see that it's a constructor in a case
 301 scrutinee position, and some_benefit is False.
 302
 303 Another example:
 304
 305 dMonadST = _/\_ t -> :Monad (g1 _@_ t, g2 _@_ t, g3 _@_ t)
 306
 307 ....  case dMonadST _@_ x0 of (a,b,c) -> ....
 308
 309 we'd really like to inline dMonadST here, but we *don't* want to
 310 inline if the case expression is just
 311
 312         case x of y { DEFAULT -> ... }
 313
 314 since we can just eliminate this case instead (x is in WHNF).  Similar
 315 applies when x is bound to a lambda expression.  Hence
 316 contIsInteresting looks for case expressions with just a single
 317 default case.
 318
 319 \begin{code}
 320 interestingCallContext :: Bool          -- False <=> no args at all
 321                        -> Bool          -- False <=> no value args
 322                        -> SimplCont -> Bool
 323         -- The "lone-variable" case is important.  I spent ages
 324         -- messing about with unsatisfactory varaints, but this is nice.
 325         -- The idea is that if a variable appear all alone
 326         --      as an arg of lazy fn, or rhs    Stop
 327         --      as scrutinee of a case          Select
 328         --      as arg of a strict fn           ArgOf
 329         -- then we should not inline it (unless there is some other reason,
 330         -- e.g. is is the sole occurrence).  We achieve this by making
 331         -- interestingCallContext return False for a lone variable.
 332         --
 333         -- Why?  At least in the case-scrutinee situation, turning
 334         --      let x = (a,b) in case x of y -> ...
 335         -- into
 336         --      let x = (a,b) in case (a,b) of y -> ...
 337         -- and thence to
 338         --      let x = (a,b) in let y = (a,b) in ...
 339         -- is bad if the binding for x will remain.
 340         --
 341         -- Another example: I discovered that strings
 342         -- were getting inlined straight back into applications of 'error'
 343         -- because the latter is strict.
 344         --      s = "foo"
 345         --      f = \x -> ...(error s)...
 346
 347         -- Fundamentally such contexts should not ecourage inlining because
 348         -- the context can ``see'' the unfolding of the variable (e.g. case or a RULE)
 349         -- so there's no gain.
 350         --
 351         -- However, even a type application or coercion isn't a lone variable.
 352         -- Consider
 353         --      case $fMonadST @ RealWorld of { :DMonad a b c -> c }
 354         -- We had better inline that sucker!  The case won't see through it.
 355         --
 356         -- For now, I'm treating treating a variable applied to types
 357         -- in a *lazy* context "lone". The motivating example was
 358         --      f = /\a. \x. BIG
 359         --      g = /\a. \y.  h (f a)
 360         -- There's no advantage in inlining f here, and perhaps
 361         -- a significant disadvantage.  Hence some_val_args in the Stop case
 362
 363 interestingCallContext some_args some_val_args cont
 364   = interesting cont
 365   where
 366     interesting (InlinePlease _)       = True
 367     interesting (Select _ _ _ _ _)     = some_args
 368     interesting (ApplyTo _ _ _ _)      = True   -- Can happen if we have (coerce t (f x)) y
 369                                                 -- Perhaps True is a bit over-keen, but I've
 370                                                 -- seen (coerce f) x, where f has an INLINE prag,
 371                                                 -- So we have to give some motivaiton for inlining it
 372     interesting (ArgOf _ _ _ _)          = some_val_args
 373     interesting (Stop ty _ upd_in_place) = some_val_args && upd_in_place
 374     interesting (CoerceIt _ cont)        = interesting cont
 375         -- If this call is the arg of a strict function, the context
 376         -- is a bit interesting.  If we inline here, we may get useful
 377         -- evaluation information to avoid repeated evals: e.g.
 378         --      x + (y * z)
 379         -- Here the contIsInteresting makes the '*' keener to inline,
 380         -- which in turn exposes a constructor which makes the '+' inline.
 381         -- Assuming that +,* aren't small enough to inline regardless.
 382         --
 383         -- It's also very important to inline in a strict context for things
 384         -- like
 385         --              foldr k z (f x)
 386         -- Here, the context of (f x) is strict, and if f's unfolding is
 387         -- a build it's *great* to inline it here.  So we must ensure that
 388         -- the context for (f x) is not totally uninteresting.
 389
 390
 391 -------------------
 392 canUpdateInPlace :: Type -> Bool
 393 -- Consider   let x = <wurble> in ...
 394 -- If <wurble> returns an explicit constructor, we might be able
 395 -- to do update in place.  So we treat even a thunk RHS context
 396 -- as interesting if update in place is possible.  We approximate
 397 -- this by seeing if the type has a single constructor with a
 398 -- small arity.  But arity zero isn't good -- we share the single copy
 399 -- for that case, so no point in sharing.
 400
 401 canUpdateInPlace ty
 402   | not opt_UF_UpdateInPlace = False
 403   | otherwise
 404   = case splitTyConApp_maybe ty of
 405         Nothing         -> False
 406         Just (tycon, _) -> case tyConDataConsIfAvailable tycon of
 407                                 [dc]  -> arity == 1 || arity == 2
 408                                       where
 409                                          arity = dataConRepArity dc
 410                                 other -> False
 411 \end{code}
 412
 413
 414
 415 %************************************************************************
 416 %*                                                                      *
 417 \section{Dealing with a single binder}
 418 %*                                                                      *
 419 %************************************************************************
 420
 421 These functions are in the monad only so that they can be made strict via seq.
 422
 423 \begin{code}
 424 simplBinders :: SimplEnv -> [InBinder] -> SimplM (SimplEnv, [OutBinder])
 425 simplBinders env bndrs
 426   = let
 427         (subst', bndrs') = Subst.simplBndrs (getSubst env) bndrs
 428     in
 429     seqBndrs bndrs'     `seq`
 430     returnSmpl (setSubst env subst', bndrs')
 431
 432 simplBinder :: SimplEnv -> InBinder -> SimplM (SimplEnv, OutBinder)
 433 simplBinder env bndr
 434   = let
 435         (subst', bndr') = Subst.simplBndr (getSubst env) bndr
 436     in
 437     seqBndr bndr'       `seq`
 438     returnSmpl (setSubst env subst', bndr')
 439
 440
 441 simplLamBinders :: SimplEnv -> [InBinder] -> SimplM (SimplEnv, [OutBinder])
 442 simplLamBinders env bndrs
 443   = let
 444         (subst', bndrs') = mapAccumL Subst.simplLamBndr (getSubst env) bndrs
 445     in
 446     seqBndrs bndrs'     `seq`
 447     returnSmpl (setSubst env subst', bndrs')
 448
 449 simplRecIds :: SimplEnv -> [InBinder] -> SimplM (SimplEnv, [OutBinder])
 450 simplRecIds env ids
 451   = let
 452         (subst', ids') = mapAccumL Subst.simplLetId (getSubst env) ids
 453     in
 454     seqBndrs ids'       `seq`
 455     returnSmpl (setSubst env subst', ids')
 456
 457 simplLetId :: SimplEnv -> InBinder -> SimplM (SimplEnv, OutBinder)
 458 simplLetId env id
 459   = let
 460         (subst', id') = Subst.simplLetId (getSubst env) id
 461     in
 462     seqBndr id'         `seq`
 463     returnSmpl (setSubst env subst', id')
 464
 465 seqBndrs [] = ()
 466 seqBndrs (b:bs) = seqBndr b `seq` seqBndrs bs
 467
 468 seqBndr b | isTyVar b = b `seq` ()
 469           | otherwise = seqType (idType b)      `seq`
 470                         idInfo b                `seq`
 471                         ()
 472 \end{code}
 473
 474
 475 \begin{code}
 476 newId :: UserFS -> Type -> SimplM Id
 477 newId fs ty = getUniqueSmpl     `thenSmpl` \ uniq ->
 478               returnSmpl (mkSysLocal fs uniq ty)
 479 \end{code}
 480
 481
 482 %************************************************************************
 483 %*                                                                      *
 484 \subsection{Rebuilding a lambda}
 485 %*                                                                      *
 486 %************************************************************************
 487
 488 \begin{code}
 489 mkLam :: SimplEnv -> [OutBinder] -> OutExpr -> SimplCont -> SimplM FloatsWithExpr
 490 \end{code}
 491
 492 Try three things
 493         a) eta reduction, if that gives a trivial expression
 494         b) eta expansion [only if there are some value lambdas]
 495         c) floating lets out through big lambdas
 496                 [only if all tyvar lambdas, and only if this lambda
 497                  is the RHS of a let]
 498
 499 \begin{code}
 500 mkLam env bndrs body cont
 501  | opt_SimplDoEtaReduction,
 502    Just etad_lam <- tryEtaReduce bndrs body
 503  = tick (EtaReduction (head bndrs))     `thenSmpl_`
 504    returnSmpl (emptyFloats env, etad_lam)
 505
 506  | opt_SimplDoLambdaEtaExpansion,
 507    any isRuntimeVar bndrs
 508  = tryEtaExpansion body         `thenSmpl` \ body' ->
 509    returnSmpl (emptyFloats env, mkLams bndrs body')
 510
 511 {-      Sept 01: I'm experimenting with getting the
 512         full laziness pass to float out past big lambdsa
 513  | all isTyVar bndrs,   -- Only for big lambdas
 514    contIsRhs cont       -- Only try the rhs type-lambda floating
 515                         -- if this is indeed a right-hand side; otherwise
 516                         -- we end up floating the thing out, only for float-in
 517                         -- to float it right back in again!
 518  = tryRhsTyLam env bndrs body           `thenSmpl` \ (floats, body') ->
 519    returnSmpl (floats, mkLams bndrs body')
 520 -}
 521
 522  | otherwise
 523  = returnSmpl (emptyFloats env, mkLams bndrs body)
 524 \end{code}
 525
 526
 527 %************************************************************************
 528 %*                                                                      *
 529 \subsection{Eta expansion and reduction}
 530 %*                                                                      *
 531 %************************************************************************
 532
 533 We try for eta reduction here, but *only* if we get all the
 534 way to an exprIsTrivial expression.
 535 We don't want to remove extra lambdas unless we are going
 536 to avoid allocating this thing altogether
 537
 538 \begin{code}
 539 tryEtaReduce :: [OutBinder] -> OutExpr -> Maybe OutExpr
 540 tryEtaReduce bndrs body
 541         -- We don't use CoreUtils.etaReduce, because we can be more
 542         -- efficient here:
 543         --  (a) we already have the binders
 544         --  (b) we can do the triviality test before computing the free vars
 545         --      [in fact I take the simple path and look for just a variable]
 546   = go (reverse bndrs) body
 547   where
 548     go (b : bs) (App fun arg) | ok_arg b arg = go bs fun        -- Loop round
 549     go []       (Var fun)     | ok_fun fun   = Just (Var fun)   -- Success!
 550     go _        _                            = Nothing          -- Failure!
 551
 552     ok_fun fun   = not (fun `elem` bndrs) && not (hasNoBinding fun)
 553                         -- Note the awkward "hasNoBinding" test
 554                         -- Details with exprIsTrivial
 555     ok_arg b arg = varToCoreExpr b `cheapEqExpr` arg
 556 \end{code}
 557
 558
 559         Try eta expansion for RHSs
 560
 561 We go for:
 562    f = \x1..xn -> N  ==>   f = \x1..xn y1..ym -> N y1..ym
 563                                  (n >= 0)
 564
 565 where (in both cases)
 566
 567         * The xi can include type variables
 568
 569         * The yi are all value variables
 570
 571         * N is a NORMAL FORM (i.e. no redexes anywhere)
 572           wanting a suitable number of extra args.
 573
 574 We may have to sandwich some coerces between the lambdas
 575 to make the types work.   exprEtaExpandArity looks through coerces
 576 when computing arity; and etaExpand adds the coerces as necessary when
 577 actually computing the expansion.
 578
 579 \begin{code}
 580 tryEtaExpansion :: OutExpr -> SimplM OutExpr
 581 -- There is at least one runtime binder in the binders
 582 tryEtaExpansion body
 583   = getUniquesSmpl                      `thenSmpl` \ us ->
 584     returnSmpl (etaExpand fun_arity us body (exprType body))
 585   where
 586     fun_arity = exprEtaExpandArity body
 587 \end{code}
 588
 589
 590 %************************************************************************
 591 %*                                                                      *
 592 \subsection{Floating lets out of big lambdas}
 593 %*                                                                      *
 594 %************************************************************************
 595
 596 tryRhsTyLam tries this transformation, when the big lambda appears as
 597 the RHS of a let(rec) binding:
 598
 599         /\abc -> let(rec) x = e in b
 600    ==>
 601         let(rec) x' = /\abc -> let x = x' a b c in e
 602         in
 603         /\abc -> let x = x' a b c in b
 604
 605 This is good because it can turn things like:
 606
 607         let f = /\a -> letrec g = ... g ... in g
 608 into
 609         letrec g' = /\a -> ... g' a ...
 610         in
 611         let f = /\ a -> g' a
 612
 613 which is better.  In effect, it means that big lambdas don't impede
 614 let-floating.
 615
 616 This optimisation is CRUCIAL in eliminating the junk introduced by
 617 desugaring mutually recursive definitions.  Don't eliminate it lightly!
 618
 619 So far as the implementation is concerned:
 620
 621         Invariant: go F e = /\tvs -> F e
 622
 623         Equalities:
 624                 go F (Let x=e in b)
 625                 = Let x' = /\tvs -> F e
 626                   in
 627                   go G b
 628                 where
 629                     G = F . Let x = x' tvs
 630
 631                 go F (Letrec xi=ei in b)
 632                 = Letrec {xi' = /\tvs -> G ei}
 633                   in
 634                   go G b
 635                 where
 636                   G = F . Let {xi = xi' tvs}
 637
 638 [May 1999]  If we do this transformation *regardless* then we can
 639 end up with some pretty silly stuff.  For example,
 640
 641         let
 642             st = /\ s -> let { x1=r1 ; x2=r2 } in ...
 643         in ..
 644 becomes
 645         let y1 = /\s -> r1
 646             y2 = /\s -> r2
 647             st = /\s -> ...[y1 s/x1, y2 s/x2]
 648         in ..
 649
 650 Unless the "..." is a WHNF there is really no point in doing this.
 651 Indeed it can make things worse.  Suppose x1 is used strictly,
 652 and is of the form
 653
 654         x1* = case f y of { (a,b) -> e }
 655
 656 If we abstract this wrt the tyvar we then can't do the case inline
 657 as we would normally do.
 658
 659
 660 \begin{code}
 661 {-      Trying to do this in full laziness
 662
 663 tryRhsTyLam :: SimplEnv -> [OutTyVar] -> OutExpr -> SimplM FloatsWithExpr
 664 -- Call ensures that all the binders are type variables
 665
 666 tryRhsTyLam env tyvars body             -- Only does something if there's a let
 667   |  not (all isTyVar tyvars)
 668   || not (worth_it body)                -- inside a type lambda,
 669   = returnSmpl (emptyFloats env, body)  -- and a WHNF inside that
 670
 671   | otherwise
 672   = go env (\x -> x) body
 673
 674   where
 675     worth_it e@(Let _ _) = whnf_in_middle e
 676     worth_it e           = False
 677
 678     whnf_in_middle (Let (NonRec x rhs) e) | isUnLiftedType (idType x) = False
 679     whnf_in_middle (Let _ e) = whnf_in_middle e
 680     whnf_in_middle e         = exprIsCheap e
 681
 682     main_tyvar_set = mkVarSet tyvars
 683
 684     go env fn (Let bind@(NonRec var rhs) body)
 685       | exprIsTrivial rhs
 686       = go env (fn . Let bind) body
 687
 688     go env fn (Let (NonRec var rhs) body)
 689       = mk_poly tyvars_here var                                                 `thenSmpl` \ (var', rhs') ->
 690         addAuxiliaryBind env (NonRec var' (mkLams tyvars_here (fn rhs)))        $ \ env ->
 691         go env (fn . Let (mk_silly_bind var rhs')) body
 692
 693       where
 694
 695         tyvars_here = varSetElems (main_tyvar_set `intersectVarSet` exprSomeFreeVars isTyVar rhs)
 696                 -- Abstract only over the type variables free in the rhs
 697                 -- wrt which the new binding is abstracted.  But the naive
 698                 -- approach of abstract wrt the tyvars free in the Id's type
 699                 -- fails. Consider:
 700                 --      /\ a b -> let t :: (a,b) = (e1, e2)
 701                 --                    x :: a     = fst t
 702                 --                in ...
 703                 -- Here, b isn't free in x's type, but we must nevertheless
 704                 -- abstract wrt b as well, because t's type mentions b.
 705                 -- Since t is floated too, we'd end up with the bogus:
 706                 --      poly_t = /\ a b -> (e1, e2)
 707                 --      poly_x = /\ a   -> fst (poly_t a *b*)
 708                 -- So for now we adopt the even more naive approach of
 709                 -- abstracting wrt *all* the tyvars.  We'll see if that
 710                 -- gives rise to problems.   SLPJ June 98
 711
 712     go env fn (Let (Rec prs) body)
 713        = mapAndUnzipSmpl (mk_poly tyvars_here) vars     `thenSmpl` \ (vars', rhss') ->
 714          let
 715             gn body = fn (foldr Let body (zipWith mk_silly_bind vars rhss'))
 716             pairs   = vars' `zip` [mkLams tyvars_here (gn rhs) | rhs <- rhss]
 717          in
 718          addAuxiliaryBind env (Rec pairs)               $ \ env ->
 719          go env gn body
 720        where
 721          (vars,rhss) = unzip prs
 722          tyvars_here = varSetElems (main_tyvar_set `intersectVarSet` exprsSomeFreeVars isTyVar (map snd prs))
 723                 -- See notes with tyvars_here above
 724
 725     go env fn body = returnSmpl (emptyFloats env, fn body)
 726
 727     mk_poly tyvars_here var
 728       = getUniqueSmpl           `thenSmpl` \ uniq ->
 729         let
 730             poly_name = setNameUnique (idName var) uniq         -- Keep same name
 731             poly_ty   = mkForAllTys tyvars_here (idType var)    -- But new type of course
 732             poly_id   = mkLocalId poly_name poly_ty
 733
 734                 -- In the olden days, it was crucial to copy the occInfo of the original var,
 735                 -- because we were looking at occurrence-analysed but as yet unsimplified code!
 736                 -- In particular, we mustn't lose the loop breakers.  BUT NOW we are looking
 737                 -- at already simplified code, so it doesn't matter
 738                 --
 739                 -- It's even right to retain single-occurrence or dead-var info:
 740                 -- Suppose we started with  /\a -> let x = E in B
 741                 -- where x occurs once in B. Then we transform to:
 742                 --      let x' = /\a -> E in /\a -> let x* = x' a in B
 743                 -- where x* has an INLINE prag on it.  Now, once x* is inlined,
 744                 -- the occurrences of x' will be just the occurrences originally
 745                 -- pinned on x.
 746         in
 747         returnSmpl (poly_id, mkTyApps (Var poly_id) (mkTyVarTys tyvars_here))
 748
 749     mk_silly_bind var rhs = NonRec var (Note InlineMe rhs)
 750                 -- Suppose we start with:
 751                 --
 752                 --      x = /\ a -> let g = G in E
 753                 --
 754                 -- Then we'll float to get
 755                 --
 756                 --      x = let poly_g = /\ a -> G
 757                 --          in /\ a -> let g = poly_g a in E
 758                 --
 759                 -- But now the occurrence analyser will see just one occurrence
 760                 -- of poly_g, not inside a lambda, so the simplifier will
 761                 -- PreInlineUnconditionally poly_g back into g!  Badk to square 1!
 762                 -- (I used to think that the "don't inline lone occurrences" stuff
 763                 --  would stop this happening, but since it's the *only* occurrence,
 764                 --  PreInlineUnconditionally kicks in first!)
 765                 --
 766                 -- Solution: put an INLINE note on g's RHS, so that poly_g seems
 767                 --           to appear many times.  (NB: mkInlineMe eliminates
 768                 --           such notes on trivial RHSs, so do it manually.)
 769 -}
 770 \end{code}
 771
 772
 773 %************************************************************************
 774 %*                                                                      *
 775 \subsection{Case absorption and identity-case elimination}
 776 %*                                                                      *
 777 %************************************************************************
 778
 779 mkCase puts a case expression back together, trying various transformations first.
 780
 781 \begin{code}
 782 mkCase :: OutExpr -> OutId -> [OutAlt] -> SimplM OutExpr
 783
 784 mkCase scrut case_bndr alts
 785   = mkAlts scrut case_bndr alts `thenSmpl` \ better_alts ->
 786     mkCase1 scrut case_bndr better_alts
 787 \end{code}
 788
 789
 790 mkAlts tries these things:
 791
 792 1.  If several alternatives are identical, merge them into
 793     a single DEFAULT alternative.  I've occasionally seen this
 794     making a big difference:
 795
 796         case e of               =====>     case e of
 797           C _ -> f x                         D v -> ....v....
 798           D v -> ....v....                   DEFAULT -> f x
 799           DEFAULT -> f x
 800
 801    The point is that we merge common RHSs, at least for the DEFAULT case.
 802    [One could do something more elaborate but I've never seen it needed.]
 803    To avoid an expensive test, we just merge branches equal to the *first*
 804    alternative; this picks up the common cases
 805         a) all branches equal
 806         b) some branches equal to the DEFAULT (which occurs first)
 807
 808 2.  If the DEFAULT alternative can match only one possible constructor,
 809     then make that constructor explicit.
 810     e.g.
 811         case e of x { DEFAULT -> rhs }
 812      ===>
 813         case e of x { (a,b) -> rhs }
 814     where the type is a single constructor type.  This gives better code
 815     when rhs also scrutinises x or e.
 816
 817 3.  Case merging:
 818        case e of b {             ==>   case e of b {
 819          p1 -> rhs1                      p1 -> rhs1
 820          ...                             ...
 821          pm -> rhsm                      pm -> rhsm
 822          _  -> case b of b' {            pn -> let b'=b in rhsn
 823                      pn -> rhsn          ...
 824                      ...                 po -> let b'=b in rhso
 825                      po -> rhso          _  -> let b'=b in rhsd
 826                      _  -> rhsd
 827        }
 828
 829     which merges two cases in one case when -- the default alternative of
 830     the outer case scrutises the same variable as the outer case This
 831     transformation is called Case Merging.  It avoids that the same
 832     variable is scrutinised multiple times.
 833
 834
 835 The case where transformation (1) showed up was like this (lib/std/PrelCError.lhs):
 836
 837         x | p `is` 1 -> e1
 838           | p `is` 2 -> e2
 839         ...etc...
 840
 841 where @is@ was something like
 842
 843         p `is` n = p /= (-1) && p == n
 844
 845 This gave rise to a horrible sequence of cases
 846
 847         case p of
 848           (-1) -> $j p
 849           1    -> e1
 850           DEFAULT -> $j p
 851
 852 and similarly in cascade for all the join points!
 853
 854
 855
 856 \begin{code}
 857 --------------------------------------------------
 858 --      1. Merge identical branches
 859 --------------------------------------------------
 860 mkAlts scrut case_bndr alts@((con1,bndrs1,rhs1) : con_alts)
 861   | all isDeadBinder bndrs1,                    -- Remember the default
 862     length filtered_alts < length con_alts      -- alternative comes first
 863   = tick (AltMerge case_bndr)                   `thenSmpl_`
 864     returnSmpl better_alts
 865   where
 866     filtered_alts        = filter keep con_alts
 867     keep (con,bndrs,rhs) = not (all isDeadBinder bndrs && rhs `cheapEqExpr` rhs1)
 868     better_alts          = (DEFAULT, [], rhs1) : filtered_alts
 869
 870
 871 --------------------------------------------------
 872 --      2. Fill in missing constructor
 873 --------------------------------------------------
 874
 875 mkAlts scrut case_bndr alts
 876   | Just (tycon, inst_tys) <- splitTyConApp_maybe (idType case_bndr),
 877     isDataTyCon tycon,                  -- It's a data type
 878     (alts_no_deflt, Just rhs) <- findDefault alts,
 879                 -- There is a DEFAULT case
 880     [missing_con] <- filter is_missing (tyConDataConsIfAvailable tycon)
 881                 -- There is just one missing constructor!
 882   = tick (FillInCaseDefault case_bndr)  `thenSmpl_`
 883     getUniquesSmpl                      `thenSmpl` \ tv_uniqs ->
 884     getUniquesSmpl                      `thenSmpl` \ id_uniqs ->
 885     let
 886         (_,_,ex_tyvars,_,_,_) = dataConSig missing_con
 887         ex_tyvars'  = zipWith mk tv_uniqs ex_tyvars
 888         mk uniq tv  = mkSysTyVar uniq (tyVarKind tv)
 889         arg_ids     = zipWith (mkSysLocal SLIT("a")) id_uniqs arg_tys
 890         arg_tys     = dataConArgTys missing_con (inst_tys ++ mkTyVarTys ex_tyvars')
 891         better_alts = (DataAlt missing_con, ex_tyvars' ++ arg_ids, rhs) : alts_no_deflt
 892     in
 893     returnSmpl better_alts
 894   where
 895     impossible_cons   = otherCons (idUnfolding case_bndr)
 896     handled_data_cons = [data_con | DataAlt data_con         <- impossible_cons] ++
 897                         [data_con | (DataAlt data_con, _, _) <- alts]
 898     is_missing con    = not (con `elem` handled_data_cons)
 899
 900 --------------------------------------------------
 901 --      3.  Merge nested cases
 902 --------------------------------------------------
 903
 904 mkAlts scrut outer_bndr outer_alts
 905   | opt_SimplCaseMerge,
 906     (outer_alts_without_deflt, maybe_outer_deflt)   <- findDefault outer_alts,
 907     Just (Case (Var scrut_var) inner_bndr inner_alts) <- maybe_outer_deflt,
 908     scruting_same_var scrut_var
 909
 910   = let     --  Eliminate any inner alts which are shadowed by the outer ones
 911         outer_cons = [con | (con,_,_) <- outer_alts_without_deflt]
 912
 913         munged_inner_alts = [ (con, args, munge_rhs rhs)
 914                             | (con, args, rhs) <- inner_alts,
 915                                not (con `elem` outer_cons)      -- Eliminate shadowed inner alts
 916                             ]
 917         munge_rhs rhs = bindCaseBndr inner_bndr (Var outer_bndr) rhs
 918
 919         (inner_con_alts, maybe_inner_default) = findDefault munged_inner_alts
 920
 921         new_alts = add_default maybe_inner_default
 922                                (outer_alts_without_deflt ++ inner_con_alts)
 923     in
 924     tick (CaseMerge outer_bndr)                         `thenSmpl_`
 925     returnSmpl new_alts
 926         -- Warning: don't call mkAlts recursively!
 927         -- Firstly, there's no point, because inner alts have already had
 928         -- mkCase applied to them, so they won't have a case in their default
 929         -- Secondly, if you do, you get an infinite loop, because the bindCaseBndr
 930         -- in munge_rhs may put a case into the DEFAULT branch!
 931   where
 932         -- We are scrutinising the same variable if it's
 933         -- the outer case-binder, or if the outer case scrutinises a variable
 934         -- (and it's the same).  Testing both allows us not to replace the
 935         -- outer scrut-var with the outer case-binder (Simplify.simplCaseBinder).
 936     scruting_same_var = case scrut of
 937                           Var outer_scrut -> \ v -> v == outer_bndr || v == outer_scrut
 938                           other           -> \ v -> v == outer_bndr
 939
 940     add_default (Just rhs) alts = (DEFAULT,[],rhs) : alts
 941     add_default Nothing    alts = alts
 942
 943
 944 --------------------------------------------------
 945 --      Catch-all
 946 --------------------------------------------------
 947
 948 mkAlts scrut case_bndr other_alts = returnSmpl other_alts
 949 \end{code}
 950
 951
 952
 953 =================================================================================
 954
 955 mkCase1 tries these things
 956
 957 1.  Eliminate the case altogether if possible
 958
 959 2.  Case-identity:
 960
 961         case e of               ===> e
 962                 True  -> True;
 963                 False -> False
 964
 965     and similar friends.
 966
 967
 968 Start with a simple situation:
 969
 970         case x# of      ===>   e[x#/y#]
 971           y# -> e
 972
 973 (when x#, y# are of primitive type, of course).  We can't (in general)
 974 do this for algebraic cases, because we might turn bottom into
 975 non-bottom!
 976
 977 Actually, we generalise this idea to look for a case where we're
 978 scrutinising a variable, and we know that only the default case can
 979 match.  For example:
 980 \begin{verbatim}
 981         case x of
 982           0#    -> ...
 983           other -> ...(case x of
 984                          0#    -> ...
 985                          other -> ...) ...
 986 \end{code}
 987 Here the inner case can be eliminated.  This really only shows up in
 988 eliminating error-checking code.
 989
 990 We also make sure that we deal with this very common case:
 991
 992         case e of
 993           x -> ...x...
 994
 995 Here we are using the case as a strict let; if x is used only once
 996 then we want to inline it.  We have to be careful that this doesn't
 997 make the program terminate when it would have diverged before, so we
 998 check that
 999         - x is used strictly, or
1000         - e is already evaluated (it may so if e is a variable)
1001
1002 Lastly, we generalise the transformation to handle this:
1003
1004         case e of       ===> r
1005            True  -> r
1006            False -> r
1007
1008 We only do this for very cheaply compared r's (constructors, literals
1009 and variables).  If pedantic bottoms is on, we only do it when the
1010 scrutinee is a PrimOp which can't fail.
1011
1012 We do it *here*, looking at un-simplified alternatives, because we
1013 have to check that r doesn't mention the variables bound by the
1014 pattern in each alternative, so the binder-info is rather useful.
1015
1016 So the case-elimination algorithm is:
1017
1018         1. Eliminate alternatives which can't match
1019
1020         2. Check whether all the remaining alternatives
1021                 (a) do not mention in their rhs any of the variables bound in their pattern
1022            and  (b) have equal rhss
1023
1024         3. Check we can safely ditch the case:
1025                    * PedanticBottoms is off,
1026                 or * the scrutinee is an already-evaluated variable
1027                 or * the scrutinee is a primop which is ok for speculation
1028                         -- ie we want to preserve divide-by-zero errors, and
1029                         -- calls to error itself!
1030
1031                 or * [Prim cases] the scrutinee is a primitive variable
1032
1033                 or * [Alg cases] the scrutinee is a variable and
1034                      either * the rhs is the same variable
1035                         (eg case x of C a b -> x  ===>   x)
1036                      or     * there is only one alternative, the default alternative,
1037                                 and the binder is used strictly in its scope.
1038                                 [NB this is helped by the "use default binder where
1039                                  possible" transformation; see below.]
1040
1041
1042 If so, then we can replace the case with one of the rhss.
1043
1044
1045 \begin{code}
1046 --------------------------------------------------
1047 --      1. Eliminate the case altogether if poss
1048 --------------------------------------------------
1049
1050 mkCase1 scrut case_bndr [(con,bndrs,rhs)]
1051   -- See if we can get rid of the case altogether
1052   -- See the extensive notes on case-elimination above
1053   -- mkCase made sure that if all the alternatives are equal,
1054   -- then there is now only one (DEFAULT) rhs
1055  |  all isDeadBinder bndrs,
1056
1057         -- Check that the scrutinee can be let-bound instead of case-bound
1058     exprOkForSpeculation scrut
1059                 -- OK not to evaluate it
1060                 -- This includes things like (==# a# b#)::Bool
1061                 -- so that we simplify
1062                 --      case ==# a# b# of { True -> x; False -> x }
1063                 -- to just
1064                 --      x
1065                 -- This particular example shows up in default methods for
1066                 -- comparision operations (e.g. in (>=) for Int.Int32)
1067         || exprIsValue scrut                    -- It's already evaluated
1068         || var_demanded_later scrut             -- It'll be demanded later
1069
1070 --      || not opt_SimplPedanticBottoms)        -- Or we don't care!
1071 --      We used to allow improving termination by discarding cases, unless -fpedantic-bottoms was on,
1072 --      but that breaks badly for the dataToTag# primop, which relies on a case to evaluate
1073 --      its argument:  case x of { y -> dataToTag# y }
1074 --      Here we must *not* discard the case, because dataToTag# just fetches the tag from
1075 --      the info pointer.  So we'll be pedantic all the time, and see if that gives any
1076 --      other problems
1077   = tick (CaseElim case_bndr)                   `thenSmpl_`
1078     returnSmpl (bindCaseBndr case_bndr scrut rhs)
1079
1080   where
1081         -- The case binder is going to be evaluated later,
1082         -- and the scrutinee is a simple variable
1083     var_demanded_later (Var v) = isStrictDmd (idNewDemandInfo case_bndr)
1084     var_demanded_later other   = False
1085
1086
1087 --------------------------------------------------
1088 --      2. Identity case
1089 --------------------------------------------------
1090
1091 mkCase1 scrut case_bndr alts    -- Identity case
1092   | all identity_alt alts
1093   = tick (CaseIdentity case_bndr)               `thenSmpl_`
1094     returnSmpl (re_note scrut)
1095   where
1096     identity_alt (con, args, rhs) = de_note rhs `cheapEqExpr` identity_rhs con args
1097
1098     identity_rhs (DataAlt con) args = mkConApp con (arg_tys ++ map varToCoreExpr args)
1099     identity_rhs (LitAlt lit)  _    = Lit lit
1100     identity_rhs DEFAULT       _    = Var case_bndr
1101
1102     arg_tys = map Type (tyConAppArgs (idType case_bndr))
1103
1104         -- We've seen this:
1105         --      case coerce T e of x { _ -> coerce T' x }
1106         -- And we definitely want to eliminate this case!
1107         -- So we throw away notes from the RHS, and reconstruct
1108         -- (at least an approximation) at the other end
1109     de_note (Note _ e) = de_note e
1110     de_note e          = e
1111
1112         -- re_note wraps a coerce if it might be necessary
1113     re_note scrut = case head alts of
1114                         (_,_,rhs1@(Note _ _)) -> mkCoerce (exprType rhs1) (idType case_bndr) scrut
1115                         other                 -> scrut
1116
1117
1118 --------------------------------------------------
1119 --      Catch-all
1120 --------------------------------------------------
1121 mkCase1 scrut bndr alts = returnSmpl (Case scrut bndr alts)
1122 \end{code}
1123
1124
1125 When adding auxiliary bindings for the case binder, it's worth checking if
1126 its dead, because it often is, and occasionally these mkCase transformations
1127 cascade rather nicely.
1128
1129 \begin{code}
1130 bindCaseBndr bndr rhs body
1131   | isDeadBinder bndr = body
1132   | otherwise         = bindNonRec bndr rhs body
1133 \end{code}