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         mkLam, prepareAlts, mkCase,
   9
  10         -- Inlining,
  11         preInlineUnconditionally, postInlineUnconditionally, activeInline, activeRule,
  12         inlineMode,
  13
  14         -- The continuation type
  15         SimplCont(..), DupFlag(..), LetRhsFlag(..),
  16         contIsDupable, contResultType,
  17         countValArgs, countArgs, pushContArgs,
  18         mkBoringStop, mkRhsStop, contIsRhs, contIsRhsOrArg,
  19         getContArgs, interestingCallContext, interestingArg, isStrictType
  20
  21     ) where
  22
  23 #include "HsVersions.h"
  24
  25 import SimplEnv
  26 import DynFlags         ( SimplifierSwitch(..), SimplifierMode(..),
  27                           DynFlag(..), dopt )
  28 import StaticFlags      ( opt_UF_UpdateInPlace, opt_SimplNoPreInlining,
  29                           opt_RulesOff )
  30
  31 import CoreSyn
  32 import CoreFVs          ( exprFreeVars )
  33 import CoreUtils        ( cheapEqExpr, exprType, exprIsTrivial, exprIsCheap,
  34                           etaExpand, exprEtaExpandArity, bindNonRec, mkCoerce2,
  35                           findDefault, exprOkForSpeculation, exprIsHNF
  36                         )
  37 import CoreUnfold       ( smallEnoughToInline )
  38 import Id               ( idType, isDataConWorkId, idOccInfo, isDictId, idArity,
  39                           mkSysLocal, isDeadBinder, idNewDemandInfo, isExportedId,
  40                           idUnfolding, idNewStrictness, idInlinePragma,
  41                         )
  42 import NewDemand        ( isStrictDmd, isBotRes, splitStrictSig )
  43 import SimplMonad
  44 import Type             ( Type, splitFunTys, dropForAlls, isStrictType,
  45                           splitTyConApp_maybe, tyConAppArgs, mkTyVarTys
  46                         )
  47 import Name             ( mkSysTvName )
  48 import TyCon            ( tyConDataCons_maybe, isAlgTyCon, isNewTyCon )
  49 import DataCon          ( dataConRepArity, dataConTyVars, dataConArgTys, isVanillaDataCon )
  50 import Var              ( tyVarKind, mkTyVar )
  51 import VarSet
  52 import BasicTypes       ( TopLevelFlag(..), isTopLevel, isNotTopLevel, OccInfo(..), isLoopBreaker, isOneOcc,
  53                           Activation, isAlwaysActive, isActive )
  54 import Util             ( lengthExceeds )
  55 import Outputable
  56 \end{code}
  57
  58
  59 %************************************************************************
  60 %*                                                                      *
  61 \subsection{The continuation data type}
  62 %*                                                                      *
  63 %************************************************************************
  64
  65 \begin{code}
  66 data SimplCont          -- Strict contexts
  67   = Stop     OutType            -- Type of the result
  68              LetRhsFlag
  69              Bool               -- True <=> This is the RHS of a thunk whose type suggests
  70                                 --          that update-in-place would be possible
  71                                 --          (This makes the inliner a little keener.)
  72
  73   | CoerceIt OutType                    -- The To-type, simplified
  74              SimplCont
  75
  76   | InlinePlease                        -- This continuation makes a function very
  77              SimplCont                  -- keen to inline itelf
  78
  79   | ApplyTo  DupFlag
  80              InExpr SimplEnv            -- The argument, as yet unsimplified,
  81              SimplCont                  -- and its environment
  82
  83   | Select   DupFlag
  84              InId [InAlt] SimplEnv      -- The case binder, alts, and subst-env
  85              SimplCont
  86
  87   | ArgOf    LetRhsFlag         -- An arbitrary strict context: the argument
  88                                 --      of a strict function, or a primitive-arg fn
  89                                 --      or a PrimOp
  90                                 -- No DupFlag because we never duplicate it
  91              OutType            -- arg_ty: type of the argument itself
  92              OutType            -- cont_ty: the type of the expression being sought by the context
  93                                 --      f (error "foo") ==> coerce t (error "foo")
  94                                 -- when f is strict
  95                                 -- We need to know the type t, to which to coerce.
  96
  97              (SimplEnv -> OutExpr -> SimplM FloatsWithExpr)     -- What to do with the result
  98                                 -- The result expression in the OutExprStuff has type cont_ty
  99
 100 data LetRhsFlag = AnArg         -- It's just an argument not a let RHS
 101                 | AnRhs         -- It's the RHS of a let (so please float lets out of big lambdas)
 102
 103 instance Outputable LetRhsFlag where
 104   ppr AnArg = ptext SLIT("arg")
 105   ppr AnRhs = ptext SLIT("rhs")
 106
 107 instance Outputable SimplCont where
 108   ppr (Stop _ is_rhs _)              = ptext SLIT("Stop") <> brackets (ppr is_rhs)
 109   ppr (ApplyTo dup arg se cont)      = (ptext SLIT("ApplyTo") <+> ppr dup <+> ppr arg) $$ ppr cont
 110   ppr (ArgOf _ _ _ _)                = ptext SLIT("ArgOf...")
 111   ppr (Select dup bndr alts se cont) = (ptext SLIT("Select") <+> ppr dup <+> ppr bndr) $$
 112                                        (nest 4 (ppr alts)) $$ ppr cont
 113   ppr (CoerceIt ty cont)             = (ptext SLIT("CoerceIt") <+> ppr ty) $$ ppr cont
 114   ppr (InlinePlease cont)            = ptext SLIT("InlinePlease") $$ ppr cont
 115
 116 data DupFlag = OkToDup | NoDup
 117
 118 instance Outputable DupFlag where
 119   ppr OkToDup = ptext SLIT("ok")
 120   ppr NoDup   = ptext SLIT("nodup")
 121
 122
 123 -------------------
 124 mkBoringStop, mkRhsStop :: OutType -> SimplCont
 125 mkBoringStop ty = Stop ty AnArg (canUpdateInPlace ty)
 126 mkRhsStop    ty = Stop ty AnRhs (canUpdateInPlace ty)
 127
 128 contIsRhs :: SimplCont -> Bool
 129 contIsRhs (Stop _ AnRhs _)    = True
 130 contIsRhs (ArgOf AnRhs _ _ _) = True
 131 contIsRhs other               = False
 132
 133 contIsRhsOrArg (Stop _ _ _)    = True
 134 contIsRhsOrArg (ArgOf _ _ _ _) = True
 135 contIsRhsOrArg other           = False
 136
 137 -------------------
 138 contIsDupable :: SimplCont -> Bool
 139 contIsDupable (Stop _ _ _)               = True
 140 contIsDupable (ApplyTo  OkToDup _ _ _)   = True
 141 contIsDupable (Select   OkToDup _ _ _ _) = True
 142 contIsDupable (CoerceIt _ cont)          = contIsDupable cont
 143 contIsDupable (InlinePlease cont)        = contIsDupable cont
 144 contIsDupable other                      = False
 145
 146 -------------------
 147 discardableCont :: SimplCont -> Bool
 148 discardableCont (Stop _ _ _)        = False
 149 discardableCont (CoerceIt _ cont)   = discardableCont cont
 150 discardableCont (InlinePlease cont) = discardableCont cont
 151 discardableCont other               = True
 152
 153 discardCont :: SimplCont        -- A continuation, expecting
 154             -> SimplCont        -- Replace the continuation with a suitable coerce
 155 discardCont cont = case cont of
 156                      Stop to_ty is_rhs _ -> cont
 157                      other               -> CoerceIt to_ty (mkBoringStop to_ty)
 158                  where
 159                    to_ty = contResultType cont
 160
 161 -------------------
 162 contResultType :: SimplCont -> OutType
 163 contResultType (Stop to_ty _ _)      = to_ty
 164 contResultType (ArgOf _ _ to_ty _)   = to_ty
 165 contResultType (ApplyTo _ _ _ cont)  = contResultType cont
 166 contResultType (CoerceIt _ cont)     = contResultType cont
 167 contResultType (InlinePlease cont)   = contResultType cont
 168 contResultType (Select _ _ _ _ cont) = contResultType cont
 169
 170 -------------------
 171 countValArgs :: SimplCont -> Int
 172 countValArgs (ApplyTo _ (Type ty) se cont) = countValArgs cont
 173 countValArgs (ApplyTo _ val_arg   se cont) = 1 + countValArgs cont
 174 countValArgs other                         = 0
 175
 176 countArgs :: SimplCont -> Int
 177 countArgs (ApplyTo _ arg se cont) = 1 + countArgs cont
 178 countArgs other                   = 0
 179
 180 -------------------
 181 pushContArgs :: SimplEnv -> [OutArg] -> SimplCont -> SimplCont
 182 -- Pushes args with the specified environment
 183 pushContArgs env []           cont = cont
 184 pushContArgs env (arg : args) cont = ApplyTo NoDup arg env (pushContArgs env args cont)
 185 \end{code}
 186
 187
 188 \begin{code}
 189 getContArgs :: SwitchChecker
 190             -> OutId -> SimplCont
 191             -> ([(InExpr, SimplEnv, Bool)],     -- Arguments; the Bool is true for strict args
 192                 SimplCont,                      -- Remaining continuation
 193                 Bool)                           -- Whether we came across an InlineCall
 194 -- getContArgs id k = (args, k', inl)
 195 --      args are the leading ApplyTo items in k
 196 --      (i.e. outermost comes first)
 197 --      augmented with demand info from the functionn
 198 getContArgs chkr fun orig_cont
 199   = let
 200                 -- Ignore strictness info if the no-case-of-case
 201                 -- flag is on.  Strictness changes evaluation order
 202                 -- and that can change full laziness
 203         stricts | switchIsOn chkr NoCaseOfCase = vanilla_stricts
 204                 | otherwise                    = computed_stricts
 205     in
 206     go [] stricts False orig_cont
 207   where
 208     ----------------------------
 209
 210         -- Type argument
 211     go acc ss inl (ApplyTo _ arg@(Type _) se cont)
 212         = go ((arg,se,False) : acc) ss inl cont
 213                 -- NB: don't bother to instantiate the function type
 214
 215         -- Value argument
 216     go acc (s:ss) inl (ApplyTo _ arg se cont)
 217         = go ((arg,se,s) : acc) ss inl cont
 218
 219         -- An Inline continuation
 220     go acc ss inl (InlinePlease cont)
 221         = go acc ss True cont
 222
 223         -- We're run out of arguments, or else we've run out of demands
 224         -- The latter only happens if the result is guaranteed bottom
 225         -- This is the case for
 226         --      * case (error "hello") of { ... }
 227         --      * (error "Hello") arg
 228         --      * f (error "Hello") where f is strict
 229         --      etc
 230         -- Then, especially in the first of these cases, we'd like to discard
 231         -- the continuation, leaving just the bottoming expression.  But the
 232         -- type might not be right, so we may have to add a coerce.
 233     go acc ss inl cont
 234         | null ss && discardableCont cont = (reverse acc, discardCont cont, inl)
 235         | otherwise                       = (reverse acc, cont,             inl)
 236
 237     ----------------------------
 238     vanilla_stricts, computed_stricts :: [Bool]
 239     vanilla_stricts  = repeat False
 240     computed_stricts = zipWith (||) fun_stricts arg_stricts
 241
 242     ----------------------------
 243     (val_arg_tys, _) = splitFunTys (dropForAlls (idType fun))
 244     arg_stricts      = map isStrictType val_arg_tys ++ repeat False
 245         -- These argument types are used as a cheap and cheerful way to find
 246         -- unboxed arguments, which must be strict.  But it's an InType
 247         -- and so there might be a type variable where we expect a function
 248         -- type (the substitution hasn't happened yet).  And we don't bother
 249         -- doing the type applications for a polymorphic function.
 250         -- Hence the splitFunTys*IgnoringForAlls*
 251
 252     ----------------------------
 253         -- If fun_stricts is finite, it means the function returns bottom
 254         -- after that number of value args have been consumed
 255         -- Otherwise it's infinite, extended with False
 256     fun_stricts
 257       = case splitStrictSig (idNewStrictness fun) of
 258           (demands, result_info)
 259                 | not (demands `lengthExceeds` countValArgs orig_cont)
 260                 ->      -- Enough args, use the strictness given.
 261                         -- For bottoming functions we used to pretend that the arg
 262                         -- is lazy, so that we don't treat the arg as an
 263                         -- interesting context.  This avoids substituting
 264                         -- top-level bindings for (say) strings into
 265                         -- calls to error.  But now we are more careful about
 266                         -- inlining lone variables, so its ok (see SimplUtils.analyseCont)
 267                    if isBotRes result_info then
 268                         map isStrictDmd demands         -- Finite => result is bottom
 269                    else
 270                         map isStrictDmd demands ++ vanilla_stricts
 271
 272           other -> vanilla_stricts      -- Not enough args, or no strictness
 273
 274 -------------------
 275 interestingArg :: OutExpr -> Bool
 276         -- An argument is interesting if it has *some* structure
 277         -- We are here trying to avoid unfolding a function that
 278         -- is applied only to variables that have no unfolding
 279         -- (i.e. they are probably lambda bound): f x y z
 280         -- There is little point in inlining f here.
 281 interestingArg (Var v)           = hasSomeUnfolding (idUnfolding v)
 282                                         -- Was: isValueUnfolding (idUnfolding v')
 283                                         -- But that seems over-pessimistic
 284                                  || isDataConWorkId v
 285                                         -- This accounts for an argument like
 286                                         -- () or [], which is definitely interesting
 287 interestingArg (Type _)          = False
 288 interestingArg (App fn (Type _)) = interestingArg fn
 289 interestingArg (Note _ a)        = interestingArg a
 290 interestingArg other             = True
 291         -- Consider     let x = 3 in f x
 292         -- The substitution will contain (x -> ContEx 3), and we want to
 293         -- to say that x is an interesting argument.
 294         -- But consider also (\x. f x y) y
 295         -- The substitution will contain (x -> ContEx y), and we want to say
 296         -- that x is not interesting (assuming y has no unfolding)
 297 \end{code}
 298
 299 Comment about interestingCallContext
 300 ~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~
 301 We want to avoid inlining an expression where there can't possibly be
 302 any gain, such as in an argument position.  Hence, if the continuation
 303 is interesting (eg. a case scrutinee, application etc.) then we
 304 inline, otherwise we don't.
 305
 306 Previously some_benefit used to return True only if the variable was
 307 applied to some value arguments.  This didn't work:
 308
 309         let x = _coerce_ (T Int) Int (I# 3) in
 310         case _coerce_ Int (T Int) x of
 311                 I# y -> ....
 312
 313 we want to inline x, but can't see that it's a constructor in a case
 314 scrutinee position, and some_benefit is False.
 315
 316 Another example:
 317
 318 dMonadST = _/\_ t -> :Monad (g1 _@_ t, g2 _@_ t, g3 _@_ t)
 319
 320 ....  case dMonadST _@_ x0 of (a,b,c) -> ....
 321
 322 we'd really like to inline dMonadST here, but we *don't* want to
 323 inline if the case expression is just
 324
 325         case x of y { DEFAULT -> ... }
 326
 327 since we can just eliminate this case instead (x is in WHNF).  Similar
 328 applies when x is bound to a lambda expression.  Hence
 329 contIsInteresting looks for case expressions with just a single
 330 default case.
 331
 332 \begin{code}
 333 interestingCallContext :: Bool          -- False <=> no args at all
 334                        -> Bool          -- False <=> no value args
 335                        -> SimplCont -> Bool
 336         -- The "lone-variable" case is important.  I spent ages
 337         -- messing about with unsatisfactory varaints, but this is nice.
 338         -- The idea is that if a variable appear all alone
 339         --      as an arg of lazy fn, or rhs    Stop
 340         --      as scrutinee of a case          Select
 341         --      as arg of a strict fn           ArgOf
 342         -- then we should not inline it (unless there is some other reason,
 343         -- e.g. is is the sole occurrence).  We achieve this by making
 344         -- interestingCallContext return False for a lone variable.
 345         --
 346         -- Why?  At least in the case-scrutinee situation, turning
 347         --      let x = (a,b) in case x of y -> ...
 348         -- into
 349         --      let x = (a,b) in case (a,b) of y -> ...
 350         -- and thence to
 351         --      let x = (a,b) in let y = (a,b) in ...
 352         -- is bad if the binding for x will remain.
 353         --
 354         -- Another example: I discovered that strings
 355         -- were getting inlined straight back into applications of 'error'
 356         -- because the latter is strict.
 357         --      s = "foo"
 358         --      f = \x -> ...(error s)...
 359
 360         -- Fundamentally such contexts should not ecourage inlining because
 361         -- the context can ``see'' the unfolding of the variable (e.g. case or a RULE)
 362         -- so there's no gain.
 363         --
 364         -- However, even a type application or coercion isn't a lone variable.
 365         -- Consider
 366         --      case $fMonadST @ RealWorld of { :DMonad a b c -> c }
 367         -- We had better inline that sucker!  The case won't see through it.
 368         --
 369         -- For now, I'm treating treating a variable applied to types
 370         -- in a *lazy* context "lone". The motivating example was
 371         --      f = /\a. \x. BIG
 372         --      g = /\a. \y.  h (f a)
 373         -- There's no advantage in inlining f here, and perhaps
 374         -- a significant disadvantage.  Hence some_val_args in the Stop case
 375
 376 interestingCallContext some_args some_val_args cont
 377   = interesting cont
 378   where
 379     interesting (InlinePlease _)         = True
 380     interesting (Select _ _ _ _ _)       = some_args
 381     interesting (ApplyTo _ _ _ _)        = True -- Can happen if we have (coerce t (f x)) y
 382                                                 -- Perhaps True is a bit over-keen, but I've
 383                                                 -- seen (coerce f) x, where f has an INLINE prag,
 384                                                 -- So we have to give some motivaiton for inlining it
 385     interesting (ArgOf _ _ _ _)          = some_val_args
 386     interesting (Stop ty _ upd_in_place) = some_val_args && upd_in_place
 387     interesting (CoerceIt _ cont)        = interesting cont
 388         -- If this call is the arg of a strict function, the context
 389         -- is a bit interesting.  If we inline here, we may get useful
 390         -- evaluation information to avoid repeated evals: e.g.
 391         --      x + (y * z)
 392         -- Here the contIsInteresting makes the '*' keener to inline,
 393         -- which in turn exposes a constructor which makes the '+' inline.
 394         -- Assuming that +,* aren't small enough to inline regardless.
 395         --
 396         -- It's also very important to inline in a strict context for things
 397         -- like
 398         --              foldr k z (f x)
 399         -- Here, the context of (f x) is strict, and if f's unfolding is
 400         -- a build it's *great* to inline it here.  So we must ensure that
 401         -- the context for (f x) is not totally uninteresting.
 402
 403
 404 -------------------
 405 canUpdateInPlace :: Type -> Bool
 406 -- Consider   let x = <wurble> in ...
 407 -- If <wurble> returns an explicit constructor, we might be able
 408 -- to do update in place.  So we treat even a thunk RHS context
 409 -- as interesting if update in place is possible.  We approximate
 410 -- this by seeing if the type has a single constructor with a
 411 -- small arity.  But arity zero isn't good -- we share the single copy
 412 -- for that case, so no point in sharing.
 413
 414 canUpdateInPlace ty
 415   | not opt_UF_UpdateInPlace = False
 416   | otherwise
 417   = case splitTyConApp_maybe ty of
 418         Nothing         -> False
 419         Just (tycon, _) -> case tyConDataCons_maybe tycon of
 420                                 Just [dc]  -> arity == 1 || arity == 2
 421                                            where
 422                                               arity = dataConRepArity dc
 423                                 other -> False
 424 \end{code}
 425
 426
 427
 428 %************************************************************************
 429 %*                                                                      *
 430 \subsection{Decisions about inlining}
 431 %*                                                                      *
 432 %************************************************************************
 433
 434 Inlining is controlled partly by the SimplifierMode switch.  This has two
 435 settings:
 436
 437         SimplGently     (a) Simplifying before specialiser/full laziness
 438                         (b) Simplifiying inside INLINE pragma
 439                         (c) Simplifying the LHS of a rule
 440                         (d) Simplifying a GHCi expression or Template
 441                                 Haskell splice
 442
 443         SimplPhase n    Used at all other times
 444
 445 The key thing about SimplGently is that it does no call-site inlining.
 446 Before full laziness we must be careful not to inline wrappers,
 447 because doing so inhibits floating
 448     e.g. ...(case f x of ...)...
 449     ==> ...(case (case x of I# x# -> fw x#) of ...)...
 450     ==> ...(case x of I# x# -> case fw x# of ...)...
 451 and now the redex (f x) isn't floatable any more.
 452
 453 The no-inling thing is also important for Template Haskell.  You might be
 454 compiling in one-shot mode with -O2; but when TH compiles a splice before
 455 running it, we don't want to use -O2.  Indeed, we don't want to inline
 456 anything, because the byte-code interpreter might get confused about
 457 unboxed tuples and suchlike.
 458
 459 INLINE pragmas
 460 ~~~~~~~~~~~~~~
 461 SimplGently is also used as the mode to simplify inside an InlineMe note.
 462
 463 \begin{code}
 464 inlineMode :: SimplifierMode
 465 inlineMode = SimplGently
 466 \end{code}
 467
 468 It really is important to switch off inlinings inside such
 469 expressions.  Consider the following example
 470
 471         let f = \pq -> BIG
 472         in
 473         let g = \y -> f y y
 474             {-# INLINE g #-}
 475         in ...g...g...g...g...g...
 476
 477 Now, if that's the ONLY occurrence of f, it will be inlined inside g,
 478 and thence copied multiple times when g is inlined.
 479
 480
 481 This function may be inlinined in other modules, so we
 482 don't want to remove (by inlining) calls to functions that have
 483 specialisations, or that may have transformation rules in an importing
 484 scope.
 485
 486 E.g.    {-# INLINE f #-}
 487                 f x = ...g...
 488
 489 and suppose that g is strict *and* has specialisations.  If we inline
 490 g's wrapper, we deny f the chance of getting the specialised version
 491 of g when f is inlined at some call site (perhaps in some other
 492 module).
 493
 494 It's also important not to inline a worker back into a wrapper.
 495 A wrapper looks like
 496         wraper = inline_me (\x -> ...worker... )
 497 Normally, the inline_me prevents the worker getting inlined into
 498 the wrapper (initially, the worker's only call site!).  But,
 499 if the wrapper is sure to be called, the strictness analyser will
 500 mark it 'demanded', so when the RHS is simplified, it'll get an ArgOf
 501 continuation.  That's why the keep_inline predicate returns True for
 502 ArgOf continuations.  It shouldn't do any harm not to dissolve the
 503 inline-me note under these circumstances.
 504
 505 Note that the result is that we do very little simplification
 506 inside an InlineMe.
 507
 508         all xs = foldr (&&) True xs
 509         any p = all . map p  {-# INLINE any #-}
 510
 511 Problem: any won't get deforested, and so if it's exported and the
 512 importer doesn't use the inlining, (eg passes it as an arg) then we
 513 won't get deforestation at all.  We havn't solved this problem yet!
 514
 515
 516 preInlineUnconditionally
 517 ~~~~~~~~~~~~~~~~~~~~~~~~
 518 @preInlineUnconditionally@ examines a bndr to see if it is used just
 519 once in a completely safe way, so that it is safe to discard the
 520 binding inline its RHS at the (unique) usage site, REGARDLESS of how
 521 big the RHS might be.  If this is the case we don't simplify the RHS
 522 first, but just inline it un-simplified.
 523
 524 This is much better than first simplifying a perhaps-huge RHS and then
 525 inlining and re-simplifying it.  Indeed, it can be at least quadratically
 526 better.  Consider
 527
 528         x1 = e1
 529         x2 = e2[x1]
 530         x3 = e3[x2]
 531         ...etc...
 532         xN = eN[xN-1]
 533
 534 We may end up simplifying e1 N times, e2 N-1 times, e3 N-3 times etc.
 535 This can happen with cascades of functions too:
 536
 537         f1 = \x1.e1
 538         f2 = \xs.e2[f1]
 539         f3 = \xs.e3[f3]
 540         ...etc...
 541
 542 THE MAIN INVARIANT is this:
 543
 544         ----  preInlineUnconditionally invariant -----
 545    IF preInlineUnconditionally chooses to inline x = <rhs>
 546    THEN doing the inlining should not change the occurrence
 547         info for the free vars of <rhs>
 548         ----------------------------------------------
 549
 550 For example, it's tempting to look at trivial binding like
 551         x = y
 552 and inline it unconditionally.  But suppose x is used many times,
 553 but this is the unique occurrence of y.  Then inlining x would change
 554 y's occurrence info, which breaks the invariant.  It matters: y
 555 might have a BIG rhs, which will now be dup'd at every occurrenc of x.
 556
 557
 558 Evne RHSs labelled InlineMe aren't caught here, because there might be
 559 no benefit from inlining at the call site.
 560
 561 [Sept 01] Don't unconditionally inline a top-level thing, because that
 562 can simply make a static thing into something built dynamically.  E.g.
 563         x = (a,b)
 564         main = \s -> h x
 565
 566 [Remember that we treat \s as a one-shot lambda.]  No point in
 567 inlining x unless there is something interesting about the call site.
 568
 569 But watch out: if you aren't careful, some useful foldr/build fusion
 570 can be lost (most notably in spectral/hartel/parstof) because the
 571 foldr didn't see the build.  Doing the dynamic allocation isn't a big
 572 deal, in fact, but losing the fusion can be.  But the right thing here
 573 seems to be to do a callSiteInline based on the fact that there is
 574 something interesting about the call site (it's strict).  Hmm.  That
 575 seems a bit fragile.
 576
 577 Conclusion: inline top level things gaily until Phase 0 (the last
 578 phase), at which point don't.
 579
 580 \begin{code}
 581 preInlineUnconditionally :: SimplEnv -> TopLevelFlag -> InId -> InExpr -> Bool
 582 preInlineUnconditionally env top_lvl bndr rhs
 583   | not active             = False
 584   | opt_SimplNoPreInlining = False
 585   | otherwise = case idOccInfo bndr of
 586                   IAmDead                    -> True    -- Happens in ((\x.1) v)
 587                   OneOcc in_lam True int_cxt -> try_once in_lam int_cxt
 588                   other                      -> False
 589   where
 590     phase = getMode env
 591     active = case phase of
 592                    SimplGently  -> isAlwaysActive prag
 593                    SimplPhase n -> isActive n prag
 594     prag = idInlinePragma bndr
 595
 596     try_once in_lam int_cxt     -- There's one textual occurrence
 597         | not in_lam = isNotTopLevel top_lvl || early_phase
 598         | otherwise  = int_cxt && canInlineInLam rhs
 599
 600 -- Be very careful before inlining inside a lambda, becuase (a) we must not
 601 -- invalidate occurrence information, and (b) we want to avoid pushing a
 602 -- single allocation (here) into multiple allocations (inside lambda).
 603 -- Inlining a *function* with a single *saturated* call would be ok, mind you.
 604 --      || (if is_cheap && not (canInlineInLam rhs) then pprTrace "preinline" (ppr bndr <+> ppr rhs) ok else ok)
 605 --      where
 606 --              is_cheap = exprIsCheap rhs
 607 --              ok = is_cheap && int_cxt
 608
 609         --      int_cxt         The context isn't totally boring
 610         -- E.g. let f = \ab.BIG in \y. map f xs
 611         --      Don't want to substitute for f, because then we allocate
 612         --      its closure every time the \y is called
 613         -- But: let f = \ab.BIG in \y. map (f y) xs
 614         --      Now we do want to substitute for f, even though it's not
 615         --      saturated, because we're going to allocate a closure for
 616         --      (f y) every time round the loop anyhow.
 617
 618         -- canInlineInLam => free vars of rhs are (Once in_lam) or Many,
 619         -- so substituting rhs inside a lambda doesn't change the occ info.
 620         -- Sadly, not quite the same as exprIsHNF.
 621     canInlineInLam (Lit l)              = True
 622     canInlineInLam (Lam b e)            = isRuntimeVar b || canInlineInLam e
 623     canInlineInLam (Note _ e)           = canInlineInLam e
 624     canInlineInLam _                    = False
 625
 626     early_phase = case phase of
 627                         SimplPhase 0 -> False
 628                         other        -> True
 629 -- If we don't have this early_phase test, consider
 630 --      x = length [1,2,3]
 631 -- The full laziness pass carefully floats all the cons cells to
 632 -- top level, and preInlineUnconditionally floats them all back in.
 633 -- Result is (a) static allocation replaced by dynamic allocation
 634 --           (b) many simplifier iterations because this tickles
 635 --               a related problem; only one inlining per pass
 636 --
 637 -- On the other hand, I have seen cases where top-level fusion is
 638 -- lost if we don't inline top level thing (e.g. string constants)
 639 -- Hence the test for phase zero (which is the phase for all the final
 640 -- simplifications).  Until phase zero we take no special notice of
 641 -- top level things, but then we become more leery about inlining
 642 -- them.
 643
 644 \end{code}
 645
 646 postInlineUnconditionally
 647 ~~~~~~~~~~~~~~~~~~~~~~~~~
 648 @postInlineUnconditionally@ decides whether to unconditionally inline
 649 a thing based on the form of its RHS; in particular if it has a
 650 trivial RHS.  If so, we can inline and discard the binding altogether.
 651
 652 NB: a loop breaker has must_keep_binding = True and non-loop-breakers
 653 only have *forward* references Hence, it's safe to discard the binding
 654
 655 NOTE: This isn't our last opportunity to inline.  We're at the binding
 656 site right now, and we'll get another opportunity when we get to the
 657 ocurrence(s)
 658
 659 Note that we do this unconditional inlining only for trival RHSs.
 660 Don't inline even WHNFs inside lambdas; doing so may simply increase
 661 allocation when the function is called. This isn't the last chance; see
 662 NOTE above.
 663
 664 NB: Even inline pragmas (e.g. IMustBeINLINEd) are ignored here Why?
 665 Because we don't even want to inline them into the RHS of constructor
 666 arguments. See NOTE above
 667
 668 NB: At one time even NOINLINE was ignored here: if the rhs is trivial
 669 it's best to inline it anyway.  We often get a=E; b=a from desugaring,
 670 with both a and b marked NOINLINE.  But that seems incompatible with
 671 our new view that inlining is like a RULE, so I'm sticking to the 'active'
 672 story for now.
 673
 674 \begin{code}
 675 postInlineUnconditionally :: SimplEnv -> TopLevelFlag -> OutId -> OccInfo -> OutExpr -> Unfolding -> Bool
 676 postInlineUnconditionally env top_lvl bndr occ_info rhs unfolding
 677   | not active             = False
 678   | isLoopBreaker occ_info = False
 679   | isExportedId bndr      = False
 680   | exprIsTrivial rhs      = True
 681   | otherwise
 682   = case occ_info of
 683       OneOcc in_lam one_br int_cxt
 684         ->     (one_br || smallEnoughToInline unfolding)        -- Small enough to dup
 685                         -- ToDo: consider discount on smallEnoughToInline if int_cxt is true
 686                         --
 687                         -- NB: Do we want to inline arbitrarily big things becuase
 688                         -- one_br is True? that can lead to inline cascades.  But
 689                         -- preInlineUnconditionlly has dealt with all the common cases
 690                         -- so perhaps it's worth the risk. Here's an example
 691                         --      let f = if b then Left (\x.BIG) else Right (\y.BIG)
 692                         --      in \y. ....f....
 693                         -- We can't preInlineUnconditionally because that woud invalidate
 694                         -- the occ info for b.  Yet f is used just once, and duplicating
 695                         -- the case work is fine (exprIsCheap).
 696
 697            &&  ((isNotTopLevel top_lvl && not in_lam) ||
 698                         -- But outside a lambda, we want to be reasonably aggressive
 699                         -- about inlining into multiple branches of case
 700                         -- e.g. let x = <non-value>
 701                         --      in case y of { C1 -> ..x..; C2 -> ..x..; C3 -> ... }
 702                         -- Inlining can be a big win if C3 is the hot-spot, even if
 703                         -- the uses in C1, C2 are not 'interesting'
 704                         -- An example that gets worse if you add int_cxt here is 'clausify'
 705
 706                 (isCheapUnfolding unfolding && int_cxt))
 707                         -- isCheap => acceptable work duplication; in_lam may be true
 708                         -- int_cxt to prevent us inlining inside a lambda without some
 709                         -- good reason.  See the notes on int_cxt in preInlineUnconditionally
 710
 711       other -> False
 712         -- The point here is that for *non-values* that occur
 713         -- outside a lambda, the call-site inliner won't have
 714         -- a chance (becuase it doesn't know that the thing
 715         -- only occurs once).   The pre-inliner won't have gotten
 716         -- it either, if the thing occurs in more than one branch
 717         -- So the main target is things like
 718         --      let x = f y in
 719         --      case v of
 720         --         True  -> case x of ...
 721         --         False -> case x of ...
 722         -- I'm not sure how important this is in practice
 723   where
 724     active = case getMode env of
 725                    SimplGently  -> isAlwaysActive prag
 726                    SimplPhase n -> isActive n prag
 727     prag = idInlinePragma bndr
 728
 729 activeInline :: SimplEnv -> OutId -> OccInfo -> Bool
 730 activeInline env id occ
 731   = case getMode env of
 732       SimplGently -> isOneOcc occ && isAlwaysActive prag
 733         -- No inlining at all when doing gentle stuff,
 734         -- except for local things that occur once
 735         -- The reason is that too little clean-up happens if you
 736         -- don't inline use-once things.   Also a bit of inlining is *good* for
 737         -- full laziness; it can expose constant sub-expressions.
 738         -- Example in spectral/mandel/Mandel.hs, where the mandelset
 739         -- function gets a useful let-float if you inline windowToViewport
 740
 741         -- NB: we used to have a second exception, for data con wrappers.
 742         -- On the grounds that we use gentle mode for rule LHSs, and
 743         -- they match better when data con wrappers are inlined.
 744         -- But that only really applies to the trivial wrappers (like (:)),
 745         -- and they are now constructed as Compulsory unfoldings (in MkId)
 746         -- so they'll happen anyway.
 747
 748       SimplPhase n -> isActive n prag
 749   where
 750     prag = idInlinePragma id
 751
 752 activeRule :: SimplEnv -> Maybe (Activation -> Bool)
 753 -- Nothing => No rules at all
 754 activeRule env
 755   | opt_RulesOff = Nothing
 756   | otherwise
 757   = case getMode env of
 758         SimplGently  -> Just isAlwaysActive
 759                         -- Used to be Nothing (no rules in gentle mode)
 760                         -- Main motivation for changing is that I wanted
 761                         --      lift String ===> ...
 762                         -- to work in Template Haskell when simplifying
 763                         -- splices, so we get simpler code for literal strings
 764         SimplPhase n -> Just (isActive n)
 765 \end{code}
 766
 767
 768 %************************************************************************
 769 %*                                                                      *
 770 \subsection{Rebuilding a lambda}
 771 %*                                                                      *
 772 %************************************************************************
 773
 774 \begin{code}
 775 mkLam :: SimplEnv -> [OutBinder] -> OutExpr -> SimplCont -> SimplM FloatsWithExpr
 776 \end{code}
 777
 778 Try three things
 779         a) eta reduction, if that gives a trivial expression
 780         b) eta expansion [only if there are some value lambdas]
 781         c) floating lets out through big lambdas
 782                 [only if all tyvar lambdas, and only if this lambda
 783                  is the RHS of a let]
 784
 785 \begin{code}
 786 mkLam env bndrs body cont
 787  = getDOptsSmpl  `thenSmpl` \dflags ->
 788    mkLam' dflags env bndrs body cont
 789  where
 790  mkLam' dflags env bndrs body cont
 791    | dopt Opt_DoEtaReduction dflags,
 792      Just etad_lam <- tryEtaReduce bndrs body
 793    = tick (EtaReduction (head bndrs))   `thenSmpl_`
 794      returnSmpl (emptyFloats env, etad_lam)
 795
 796    | dopt Opt_DoLambdaEtaExpansion dflags,
 797      any isRuntimeVar bndrs
 798    = tryEtaExpansion body               `thenSmpl` \ body' ->
 799      returnSmpl (emptyFloats env, mkLams bndrs body')
 800
 801 {-      Sept 01: I'm experimenting with getting the
 802         full laziness pass to float out past big lambdsa
 803  | all isTyVar bndrs,   -- Only for big lambdas
 804    contIsRhs cont       -- Only try the rhs type-lambda floating
 805                         -- if this is indeed a right-hand side; otherwise
 806                         -- we end up floating the thing out, only for float-in
 807                         -- to float it right back in again!
 808  = tryRhsTyLam env bndrs body           `thenSmpl` \ (floats, body') ->
 809    returnSmpl (floats, mkLams bndrs body')
 810 -}
 811
 812    | otherwise
 813    = returnSmpl (emptyFloats env, mkLams bndrs body)
 814 \end{code}
 815
 816
 817 %************************************************************************
 818 %*                                                                      *
 819 \subsection{Eta expansion and reduction}
 820 %*                                                                      *
 821 %************************************************************************
 822
 823 We try for eta reduction here, but *only* if we get all the
 824 way to an exprIsTrivial expression.
 825 We don't want to remove extra lambdas unless we are going
 826 to avoid allocating this thing altogether
 827
 828 \begin{code}
 829 tryEtaReduce :: [OutBinder] -> OutExpr -> Maybe OutExpr
 830 tryEtaReduce bndrs body
 831         -- We don't use CoreUtils.etaReduce, because we can be more
 832         -- efficient here:
 833         --  (a) we already have the binders
 834         --  (b) we can do the triviality test before computing the free vars
 835   = go (reverse bndrs) body
 836   where
 837     go (b : bs) (App fun arg) | ok_arg b arg = go bs fun        -- Loop round
 838     go []       fun           | ok_fun fun   = Just fun         -- Success!
 839     go _        _                            = Nothing          -- Failure!
 840
 841     ok_fun fun =  exprIsTrivial fun
 842                && not (any (`elemVarSet` (exprFreeVars fun)) bndrs)
 843                && (exprIsHNF fun || all ok_lam bndrs)
 844     ok_lam v = isTyVar v || isDictId v
 845         -- The exprIsHNF is because eta reduction is not
 846         -- valid in general:  \x. bot  /=  bot
 847         -- So we need to be sure that the "fun" is a value.
 848         --
 849         -- However, we always want to reduce (/\a -> f a) to f
 850         -- This came up in a RULE: foldr (build (/\a -> g a))
 851         --      did not match      foldr (build (/\b -> ...something complex...))
 852         -- The type checker can insert these eta-expanded versions,
 853         -- with both type and dictionary lambdas; hence the slightly
 854         -- ad-hoc isDictTy
 855
 856     ok_arg b arg = varToCoreExpr b `cheapEqExpr` arg
 857 \end{code}
 858
 859
 860         Try eta expansion for RHSs
 861
 862 We go for:
 863    f = \x1..xn -> N  ==>   f = \x1..xn y1..ym -> N y1..ym
 864                                  (n >= 0)
 865
 866 where (in both cases)
 867
 868         * The xi can include type variables
 869
 870         * The yi are all value variables
 871
 872         * N is a NORMAL FORM (i.e. no redexes anywhere)
 873           wanting a suitable number of extra args.
 874
 875 We may have to sandwich some coerces between the lambdas
 876 to make the types work.   exprEtaExpandArity looks through coerces
 877 when computing arity; and etaExpand adds the coerces as necessary when
 878 actually computing the expansion.
 879
 880 \begin{code}
 881 tryEtaExpansion :: OutExpr -> SimplM OutExpr
 882 -- There is at least one runtime binder in the binders
 883 tryEtaExpansion body
 884   = getUniquesSmpl                      `thenSmpl` \ us ->
 885     returnSmpl (etaExpand fun_arity us body (exprType body))
 886   where
 887     fun_arity = exprEtaExpandArity body
 888 \end{code}
 889
 890
 891 %************************************************************************
 892 %*                                                                      *
 893 \subsection{Floating lets out of big lambdas}
 894 %*                                                                      *
 895 %************************************************************************
 896
 897 tryRhsTyLam tries this transformation, when the big lambda appears as
 898 the RHS of a let(rec) binding:
 899
 900         /\abc -> let(rec) x = e in b
 901    ==>
 902         let(rec) x' = /\abc -> let x = x' a b c in e
 903         in
 904         /\abc -> let x = x' a b c in b
 905
 906 This is good because it can turn things like:
 907
 908         let f = /\a -> letrec g = ... g ... in g
 909 into
 910         letrec g' = /\a -> ... g' a ...
 911         in
 912         let f = /\ a -> g' a
 913
 914 which is better.  In effect, it means that big lambdas don't impede
 915 let-floating.
 916
 917 This optimisation is CRUCIAL in eliminating the junk introduced by
 918 desugaring mutually recursive definitions.  Don't eliminate it lightly!
 919
 920 So far as the implementation is concerned:
 921
 922         Invariant: go F e = /\tvs -> F e
 923
 924         Equalities:
 925                 go F (Let x=e in b)
 926                 = Let x' = /\tvs -> F e
 927                   in
 928                   go G b
 929                 where
 930                     G = F . Let x = x' tvs
 931
 932                 go F (Letrec xi=ei in b)
 933                 = Letrec {xi' = /\tvs -> G ei}
 934                   in
 935                   go G b
 936                 where
 937                   G = F . Let {xi = xi' tvs}
 938
 939 [May 1999]  If we do this transformation *regardless* then we can
 940 end up with some pretty silly stuff.  For example,
 941
 942         let
 943             st = /\ s -> let { x1=r1 ; x2=r2 } in ...
 944         in ..
 945 becomes
 946         let y1 = /\s -> r1
 947             y2 = /\s -> r2
 948             st = /\s -> ...[y1 s/x1, y2 s/x2]
 949         in ..
 950
 951 Unless the "..." is a WHNF there is really no point in doing this.
 952 Indeed it can make things worse.  Suppose x1 is used strictly,
 953 and is of the form
 954
 955         x1* = case f y of { (a,b) -> e }
 956
 957 If we abstract this wrt the tyvar we then can't do the case inline
 958 as we would normally do.
 959
 960
 961 \begin{code}
 962 {-      Trying to do this in full laziness
 963
 964 tryRhsTyLam :: SimplEnv -> [OutTyVar] -> OutExpr -> SimplM FloatsWithExpr
 965 -- Call ensures that all the binders are type variables
 966
 967 tryRhsTyLam env tyvars body             -- Only does something if there's a let
 968   |  not (all isTyVar tyvars)
 969   || not (worth_it body)                -- inside a type lambda,
 970   = returnSmpl (emptyFloats env, body)  -- and a WHNF inside that
 971
 972   | otherwise
 973   = go env (\x -> x) body
 974
 975   where
 976     worth_it e@(Let _ _) = whnf_in_middle e
 977     worth_it e           = False
 978
 979     whnf_in_middle (Let (NonRec x rhs) e) | isUnLiftedType (idType x) = False
 980     whnf_in_middle (Let _ e) = whnf_in_middle e
 981     whnf_in_middle e         = exprIsCheap e
 982
 983     main_tyvar_set = mkVarSet tyvars
 984
 985     go env fn (Let bind@(NonRec var rhs) body)
 986       | exprIsTrivial rhs
 987       = go env (fn . Let bind) body
 988
 989     go env fn (Let (NonRec var rhs) body)
 990       = mk_poly tyvars_here var                                                 `thenSmpl` \ (var', rhs') ->
 991         addAuxiliaryBind env (NonRec var' (mkLams tyvars_here (fn rhs)))        $ \ env ->
 992         go env (fn . Let (mk_silly_bind var rhs')) body
 993
 994       where
 995
 996         tyvars_here = varSetElems (main_tyvar_set `intersectVarSet` exprSomeFreeVars isTyVar rhs)
 997                 -- Abstract only over the type variables free in the rhs
 998                 -- wrt which the new binding is abstracted.  But the naive
 999                 -- approach of abstract wrt the tyvars free in the Id's type
1000                 -- fails. Consider:
1001                 --      /\ a b -> let t :: (a,b) = (e1, e2)
1002                 --                    x :: a     = fst t
1003                 --                in ...
1004                 -- Here, b isn't free in x's type, but we must nevertheless
1005                 -- abstract wrt b as well, because t's type mentions b.
1006                 -- Since t is floated too, we'd end up with the bogus:
1007                 --      poly_t = /\ a b -> (e1, e2)
1008                 --      poly_x = /\ a   -> fst (poly_t a *b*)
1009                 -- So for now we adopt the even more naive approach of
1010                 -- abstracting wrt *all* the tyvars.  We'll see if that
1011                 -- gives rise to problems.   SLPJ June 98
1012
1013     go env fn (Let (Rec prs) body)
1014        = mapAndUnzipSmpl (mk_poly tyvars_here) vars     `thenSmpl` \ (vars', rhss') ->
1015          let
1016             gn body = fn (foldr Let body (zipWith mk_silly_bind vars rhss'))
1017             pairs   = vars' `zip` [mkLams tyvars_here (gn rhs) | rhs <- rhss]
1018          in
1019          addAuxiliaryBind env (Rec pairs)               $ \ env ->
1020          go env gn body
1021        where
1022          (vars,rhss) = unzip prs
1023          tyvars_here = varSetElems (main_tyvar_set `intersectVarSet` exprsSomeFreeVars isTyVar (map snd prs))
1024                 -- See notes with tyvars_here above
1025
1026     go env fn body = returnSmpl (emptyFloats env, fn body)
1027
1028     mk_poly tyvars_here var
1029       = getUniqueSmpl           `thenSmpl` \ uniq ->
1030         let
1031             poly_name = setNameUnique (idName var) uniq         -- Keep same name
1032             poly_ty   = mkForAllTys tyvars_here (idType var)    -- But new type of course
1033             poly_id   = mkLocalId poly_name poly_ty
1034
1035                 -- In the olden days, it was crucial to copy the occInfo of the original var,
1036                 -- because we were looking at occurrence-analysed but as yet unsimplified code!
1037                 -- In particular, we mustn't lose the loop breakers.  BUT NOW we are looking
1038                 -- at already simplified code, so it doesn't matter
1039                 --
1040                 -- It's even right to retain single-occurrence or dead-var info:
1041                 -- Suppose we started with  /\a -> let x = E in B
1042                 -- where x occurs once in B. Then we transform to:
1043                 --      let x' = /\a -> E in /\a -> let x* = x' a in B
1044                 -- where x* has an INLINE prag on it.  Now, once x* is inlined,
1045                 -- the occurrences of x' will be just the occurrences originally
1046                 -- pinned on x.
1047         in
1048         returnSmpl (poly_id, mkTyApps (Var poly_id) (mkTyVarTys tyvars_here))
1049
1050     mk_silly_bind var rhs = NonRec var (Note InlineMe rhs)
1051                 -- Suppose we start with:
1052                 --
1053                 --      x = /\ a -> let g = G in E
1054                 --
1055                 -- Then we'll float to get
1056                 --
1057                 --      x = let poly_g = /\ a -> G
1058                 --          in /\ a -> let g = poly_g a in E
1059                 --
1060                 -- But now the occurrence analyser will see just one occurrence
1061                 -- of poly_g, not inside a lambda, so the simplifier will
1062                 -- PreInlineUnconditionally poly_g back into g!  Badk to square 1!
1063                 -- (I used to think that the "don't inline lone occurrences" stuff
1064                 --  would stop this happening, but since it's the *only* occurrence,
1065                 --  PreInlineUnconditionally kicks in first!)
1066                 --
1067                 -- Solution: put an INLINE note on g's RHS, so that poly_g seems
1068                 --           to appear many times.  (NB: mkInlineMe eliminates
1069                 --           such notes on trivial RHSs, so do it manually.)
1070 -}
1071 \end{code}
1072
1073 %************************************************************************
1074 %*                                                                      *
1075 \subsection{Case alternative filtering
1076 %*                                                                      *
1077 %************************************************************************
1078
1079 prepareAlts does two things:
1080
1081 1.  Eliminate alternatives that cannot match, including the
1082     DEFAULT alternative.
1083
1084 2.  If the DEFAULT alternative can match only one possible constructor,
1085     then make that constructor explicit.
1086     e.g.
1087         case e of x { DEFAULT -> rhs }
1088      ===>
1089         case e of x { (a,b) -> rhs }
1090     where the type is a single constructor type.  This gives better code
1091     when rhs also scrutinises x or e.
1092
1093 It's a good idea do do this stuff before simplifying the alternatives, to
1094 avoid simplifying alternatives we know can't happen, and to come up with
1095 the list of constructors that are handled, to put into the IdInfo of the
1096 case binder, for use when simplifying the alternatives.
1097
1098 Eliminating the default alternative in (1) isn't so obvious, but it can
1099 happen:
1100
1101 data Colour = Red | Green | Blue
1102
1103 f x = case x of
1104         Red -> ..
1105         Green -> ..
1106         DEFAULT -> h x
1107
1108 h y = case y of
1109         Blue -> ..
1110         DEFAULT -> [ case y of ... ]
1111
1112 If we inline h into f, the default case of the inlined h can't happen.
1113 If we don't notice this, we may end up filtering out *all* the cases
1114 of the inner case y, which give us nowhere to go!
1115
1116
1117 \begin{code}
1118 prepareAlts :: OutExpr          -- Scrutinee
1119             -> InId             -- Case binder
1120             -> [InAlt]          -- Increasing order
1121             -> SimplM ([InAlt],         -- Better alternatives, still incresaing order
1122                         [AltCon])       -- These cases are handled
1123
1124 prepareAlts scrut case_bndr alts
1125   = let
1126         (alts_wo_default, maybe_deflt) = findDefault alts
1127
1128         impossible_cons = case scrut of
1129                             Var v -> otherCons (idUnfolding v)
1130                             other -> []
1131
1132         -- Filter out alternatives that can't possibly match
1133         better_alts | null impossible_cons = alts_wo_default
1134                     | otherwise            = [alt | alt@(con,_,_) <- alts_wo_default,
1135                                                     not (con `elem` impossible_cons)]
1136
1137         -- "handled_cons" are handled either by the context,
1138         -- or by a branch in this case expression
1139         -- (Don't add DEFAULT to the handled_cons!!)
1140         handled_cons = impossible_cons ++ [con | (con,_,_) <- better_alts]
1141     in
1142         -- Filter out the default, if it can't happen,
1143         -- or replace it with "proper" alternative if there
1144         -- is only one constructor left
1145     prepareDefault case_bndr handled_cons maybe_deflt   `thenSmpl` \ deflt_alt ->
1146
1147     returnSmpl (mergeAlts better_alts deflt_alt, handled_cons)
1148         -- We need the mergeAlts in case the new default_alt
1149         -- has turned into a constructor alternative.
1150
1151 prepareDefault case_bndr handled_cons (Just rhs)
1152   | Just (tycon, inst_tys) <- splitTyConApp_maybe (idType case_bndr),
1153     isAlgTyCon tycon,           -- It's a data type, tuple, or unboxed tuples.
1154     not (isNewTyCon tycon),     -- We can have a newtype, if we are just doing an eval:
1155                                 --      case x of { DEFAULT -> e }
1156                                 -- and we don't want to fill in a default for them!
1157     Just all_cons <- tyConDataCons_maybe tycon,
1158     not (null all_cons),        -- This is a tricky corner case.  If the data type has no constructors,
1159                                 -- which GHC allows, then the case expression will have at most a default
1160                                 -- alternative.  We don't want to eliminate that alternative, because the
1161                                 -- invariant is that there's always one alternative.  It's more convenient
1162                                 -- to leave
1163                                 --      case x of { DEFAULT -> e }
1164                                 -- as it is, rather than transform it to
1165                                 --      error "case cant match"
1166                                 -- which would be quite legitmate.  But it's a really obscure corner, and
1167                                 -- not worth wasting code on.
1168     let handled_data_cons = [data_con | DataAlt data_con <- handled_cons],
1169     let missing_cons      = [con | con <- all_cons,
1170                                    not (con `elem` handled_data_cons)]
1171   = case missing_cons of
1172         []          -> returnSmpl []    -- Eliminate the default alternative
1173                                         -- if it can't match
1174
1175         [con]       ->  -- It matches exactly one constructor, so fill it in
1176                        tick (FillInCaseDefault case_bndr)       `thenSmpl_`
1177                        mk_args con inst_tys                     `thenSmpl` \ args ->
1178                        returnSmpl [(DataAlt con, args, rhs)]
1179
1180         two_or_more -> returnSmpl [(DEFAULT, [], rhs)]
1181
1182   | otherwise
1183   = returnSmpl [(DEFAULT, [], rhs)]
1184
1185 prepareDefault case_bndr handled_cons Nothing
1186   = returnSmpl []
1187
1188 mk_args missing_con inst_tys
1189   = mk_tv_bndrs missing_con inst_tys    `thenSmpl` \ (tv_bndrs, inst_tys') ->
1190     getUniquesSmpl                      `thenSmpl` \ id_uniqs ->
1191     let arg_tys = dataConArgTys missing_con inst_tys'
1192         arg_ids = zipWith (mkSysLocal FSLIT("a")) id_uniqs arg_tys
1193     in
1194     returnSmpl (tv_bndrs ++ arg_ids)
1195
1196 mk_tv_bndrs missing_con inst_tys
1197   | isVanillaDataCon missing_con
1198   = returnSmpl ([], inst_tys)
1199   | otherwise
1200   = getUniquesSmpl              `thenSmpl` \ tv_uniqs ->
1201     let new_tvs    = zipWith mk tv_uniqs (dataConTyVars missing_con)
1202         mk uniq tv = mkTyVar (mkSysTvName uniq FSLIT("t")) (tyVarKind tv)
1203     in
1204     returnSmpl (new_tvs, mkTyVarTys new_tvs)
1205 \end{code}
1206
1207
1208 %************************************************************************
1209 %*                                                                      *
1210 \subsection{Case absorption and identity-case elimination}
1211 %*                                                                      *
1212 %************************************************************************
1213
1214 mkCase puts a case expression back together, trying various transformations first.
1215
1216 \begin{code}
1217 mkCase :: OutExpr -> OutId -> OutType
1218        -> [OutAlt]              -- Increasing order
1219        -> SimplM OutExpr
1220
1221 mkCase scrut case_bndr ty alts
1222   = getDOptsSmpl                        `thenSmpl` \dflags ->
1223     mkAlts dflags scrut case_bndr alts  `thenSmpl` \ better_alts ->
1224     mkCase1 scrut case_bndr ty better_alts
1225 \end{code}
1226
1227
1228 mkAlts tries these things:
1229
1230 1.  If several alternatives are identical, merge them into
1231     a single DEFAULT alternative.  I've occasionally seen this
1232     making a big difference:
1233
1234         case e of               =====>     case e of
1235           C _ -> f x                         D v -> ....v....
1236           D v -> ....v....                   DEFAULT -> f x
1237           DEFAULT -> f x
1238
1239    The point is that we merge common RHSs, at least for the DEFAULT case.
1240    [One could do something more elaborate but I've never seen it needed.]
1241    To avoid an expensive test, we just merge branches equal to the *first*
1242    alternative; this picks up the common cases
1243         a) all branches equal
1244         b) some branches equal to the DEFAULT (which occurs first)
1245
1246 2.  Case merging:
1247        case e of b {             ==>   case e of b {
1248          p1 -> rhs1                      p1 -> rhs1
1249          ...                             ...
1250          pm -> rhsm                      pm -> rhsm
1251          _  -> case b of b' {            pn -> let b'=b in rhsn
1252                      pn -> rhsn          ...
1253                      ...                 po -> let b'=b in rhso
1254                      po -> rhso          _  -> let b'=b in rhsd
1255                      _  -> rhsd
1256        }
1257
1258     which merges two cases in one case when -- the default alternative of
1259     the outer case scrutises the same variable as the outer case This
1260     transformation is called Case Merging.  It avoids that the same
1261     variable is scrutinised multiple times.
1262
1263
1264 The case where transformation (1) showed up was like this (lib/std/PrelCError.lhs):
1265
1266         x | p `is` 1 -> e1
1267           | p `is` 2 -> e2
1268         ...etc...
1269
1270 where @is@ was something like
1271
1272         p `is` n = p /= (-1) && p == n
1273
1274 This gave rise to a horrible sequence of cases
1275
1276         case p of
1277           (-1) -> $j p
1278           1    -> e1
1279           DEFAULT -> $j p
1280
1281 and similarly in cascade for all the join points!
1282
1283
1284
1285 \begin{code}
1286 --------------------------------------------------
1287 --      1. Merge identical branches
1288 --------------------------------------------------
1289 mkAlts dflags scrut case_bndr alts@((con1,bndrs1,rhs1) : con_alts)
1290   | all isDeadBinder bndrs1,                    -- Remember the default
1291     length filtered_alts < length con_alts      -- alternative comes first
1292   = tick (AltMerge case_bndr)                   `thenSmpl_`
1293     returnSmpl better_alts
1294   where
1295     filtered_alts        = filter keep con_alts
1296     keep (con,bndrs,rhs) = not (all isDeadBinder bndrs && rhs `cheapEqExpr` rhs1)
1297     better_alts          = (DEFAULT, [], rhs1) : filtered_alts
1298
1299
1300 --------------------------------------------------
1301 --      2.  Merge nested cases
1302 --------------------------------------------------
1303
1304 mkAlts dflags scrut outer_bndr outer_alts
1305   | dopt Opt_CaseMerge dflags,
1306     (outer_alts_without_deflt, maybe_outer_deflt)   <- findDefault outer_alts,
1307     Just (Case (Var scrut_var) inner_bndr _ inner_alts) <- maybe_outer_deflt,
1308     scruting_same_var scrut_var
1309   = let
1310         munged_inner_alts = [(con, args, munge_rhs rhs) | (con, args, rhs) <- inner_alts]
1311         munge_rhs rhs = bindCaseBndr inner_bndr (Var outer_bndr) rhs
1312
1313         new_alts = mergeAlts outer_alts_without_deflt munged_inner_alts
1314                 -- The merge keeps the inner DEFAULT at the front, if there is one
1315                 -- and eliminates any inner_alts that are shadowed by the outer_alts
1316     in
1317     tick (CaseMerge outer_bndr)                         `thenSmpl_`
1318     returnSmpl new_alts
1319         -- Warning: don't call mkAlts recursively!
1320         -- Firstly, there's no point, because inner alts have already had
1321         -- mkCase applied to them, so they won't have a case in their default
1322         -- Secondly, if you do, you get an infinite loop, because the bindCaseBndr
1323         -- in munge_rhs may put a case into the DEFAULT branch!
1324   where
1325         -- We are scrutinising the same variable if it's
1326         -- the outer case-binder, or if the outer case scrutinises a variable
1327         -- (and it's the same).  Testing both allows us not to replace the
1328         -- outer scrut-var with the outer case-binder (Simplify.simplCaseBinder).
1329     scruting_same_var = case scrut of
1330                           Var outer_scrut -> \ v -> v == outer_bndr || v == outer_scrut
1331                           other           -> \ v -> v == outer_bndr
1332
1333 ------------------------------------------------
1334 --      Catch-all
1335 ------------------------------------------------
1336
1337 mkAlts dflags scrut case_bndr other_alts = returnSmpl other_alts
1338
1339
1340 ---------------------------------
1341 mergeAlts :: [OutAlt] -> [OutAlt] -> [OutAlt]
1342 -- Merge preserving order; alternatives in the first arg
1343 -- shadow ones in the second
1344 mergeAlts [] as2 = as2
1345 mergeAlts as1 [] = as1
1346 mergeAlts (a1:as1) (a2:as2)
1347   = case a1 `cmpAlt` a2 of
1348         LT -> a1 : mergeAlts as1      (a2:as2)
1349         EQ -> a1 : mergeAlts as1      as2       -- Discard a2
1350         GT -> a2 : mergeAlts (a1:as1) as2
1351 \end{code}
1352
1353
1354
1355 =================================================================================
1356
1357 mkCase1 tries these things
1358
1359 1.  Eliminate the case altogether if possible
1360
1361 2.  Case-identity:
1362
1363         case e of               ===> e
1364                 True  -> True;
1365                 False -> False
1366
1367     and similar friends.
1368
1369
1370 Start with a simple situation:
1371
1372         case x# of      ===>   e[x#/y#]
1373           y# -> e
1374
1375 (when x#, y# are of primitive type, of course).  We can't (in general)
1376 do this for algebraic cases, because we might turn bottom into
1377 non-bottom!
1378
1379 Actually, we generalise this idea to look for a case where we're
1380 scrutinising a variable, and we know that only the default case can
1381 match.  For example:
1382 \begin{verbatim}
1383         case x of
1384           0#    -> ...
1385           other -> ...(case x of
1386                          0#    -> ...
1387                          other -> ...) ...
1388 \end{code}
1389 Here the inner case can be eliminated.  This really only shows up in
1390 eliminating error-checking code.
1391
1392 We also make sure that we deal with this very common case:
1393
1394         case e of
1395           x -> ...x...
1396
1397 Here we are using the case as a strict let; if x is used only once
1398 then we want to inline it.  We have to be careful that this doesn't
1399 make the program terminate when it would have diverged before, so we
1400 check that
1401         - x is used strictly, or
1402         - e is already evaluated (it may so if e is a variable)
1403
1404 Lastly, we generalise the transformation to handle this:
1405
1406         case e of       ===> r
1407            True  -> r
1408            False -> r
1409
1410 We only do this for very cheaply compared r's (constructors, literals
1411 and variables).  If pedantic bottoms is on, we only do it when the
1412 scrutinee is a PrimOp which can't fail.
1413
1414 We do it *here*, looking at un-simplified alternatives, because we
1415 have to check that r doesn't mention the variables bound by the
1416 pattern in each alternative, so the binder-info is rather useful.
1417
1418 So the case-elimination algorithm is:
1419
1420         1. Eliminate alternatives which can't match
1421
1422         2. Check whether all the remaining alternatives
1423                 (a) do not mention in their rhs any of the variables bound in their pattern
1424            and  (b) have equal rhss
1425
1426         3. Check we can safely ditch the case:
1427                    * PedanticBottoms is off,
1428                 or * the scrutinee is an already-evaluated variable
1429                 or * the scrutinee is a primop which is ok for speculation
1430                         -- ie we want to preserve divide-by-zero errors, and
1431                         -- calls to error itself!
1432
1433                 or * [Prim cases] the scrutinee is a primitive variable
1434
1435                 or * [Alg cases] the scrutinee is a variable and
1436                      either * the rhs is the same variable
1437                         (eg case x of C a b -> x  ===>   x)
1438                      or     * there is only one alternative, the default alternative,
1439                                 and the binder is used strictly in its scope.
1440                                 [NB this is helped by the "use default binder where
1441                                  possible" transformation; see below.]
1442
1443
1444 If so, then we can replace the case with one of the rhss.
1445
1446 Further notes about case elimination
1447 ~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~
1448 Consider:       test :: Integer -> IO ()
1449                 test = print
1450
1451 Turns out that this compiles to:
1452     Print.test
1453       = \ eta :: Integer
1454           eta1 :: State# RealWorld ->
1455           case PrelNum.< eta PrelNum.zeroInteger of wild { __DEFAULT ->
1456           case hPutStr stdout
1457                  (PrelNum.jtos eta ($w[] @ Char))
1458                  eta1
1459           of wild1 { (# new_s, a4 #) -> PrelIO.lvl23 new_s  }}
1460
1461 Notice the strange '<' which has no effect at all. This is a funny one.
1462 It started like this:
1463
1464 f x y = if x < 0 then jtos x
1465           else if y==0 then "" else jtos x
1466
1467 At a particular call site we have (f v 1).  So we inline to get
1468
1469         if v < 0 then jtos x
1470         else if 1==0 then "" else jtos x
1471
1472 Now simplify the 1==0 conditional:
1473
1474         if v<0 then jtos v else jtos v
1475
1476 Now common-up the two branches of the case:
1477
1478         case (v<0) of DEFAULT -> jtos v
1479
1480 Why don't we drop the case?  Because it's strict in v.  It's technically
1481 wrong to drop even unnecessary evaluations, and in practice they
1482 may be a result of 'seq' so we *definitely* don't want to drop those.
1483 I don't really know how to improve this situation.
1484
1485
1486 \begin{code}
1487 --------------------------------------------------
1488 --      0. Check for empty alternatives
1489 --------------------------------------------------
1490
1491 #ifdef DEBUG
1492 mkCase1 scrut case_bndr ty []
1493   = pprTrace "mkCase1: null alts" (ppr case_bndr <+> ppr scrut) $
1494     returnSmpl scrut
1495 #endif
1496
1497 --------------------------------------------------
1498 --      1. Eliminate the case altogether if poss
1499 --------------------------------------------------
1500
1501 mkCase1 scrut case_bndr ty [(con,bndrs,rhs)]
1502   -- See if we can get rid of the case altogether
1503   -- See the extensive notes on case-elimination above
1504   -- mkCase made sure that if all the alternatives are equal,
1505   -- then there is now only one (DEFAULT) rhs
1506  |  all isDeadBinder bndrs,
1507
1508         -- Check that the scrutinee can be let-bound instead of case-bound
1509     exprOkForSpeculation scrut
1510                 -- OK not to evaluate it
1511                 -- This includes things like (==# a# b#)::Bool
1512                 -- so that we simplify
1513                 --      case ==# a# b# of { True -> x; False -> x }
1514                 -- to just
1515                 --      x
1516                 -- This particular example shows up in default methods for
1517                 -- comparision operations (e.g. in (>=) for Int.Int32)
1518         || exprIsHNF scrut                      -- It's already evaluated
1519         || var_demanded_later scrut             -- It'll be demanded later
1520
1521 --      || not opt_SimplPedanticBottoms)        -- Or we don't care!
1522 --      We used to allow improving termination by discarding cases, unless -fpedantic-bottoms was on,
1523 --      but that breaks badly for the dataToTag# primop, which relies on a case to evaluate
1524 --      its argument:  case x of { y -> dataToTag# y }
1525 --      Here we must *not* discard the case, because dataToTag# just fetches the tag from
1526 --      the info pointer.  So we'll be pedantic all the time, and see if that gives any
1527 --      other problems
1528 --      Also we don't want to discard 'seq's
1529   = tick (CaseElim case_bndr)                   `thenSmpl_`
1530     returnSmpl (bindCaseBndr case_bndr scrut rhs)
1531
1532   where
1533         -- The case binder is going to be evaluated later,
1534         -- and the scrutinee is a simple variable
1535     var_demanded_later (Var v) = isStrictDmd (idNewDemandInfo case_bndr)
1536     var_demanded_later other   = False
1537
1538
1539 --------------------------------------------------
1540 --      2. Identity case
1541 --------------------------------------------------
1542
1543 mkCase1 scrut case_bndr ty alts -- Identity case
1544   | all identity_alt alts
1545   = tick (CaseIdentity case_bndr)               `thenSmpl_`
1546     returnSmpl (re_note scrut)
1547   where
1548     identity_alt (con, args, rhs) = de_note rhs `cheapEqExpr` identity_rhs con args
1549
1550     identity_rhs (DataAlt con) args = mkConApp con (arg_tys ++ map varToCoreExpr args)
1551     identity_rhs (LitAlt lit)  _    = Lit lit
1552     identity_rhs DEFAULT       _    = Var case_bndr
1553
1554     arg_tys = map Type (tyConAppArgs (idType case_bndr))
1555
1556         -- We've seen this:
1557         --      case coerce T e of x { _ -> coerce T' x }
1558         -- And we definitely want to eliminate this case!
1559         -- So we throw away notes from the RHS, and reconstruct
1560         -- (at least an approximation) at the other end
1561     de_note (Note _ e) = de_note e
1562     de_note e          = e
1563
1564         -- re_note wraps a coerce if it might be necessary
1565     re_note scrut = case head alts of
1566                         (_,_,rhs1@(Note _ _)) -> mkCoerce2 (exprType rhs1) (idType case_bndr) scrut
1567                         other                 -> scrut
1568
1569
1570 --------------------------------------------------
1571 --      Catch-all
1572 --------------------------------------------------
1573 mkCase1 scrut bndr ty alts = returnSmpl (Case scrut bndr ty alts)
1574 \end{code}
1575
1576
1577 When adding auxiliary bindings for the case binder, it's worth checking if
1578 its dead, because it often is, and occasionally these mkCase transformations
1579 cascade rather nicely.
1580
1581 \begin{code}
1582 bindCaseBndr bndr rhs body
1583   | isDeadBinder bndr = body
1584   | otherwise         = bindNonRec bndr rhs body
1585 \end{code}