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