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