ghc/compiler/simplCore/Simplify.lhs

   1 %
   2 % (c) The AQUA Project, Glasgow University, 1993-1996
   3 %
   4 \section[Simplify]{The main module of the simplifier}
   5
   6 \begin{code}
   7 #include "HsVersions.h"
   8
   9 module Simplify ( simplTopBinds, simplExpr, simplBind ) where
  10
  11 IMPORT_1_3(List(partition))
  12
  13 IMP_Ubiq(){-uitous-}
  14 #if defined(__GLASGOW_HASKELL__) && __GLASGOW_HASKELL__ <= 201
  15 IMPORT_DELOOPER(SmplLoop)               -- paranoia checking
  16 #endif
  17
  18 import BinderInfo
  19 import CmdLineOpts      ( SimplifierSwitch(..) )
  20 import ConFold          ( completePrim )
  21 import CoreUnfold       ( Unfolding, SimpleUnfolding, mkFormSummary,
  22                           exprIsTrivial, whnfOrBottom, inlineUnconditionally,
  23                           FormSummary(..)
  24                         )
  25 import CostCentre       ( isSccCountCostCentre, cmpCostCentre, costsAreSubsumed, useCurrentCostCentre )
  26 import CoreSyn
  27 import CoreUtils        ( coreExprType, nonErrorRHSs, maybeErrorApp,
  28                           unTagBinders, squashableDictishCcExpr
  29                         )
  30 import Id               ( idType, idMustBeINLINEd, idWantsToBeINLINEd, idMustNotBeINLINEd,
  31                           addIdArity, getIdArity,
  32                           getIdDemandInfo, addIdDemandInfo,
  33                           GenId{-instance NamedThing-}
  34                         )
  35 import Name             ( isExported )
  36 import IdInfo           ( willBeDemanded, noDemandInfo, DemandInfo, ArityInfo(..),
  37                           atLeastArity, unknownArity )
  38 import Literal          ( isNoRepLit )
  39 import Maybes           ( maybeToBool )
  40 import PprType          ( GenType{-instance Outputable-}, GenTyVar{- instance Outputable -} )
  41 #if __GLASGOW_HASKELL__ <= 30
  42 import PprCore          ( GenCoreArg, GenCoreExpr )
  43 #endif
  44 import TyVar            ( GenTyVar {- instance Eq -} )
  45 import Pretty           --( ($$) )
  46 import PrimOp           ( primOpOkForSpeculation, PrimOp(..) )
  47 import SimplCase        ( simplCase, bindLargeRhs )
  48 import SimplEnv
  49 import SimplMonad
  50 import SimplVar         ( completeVar )
  51 import Unique           ( Unique )
  52 import SimplUtils
  53 import Type             ( mkTyVarTy, mkTyVarTys, mkAppTy, applyTy, mkFunTys, maybeAppDataTyCon,
  54                           splitFunTy, splitFunTyExpandingDicts, getFunTy_maybe, eqTy
  55                         )
  56 import TysWiredIn       ( realWorldStateTy )
  57 import Outputable       ( PprStyle(..), Outputable(..) )
  58 import Util             ( SYN_IE(Eager), appEager, returnEager, runEager, mapEager,
  59                           isSingleton, zipEqual, zipWithEqual, mapAndUnzip, panic, pprPanic, assertPanic, pprTrace )
  60 \end{code}
  61
  62 The controlling flags, and what they do
  63 ~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~
  64
  65 passes:
  66 ------
  67 -fsimplify              = run the simplifier
  68 -ffloat-inwards         = runs the float lets inwards pass
  69 -ffloat                 = runs the full laziness pass
  70                           (ToDo: rename to -ffull-laziness)
  71 -fupdate-analysis       = runs update analyser
  72 -fstrictness            = runs strictness analyser
  73 -fsaturate-apps         = saturates applications (eta expansion)
  74
  75 options:
  76 -------
  77 -ffloat-past-lambda     = OK to do full laziness.
  78                           (ToDo: remove, as the full laziness pass is
  79                                  useless without this flag, therefore
  80                                  it is unnecessary. Just -ffull-laziness
  81                                  should be kept.)
  82
  83 -ffloat-lets-ok         = OK to float lets out of lets if the enclosing
  84                           let is strict or if the floating will expose
  85                           a WHNF [simplifier].
  86
  87 -ffloat-primops-ok      = OK to float out of lets cases whose scrutinee
  88                           is a primop that cannot fail [simplifier].
  89
  90 -fcode-duplication-ok   = allows the previous option to work on cases with
  91                           multiple branches [simplifier].
  92
  93 -flet-to-case           = does let-to-case transformation [simplifier].
  94
  95 -fcase-of-case          = does case of case transformation [simplifier].
  96
  97 -fpedantic-bottoms      = does not allow:
  98                              case x of y -> e  ===>  e[x/y]
  99                           (which may turn bottom into non-bottom)
 100
 101
 102                         NOTES ON INLINING
 103                         ~~~~~~~~~~~~~~~~~
 104
 105 Inlining is one of the delicate aspects of the simplifier.  By
 106 ``inlining'' we mean replacing an occurrence of a variable ``x'' by
 107 the RHS of x's definition.  Thus
 108
 109         let x = e in ...x...    ===>   let x = e in ...e...
 110
 111 We have two mechanisms for inlining:
 112
 113 1.  Unconditional.  The occurrence analyser has pinned an (OneOcc
 114 FunOcc NoDupDanger NotInsideSCC n) flag on the variable, saying ``it's
 115 certainly safe to inline this variable, and to drop its binding''.
 116 (...Umm... if n <= 1; if n > 1, it is still safe, provided you are
 117 happy to be duplicating code...) When it encounters such a beast, the
 118 simplifer binds the variable to its RHS (in the id_env) and continues.
 119 It doesn't even look at the RHS at that stage.  It also drops the
 120 binding altogether.
 121
 122 2.  Conditional.  In all other situations, the simplifer simplifies
 123 the RHS anyway, and keeps the new binding.  It also binds the new
 124 (cloned) variable to a ``suitable'' Unfolding in the UnfoldEnv.
 125
 126 Here, ``suitable'' might mean NoUnfolding (if the occurrence
 127 info is ManyOcc and the RHS is not a manifest HNF, or UnfoldAlways (if
 128 the variable has an INLINE pragma on it).  The idea is that anything
 129 in the UnfoldEnv is safe to use, but also has an enclosing binding if
 130 you decide not to use it.
 131
 132 Head normal forms
 133 ~~~~~~~~~~~~~~~~~
 134 We *never* put a non-HNF unfolding in the UnfoldEnv except in the
 135 INLINE-pragma case.
 136
 137 At one time I thought it would be OK to put non-HNF unfoldings in for
 138 variables which occur only once [if they got inlined at that
 139 occurrence the RHS of the binding would become dead, so no duplication
 140 would occur].   But consider:
 141 @
 142         let x = <expensive>
 143             f = \y -> ...y...y...y...
 144         in f x
 145 @
 146 Now, it seems that @x@ appears only once, but even so it is NOT safe
 147 to put @x@ in the UnfoldEnv, because @f@ will be inlined, and will
 148 duplicate the references to @x@.
 149
 150 Because of this, the "unconditional-inline" mechanism above is the
 151 only way in which non-HNFs can get inlined.
 152
 153 INLINE pragmas
 154 ~~~~~~~~~~~~~~
 155
 156 When a variable has an INLINE pragma on it --- which includes wrappers
 157 produced by the strictness analyser --- we treat it rather carefully.
 158
 159 For a start, we are careful not to substitute into its RHS, because
 160 that might make it BIG, and the user said "inline exactly this", not
 161 "inline whatever you get after inlining other stuff inside me".  For
 162 example
 163
 164         let f = BIG
 165         in {-# INLINE y #-} y = f 3
 166         in ...y...y...
 167
 168 Here we don't want to substitute BIG for the (single) occurrence of f,
 169 because then we'd duplicate BIG when we inline'd y.  (Exception:
 170 things in the UnfoldEnv with UnfoldAlways flags, which originated in
 171 other INLINE pragmas.)
 172
 173 So, we clean out the UnfoldEnv of all SimpleUnfolding inlinings before
 174 going into such an RHS.
 175
 176 What about imports?  They don't really matter much because we only
 177 inline relatively small things via imports.
 178
 179 We augment the the UnfoldEnv with UnfoldAlways guidance if there's an
 180 INLINE pragma.  We also do this for the RHSs of recursive decls,
 181 before looking at the recursive decls. That way we achieve the effect
 182 of inlining a wrapper in the body of its worker, in the case of a
 183 mutually-recursive worker/wrapper split.
 184
 185
 186 %************************************************************************
 187 %*                                                                      *
 188 \subsection[Simplify-simplExpr]{The main function: simplExpr}
 189 %*                                                                      *
 190 %************************************************************************
 191
 192 At the top level things are a little different.
 193
 194   * No cloning (not allowed for exported Ids, unnecessary for the others)
 195   * Floating is done a bit differently (no case floating; check for leaks; handle letrec)
 196
 197 \begin{code}
 198 simplTopBinds :: SimplEnv -> [InBinding] -> SmplM [OutBinding]
 199
 200 -- Dead code is now discarded by the occurrence analyser,
 201
 202 simplTopBinds env binds
 203   = mapSmpl (floatBind env True) binds  `thenSmpl` \ binds_s ->
 204     simpl_top_binds env (concat binds_s)
 205   where
 206     simpl_top_binds env [] = returnSmpl []
 207
 208     simpl_top_binds env (NonRec binder@(in_id,occ_info) rhs : binds)
 209       =         --- No cloning necessary at top level
 210         simplRhsExpr env binder rhs in_id                               `thenSmpl` \ (rhs',arity) ->
 211         completeNonRec env binder (in_id `withArity` arity) rhs'        `thenSmpl` \ (new_env, binds1') ->
 212         simpl_top_binds new_env binds                                   `thenSmpl` \ binds2' ->
 213         returnSmpl (binds1' ++ binds2')
 214
 215     simpl_top_binds env (Rec pairs : binds)
 216       =         -- No cloning necessary at top level, but we nevertheless
 217                 -- add the Ids to the environment.  This makes sure that
 218                 -- info carried on the Id (such as arity info) gets propagated
 219                 -- to occurrences.
 220                 --
 221                 -- This may seem optional, but I found an occasion when it Really matters.
 222                 -- Consider     foo{n} = ...foo...
 223                 --              baz* = foo
 224                 --
 225                 -- where baz* is exported and foo isn't.  Then when we do "indirection-shorting"
 226                 -- in tidyCore, we need the {no-inline} pragma from foo to attached to the final
 227                 -- thing:       baz*{n} = ...baz...
 228                 --
 229                 -- Sure we could have made the indirection-shorting a bit cleverer, but
 230                 -- propagating pragma info is a Good Idea anyway.
 231         let
 232             env1 = extendIdEnvWithClones env binders ids
 233         in
 234         simplRecursiveGroup env1 ids pairs      `thenSmpl` \ (bind', new_env) ->
 235         simpl_top_binds new_env binds           `thenSmpl` \ binds' ->
 236         returnSmpl (Rec bind' : binds')
 237       where
 238         binders = map fst pairs
 239         ids     = map fst binders
 240 \end{code}
 241
 242 %************************************************************************
 243 %*                                                                      *
 244 \subsection[Simplify-simplExpr]{The main function: simplExpr}
 245 %*                                                                      *
 246 %************************************************************************
 247
 248
 249 \begin{code}
 250 simplExpr :: SimplEnv
 251           -> InExpr -> [OutArg]
 252           -> OutType            -- Type of (e args); i.e. type of overall result
 253           -> SmplM OutExpr
 254 \end{code}
 255
 256 The expression returned has the same meaning as the input expression
 257 applied to the specified arguments.
 258
 259
 260 Variables
 261 ~~~~~~~~~
 262 Check if there's a macro-expansion, and if so rattle on.  Otherwise do
 263 the more sophisticated stuff.
 264
 265 \begin{code}
 266 simplExpr env (Var v) args result_ty
 267   = case (runEager $ lookupId env v) of
 268       LitArg lit                -- A boring old literal
 269         -> ASSERT( null args )
 270            returnSmpl (Lit lit)
 271
 272       VarArg var        -- More interesting!  An id!
 273         -> completeVar env var args result_ty
 274                                 -- Either Id is in the local envt, or it's a global.
 275                                 -- In either case we don't need to apply the type
 276                                 -- environment to it.
 277 \end{code}
 278
 279 Literals
 280 ~~~~~~~~
 281
 282 \begin{code}
 283 simplExpr env (Lit l) [] result_ty = returnSmpl (Lit l)
 284 #ifdef DEBUG
 285 simplExpr env (Lit l) _  _ = panic "simplExpr:Lit with argument"
 286 #endif
 287 \end{code}
 288
 289 Primitive applications are simple.
 290 ~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~
 291
 292 NB: Prim expects an empty argument list! (Because it should be
 293 saturated and not higher-order. ADR)
 294
 295 \begin{code}
 296 simplExpr env (Prim op prim_args) args result_ty
 297   = ASSERT (null args)
 298     mapEager (simplArg env) prim_args   `appEager` \ prim_args' ->
 299     simpl_op op                         `appEager` \ op' ->
 300     completePrim env op' prim_args'
 301   where
 302     -- PrimOps just need any types in them renamed.
 303
 304     simpl_op (CCallOp label is_asm may_gc arg_tys result_ty)
 305       = mapEager (simplTy env) arg_tys  `appEager` \ arg_tys' ->
 306         simplTy env result_ty           `appEager` \ result_ty' ->
 307         returnEager (CCallOp label is_asm may_gc arg_tys' result_ty')
 308
 309     simpl_op other_op = returnEager other_op
 310 \end{code}
 311
 312 Constructor applications
 313 ~~~~~~~~~~~~~~~~~~~~~~~~
 314 Nothing to try here.  We only reuse constructors when they appear as the
 315 rhs of a let binding (see completeLetBinding).
 316
 317 \begin{code}
 318 simplExpr env (Con con con_args) args result_ty
 319   = ASSERT( null args )
 320     mapEager (simplArg env) con_args    `appEager` \ con_args' ->
 321     returnSmpl (Con con con_args')
 322 \end{code}
 323
 324
 325 Applications are easy too:
 326 ~~~~~~~~~~~~~~~~~~~~~~~~~~
 327 Just stuff 'em in the arg stack
 328
 329 \begin{code}
 330 simplExpr env (App fun arg) args result_ty
 331   = simplArg env arg    `appEager` \ arg' ->
 332     simplExpr env fun (arg' : args) result_ty
 333 \end{code}
 334
 335 Type lambdas
 336 ~~~~~~~~~~~~
 337
 338 First the case when it's applied to an argument.
 339
 340 \begin{code}
 341 simplExpr env (Lam (TyBinder tyvar) body) (TyArg ty : args) result_ty
 342   = -- ASSERT(not (isPrimType ty))
 343     tick TyBetaReduction        `thenSmpl_`
 344     simplExpr (extendTyEnv env tyvar ty) body args result_ty
 345 \end{code}
 346
 347 \begin{code}
 348 simplExpr env tylam@(Lam (TyBinder tyvar) body) [] result_ty
 349   = cloneTyVarSmpl tyvar                `thenSmpl` \ tyvar' ->
 350     let
 351         new_ty  = mkTyVarTy tyvar'
 352         new_env = extendTyEnv env tyvar new_ty
 353         new_result_ty = applyTy result_ty new_ty
 354     in
 355     simplExpr new_env body [] new_result_ty             `thenSmpl` \ body' ->
 356     returnSmpl (Lam (TyBinder tyvar') body')
 357
 358 #ifdef DEBUG
 359 simplExpr env (Lam (TyBinder _) _) (_ : _) result_ty
 360   = panic "simplExpr:TyLam with non-TyArg"
 361 #endif
 362 \end{code}
 363
 364
 365 Ordinary lambdas
 366 ~~~~~~~~~~~~~~~~
 367
 368 There's a complication with lambdas that aren't saturated.
 369 Suppose we have:
 370
 371         (\x. \y. ...x...)
 372
 373 If we did nothing, x is used inside the \y, so would be marked
 374 as dangerous to dup.  But in the common case where the abstraction
 375 is applied to two arguments this is over-pessimistic.
 376 So instead we don't take account of the \y when dealing with x's usage;
 377 instead, the simplifier is careful when partially applying lambdas.
 378
 379 \begin{code}
 380 simplExpr env expr@(Lam (ValBinder binder) body) orig_args result_ty
 381   = go 0 env expr orig_args
 382   where
 383     go n env (Lam (ValBinder binder) body) (val_arg : args)
 384       | isValArg val_arg                -- The lambda has an argument
 385       = tick BetaReduction      `thenSmpl_`
 386         go (n+1) (extendIdEnvWithAtom env binder val_arg) body args
 387
 388     go n env expr@(Lam (ValBinder binder) body) args
 389         -- The lambda is un-saturated, so we must zap the occurrence info
 390         -- on the arguments we've already beta-reduced into the body of the lambda
 391       = ASSERT( null args )     -- Value lambda must match value argument!
 392         let
 393             new_env = markDangerousOccs env (take n orig_args)
 394         in
 395         simplValLam new_env expr 0 {- Guaranteed applied to at least 0 args! -} result_ty
 396                                 `thenSmpl` \ (expr', arity) ->
 397         returnSmpl expr'
 398
 399     go n env non_val_lam_expr args      -- The lambda had enough arguments
 400       = simplExpr env non_val_lam_expr args result_ty
 401 \end{code}
 402
 403
 404 Let expressions
 405 ~~~~~~~~~~~~~~~
 406
 407 \begin{code}
 408 simplExpr env (Let bind body) args result_ty
 409   = simplBind env bind (\env -> simplExpr env body args result_ty) result_ty
 410 \end{code}
 411
 412 Case expressions
 413 ~~~~~~~~~~~~~~~~
 414
 415 \begin{code}
 416 simplExpr env expr@(Case scrut alts) args result_ty
 417   = simplCase env scrut alts (\env rhs -> simplExpr env rhs args result_ty) result_ty
 418 \end{code}
 419
 420
 421 Coercions
 422 ~~~~~~~~~
 423 \begin{code}
 424 simplExpr env (Coerce coercion ty body) args result_ty
 425   = simplCoerce env coercion ty body args result_ty
 426 \end{code}
 427
 428
 429 Set-cost-centre
 430 ~~~~~~~~~~~~~~~
 431
 432 1) Eliminating nested sccs ...
 433 We must be careful to maintain the scc counts ...
 434
 435 \begin{code}
 436 simplExpr env (SCC cc1 (SCC cc2 expr)) args result_ty
 437   | not (isSccCountCostCentre cc2) && case cmpCostCentre cc1 cc2 of { EQ_ -> True; _ -> False }
 438         -- eliminate inner scc if no call counts and same cc as outer
 439   = simplExpr env (SCC cc1 expr) args result_ty
 440
 441   | not (isSccCountCostCentre cc2) && not (isSccCountCostCentre cc1)
 442         -- eliminate outer scc if no call counts associated with either ccs
 443   = simplExpr env (SCC cc2 expr) args result_ty
 444 \end{code}
 445
 446 2) Moving sccs inside lambdas ...
 447
 448 \begin{code}
 449 simplExpr env (SCC cc (Lam binder@(ValBinder _) body)) args result_ty
 450   | not (isSccCountCostCentre cc)
 451         -- move scc inside lambda only if no call counts
 452   = simplExpr env (Lam binder (SCC cc body)) args result_ty
 453
 454 simplExpr env (SCC cc (Lam binder body)) args result_ty
 455         -- always ok to move scc inside type/usage lambda
 456   = simplExpr env (Lam binder (SCC cc body)) args result_ty
 457 \end{code}
 458
 459 3) Eliminating dict sccs ...
 460
 461 \begin{code}
 462 simplExpr env (SCC cc expr) args result_ty
 463   | squashableDictishCcExpr cc expr
 464         -- eliminate dict cc if trivial dict expression
 465   = simplExpr env expr args result_ty
 466 \end{code}
 467
 468 4) Moving arguments inside the body of an scc ...
 469 This moves the cost of doing the application inside the scc
 470 (which may include the cost of extracting methods etc)
 471
 472 \begin{code}
 473 simplExpr env (SCC cost_centre body) args result_ty
 474   = let
 475         new_env = setEnclosingCC env cost_centre
 476     in
 477     simplExpr new_env body args result_ty               `thenSmpl` \ body' ->
 478     returnSmpl (SCC cost_centre body')
 479 \end{code}
 480
 481 %************************************************************************
 482 %*                                                                      *
 483 \subsection{Simplify RHS of a Let/Letrec}
 484 %*                                                                      *
 485 %************************************************************************
 486
 487 simplRhsExpr does arity-expansion.  That is, given:
 488
 489         * a right hand side /\ tyvars -> \a1 ... an -> e
 490         * the information (stored in BinderInfo) that the function will always
 491           be applied to at least k arguments
 492
 493 it transforms the rhs to
 494
 495         /\tyvars -> \a1 ... an b(n+1) ... bk -> (e b(n+1) ... bk)
 496
 497 This is a Very Good Thing!
 498
 499 \begin{code}
 500 simplRhsExpr
 501         :: SimplEnv
 502         -> InBinder
 503         -> InExpr
 504         -> OutId                -- The new binder (used only for its type)
 505         -> SmplM (OutExpr, ArityInfo)
 506 \end{code}
 507
 508
 509 \begin{code}
 510 simplRhsExpr env binder@(id,occ_info) rhs new_id
 511   | maybeToBool (maybeAppDataTyCon rhs_ty)
 512         -- Deal with the data type case, in which case the elaborate
 513         -- eta-expansion nonsense is really quite a waste of time.
 514   = simplExpr rhs_env rhs [] rhs_ty             `thenSmpl` \ rhs' ->
 515     returnSmpl (rhs', ArityExactly 0)
 516
 517   | otherwise   -- OK, use the big hammer
 518   =     -- Deal with the big lambda part
 519     ASSERT( null uvars )        -- For now
 520
 521     mapSmpl cloneTyVarSmpl tyvars                       `thenSmpl` \ tyvars' ->
 522     let
 523         new_tys  = mkTyVarTys tyvars'
 524         body_ty  = foldl applyTy rhs_ty new_tys
 525         lam_env  = extendTyEnvList rhs_env (zipEqual "simplRhsExpr" tyvars new_tys)
 526     in
 527         -- Deal with the little lambda part
 528         -- Note that we call simplLam even if there are no binders,
 529         -- in case it can do arity expansion.
 530     simplValLam lam_env body (getBinderInfoArity occ_info) body_ty      `thenSmpl` \ (lambda', arity) ->
 531
 532         -- Put on the big lambdas, trying to float out any bindings caught inside
 533     mkRhsTyLam tyvars' lambda'                                  `thenSmpl` \ rhs' ->
 534
 535     returnSmpl (rhs', arity)
 536   where
 537     rhs_ty  = idType new_id
 538     rhs_env | idWantsToBeINLINEd id     -- Don't ever inline in a INLINE thing's rhs
 539             = switchOffInlining env1    -- See comments with switchOffInlining
 540             | otherwise
 541             = env1
 542
 543         -- The top level "enclosing CC" is "SUBSUMED".  But the enclosing CC
 544         -- for the rhs of top level defs is "OST_CENTRE".  Consider
 545         --      f = \x -> e
 546         --      g = \y -> let v = f y in scc "x" (v ...)
 547         -- Here we want to inline "f", since its CC is SUBSUMED, but we don't
 548         -- want to inline "v" since its CC is dynamically determined.
 549
 550     current_cc = getEnclosingCC env
 551     env1 | costsAreSubsumed current_cc = setEnclosingCC env useCurrentCostCentre
 552          | otherwise                   = env
 553
 554     (uvars, tyvars, body) = collectUsageAndTyBinders rhs
 555 \end{code}
 556
 557
 558 ----------------------------------------------------------------
 559         An old special case that is now nuked.
 560
 561 First a special case for variable right-hand sides
 562         v = w
 563 It's OK to simplify the RHS, but it's often a waste of time.  Often
 564 these v = w things persist because v is exported, and w is used
 565 elsewhere.  So if we're not careful we'll eta expand the rhs, only
 566 to eta reduce it in competeNonRec.
 567
 568 If we leave the binding unchanged, we will certainly replace v by w at
 569 every occurrence of v, which is good enough.
 570
 571 In fact, it's *better* to replace v by w than to inline w in v's rhs,
 572 even if this is the only occurrence of w.  Why? Because w might have
 573 IdInfo (such as strictness) that v doesn't.
 574
 575 Furthermore, there might be other uses of w; if so, inlining w in
 576 v's rhs will duplicate w's rhs, whereas replacing v by w doesn't.
 577
 578 HOWEVER, we have to be careful if w is something that *must* be
 579 inlined.  In particular, its binding may have been dropped.  Here's
 580 an example that actually happened:
 581         let x = let y = e in y
 582      in f x
 583 The "let y" was floated out, and then (since y occurs once in a
 584 definitely inlinable position) the binding was dropped, leaving
 585         {y=e} let x = y in f x
 586 But now using the reasoning of this little section,
 587 y wasn't inlined, because it was a let x=y form.
 588
 589
 590                 HOWEVER
 591
 592 This "optimisation" turned out to be a bad idea.  If there's are
 593 top-level exported bindings like
 594
 595         y = I# 3#
 596         x = y
 597
 598 then y wasn't getting inlined in x's rhs, and we were getting
 599 bad code.  So I've removed the special case from here, and
 600 instead we only try eta reduction and constructor reuse
 601 in completeNonRec if the thing is *not* exported.
 602
 603
 604 \begin{pseudocode}
 605 simplRhsExpr env binder@(id,occ_info) (Var v) new_id
 606  | maybeToBool maybe_stop_at_var
 607  = returnSmpl (Var the_var, getIdArity the_var)
 608  where
 609    maybe_stop_at_var
 610      = case (runEager $ lookupId env v) of
 611          VarArg v' | not (must_unfold v') -> Just v'
 612          other                            -> Nothing
 613
 614    Just the_var = maybe_stop_at_var
 615
 616    must_unfold v' =  idMustBeINLINEd v'
 617                   || case lookupOutIdEnv env v' of
 618                         Just (_, _, InUnfolding _ _) -> True
 619                         other                        -> False
 620 \end{pseudocode}
 621
 622                 End of old, nuked, special case.
 623 ------------------------------------------------------------------
 624
 625
 626 %************************************************************************
 627 %*                                                                      *
 628 \subsection{Simplify a lambda abstraction}
 629 %*                                                                      *
 630 %************************************************************************
 631
 632 Simplify (\binders -> body) trying eta expansion and reduction, given that
 633 the abstraction will always be applied to at least min_no_of_args.
 634
 635 \begin{code}
 636 simplValLam env expr min_no_of_args expr_ty
 637   | not (switchIsSet env SimplDoLambdaEtaExpansion) ||  -- Bale out if eta expansion off
 638
 639     exprIsTrivial expr                              ||  -- or it's a trivial RHS
 640         -- No eta expansion for trivial RHSs
 641         -- It's rather a Bad Thing to expand
 642         --      g = f alpha beta
 643         -- to
 644         --      g = \a b c -> f alpha beta a b c
 645         --
 646         -- The original RHS is "trivial" (exprIsTrivial), because it generates
 647         -- no code (renames f to g).  But the new RHS isn't.
 648
 649     null potential_extra_binder_tys                 ||  -- or ain't a function
 650     no_of_extra_binders <= 0                            -- or no extra binders needed
 651   = cloneIds env binders                `thenSmpl` \ binders' ->
 652     let
 653         new_env = extendIdEnvWithClones env binders binders'
 654     in
 655     simplExpr new_env body [] body_ty           `thenSmpl` \ body' ->
 656     returnSmpl (mkValLam binders' body', final_arity)
 657
 658   | otherwise                           -- Eta expansion possible
 659   = -- A SSERT( no_of_extra_binders <= length potential_extra_binder_tys )
 660     (if not ( no_of_extra_binders <= length potential_extra_binder_tys ) then
 661         pprTrace "simplValLam" (vcat [ppr PprDebug expr,
 662                                           ppr PprDebug expr_ty,
 663                                           ppr PprDebug binders,
 664                                           int no_of_extra_binders,
 665                                           ppr PprDebug potential_extra_binder_tys])
 666     else \x -> x) $
 667
 668     tick EtaExpansion                   `thenSmpl_`
 669     cloneIds env binders                `thenSmpl` \ binders' ->
 670     let
 671         new_env = extendIdEnvWithClones env binders binders'
 672     in
 673     newIds extra_binder_tys                                             `thenSmpl` \ extra_binders' ->
 674     simplExpr new_env body (map VarArg extra_binders') etad_body_ty     `thenSmpl` \ body' ->
 675     returnSmpl (
 676       mkValLam (binders' ++ extra_binders') body',
 677       final_arity
 678     )
 679
 680   where
 681     (binders,body)             = collectValBinders expr
 682     no_of_binders              = length binders
 683     (arg_tys, res_ty)          = splitFunTyExpandingDicts expr_ty
 684     potential_extra_binder_tys = (if not (no_of_binders <= length arg_tys) then
 685                                         pprTrace "simplValLam" (vcat [ppr PprDebug expr,
 686                                                                           ppr PprDebug expr_ty,
 687                                                                           ppr PprDebug binders])
 688                                   else \x->x) $
 689                                  drop no_of_binders arg_tys
 690     body_ty                    = mkFunTys potential_extra_binder_tys res_ty
 691
 692         -- Note: it's possible that simplValLam will be applied to something
 693         -- with a forall type.  Eg when being applied to the rhs of
 694         --              let x = wurble
 695         -- where wurble has a forall-type, but no big lambdas at the top.
 696         -- We could be clever an insert new big lambdas, but we don't bother.
 697
 698     etad_body_ty        = mkFunTys (drop no_of_extra_binders potential_extra_binder_tys) res_ty
 699     extra_binder_tys    = take no_of_extra_binders potential_extra_binder_tys
 700     final_arity         = atLeastArity (no_of_binders + no_of_extra_binders)
 701
 702     no_of_extra_binders =       -- First, use the info about how many args it's
 703                                 -- always applied to in its scope; but ignore this
 704                                 -- info for thunks. To see why we ignore it for thunks,
 705                                 -- consider     let f = lookup env key in (f 1, f 2)
 706                                 -- We'd better not eta expand f just because it is
 707                                 -- always applied!
 708                            (min_no_of_args - no_of_binders)
 709
 710                                 -- Next, try seeing if there's a lambda hidden inside
 711                                 -- something cheap.
 712                                 -- etaExpandCount can reuturn a huge number (like 10000!) if
 713                                 -- it finds that the body is a call to "error"; hence
 714                                 -- the use of "min" here.
 715                            `max`
 716                            (etaExpandCount body `min` length potential_extra_binder_tys)
 717
 718                                 -- Finally, see if it's a state transformer, in which
 719                                 -- case we eta-expand on principle! This can waste work,
 720                                 -- but usually doesn't
 721                            `max`
 722                            case potential_extra_binder_tys of
 723                                 [ty] | ty `eqTy` realWorldStateTy -> 1
 724                                 other                             -> 0
 725 \end{code}
 726
 727
 728
 729 %************************************************************************
 730 %*                                                                      *
 731 \subsection[Simplify-coerce]{Coerce expressions}
 732 %*                                                                      *
 733 %************************************************************************
 734
 735 \begin{code}
 736 -- (coerce (case s of p -> r)) args ==> case s of p -> (coerce r) args
 737 simplCoerce env coercion ty expr@(Case scrut alts) args result_ty
 738   = simplCase env scrut alts (\env rhs -> simplCoerce env coercion ty rhs args result_ty) result_ty
 739
 740 -- (coerce (let defns in b)) args  ==> let defns' in (coerce b) args
 741 simplCoerce env coercion ty (Let bind body) args result_ty
 742   = simplBind env bind (\env -> simplCoerce env coercion ty body args result_ty) result_ty
 743
 744 -- Default case
 745 simplCoerce env coercion ty expr args result_ty
 746   = simplTy env ty                      `appEager` \ ty' ->
 747     simplTy env expr_ty                 `appEager` \ expr_ty' ->
 748     simplExpr env expr [] expr_ty'      `thenSmpl` \ expr' ->
 749     returnSmpl (mkGenApp (mkCoerce coercion ty' expr') args)
 750   where
 751     expr_ty = coreExprType (unTagBinders expr)  -- Rather like simplCase other_scrut
 752
 753         -- Try cancellation; we do this "on the way up" because
 754         -- I think that's where it'll bite best
 755     mkCoerce (CoerceOut con1) ty1 (Coerce (CoerceIn  con2) ty2 body) | con1 == con2 = body
 756     mkCoerce coercion ty  body = Coerce coercion ty body
 757 \end{code}
 758
 759
 760 %************************************************************************
 761 %*                                                                      *
 762 \subsection[Simplify-bind]{Binding groups}
 763 %*                                                                      *
 764 %************************************************************************
 765
 766 \begin{code}
 767 simplBind :: SimplEnv
 768           -> InBinding
 769           -> (SimplEnv -> SmplM OutExpr)
 770           -> OutType
 771           -> SmplM OutExpr
 772
 773 simplBind env (NonRec binder rhs) body_c body_ty = simplNonRec env binder rhs body_c body_ty
 774 simplBind env (Rec pairs)         body_c body_ty = simplRec    env pairs      body_c body_ty
 775 \end{code}
 776
 777
 778 %************************************************************************
 779 %*                                                                      *
 780 \subsection[Simplify-let]{Let-expressions}
 781 %*                                                                      *
 782 %************************************************************************
 783
 784 Float switches
 785 ~~~~~~~~~~~~~~
 786 The booleans controlling floating have to be set with a little care.
 787 Here's one performance bug I found:
 788
 789         let x = let y = let z = case a# +# 1 of {b# -> E1}
 790                         in E2
 791                 in E3
 792         in E4
 793
 794 Now, if E2, E3 aren't HNFs we won't float the y-binding or the z-binding.
 795 Before case_floating_ok included float_exposes_hnf, the case expression was floated
 796 *one level per simplifier iteration* outwards.  So it made th s
 797
 798
 799 Floating case from let
 800 ~~~~~~~~~~~~~~~~~~~~~~
 801 When floating cases out of lets, remember this:
 802
 803         let x* = case e of alts
 804         in <small expr>
 805
 806 where x* is sure to be demanded or e is a cheap operation that cannot
 807 fail, e.g. unboxed addition.  Here we should be prepared to duplicate
 808 <small expr>.  A good example:
 809
 810         let x* = case y of
 811                    p1 -> build e1
 812                    p2 -> build e2
 813         in
 814         foldr c n x*
 815 ==>
 816         case y of
 817           p1 -> foldr c n (build e1)
 818           p2 -> foldr c n (build e2)
 819
 820 NEW: We use the same machinery that we use for case-of-case to
 821 *always* do case floating from let, that is we let bind and abstract
 822 the original let body, and let the occurrence analyser later decide
 823 whether the new let should be inlined or not. The example above
 824 becomes:
 825
 826 ==>
 827       let join_body x' = foldr c n x'
 828         in case y of
 829         p1 -> let x* = build e1
 830                 in join_body x*
 831         p2 -> let x* = build e2
 832                 in join_body x*
 833
 834 note that join_body is a let-no-escape.
 835 In this particular example join_body will later be inlined,
 836 achieving the same effect.
 837 ToDo: check this is OK with andy
 838
 839
 840 Let to case: two points
 841 ~~~~~~~~~~~
 842
 843 Point 1.  We defer let-to-case for all data types except single-constructor
 844 ones.  Suppose we change
 845
 846         let x* = e in b
 847 to
 848         case e of x -> b
 849
 850 It can be the case that we find that b ultimately contains ...(case x of ..)....
 851 and this is the only occurrence of x.  Then if we've done let-to-case
 852 we can't inline x, which is a real pain.  On the other hand, we lose no
 853 transformations by not doing this transformation, because the relevant
 854 case-of-X transformations are also implemented by simpl_bind.
 855
 856 If x is a single-constructor type, then we go ahead anyway, giving
 857
 858         case e of (y,z) -> let x = (y,z) in b
 859
 860 because now we can squash case-on-x wherever they occur in b.
 861
 862 We do let-to-case on multi-constructor types in the tidy-up phase
 863 (tidyCoreExpr) mainly so that the code generator doesn't need to
 864 spot the demand-flag.
 865
 866
 867 Point 2.  It's important to try let-to-case before doing the
 868 strict-let-of-case transformation, which happens in the next equation
 869 for simpl_bind.
 870
 871         let a*::Int = case v of {p1->e1; p2->e2}
 872         in b
 873
 874 (The * means that a is sure to be demanded.)
 875 If we do case-floating first we get this:
 876
 877         let k = \a* -> b
 878         in case v of
 879                 p1-> let a*=e1 in k a
 880                 p2-> let a*=e2 in k a
 881
 882 Now watch what happens if we do let-to-case first:
 883
 884         case (case v of {p1->e1; p2->e2}) of
 885           Int a# -> let a*=I# a# in b
 886 ===>
 887         let k = \a# -> let a*=I# a# in b
 888         in case v of
 889                 p1 -> case e1 of I# a# -> k a#
 890                 p1 -> case e2 of I# a# -> k a#
 891
 892 The latter is clearly better.  (Remember the reboxing let-decl for a
 893 is likely to go away, because after all b is strict in a.)
 894
 895 We do not do let to case for WHNFs, e.g.
 896
 897           let x = a:b in ...
 898           =/=>
 899           case a:b of x in ...
 900
 901 as this is less efficient.  but we don't mind doing let-to-case for
 902 "bottom", as that will allow us to remove more dead code, if anything:
 903
 904           let x = error in ...
 905           ===>
 906           case error  of x -> ...
 907           ===>
 908           error
 909
 910 Notice that let to case occurs only if x is used strictly in its body
 911 (obviously).
 912
 913
 914 \begin{code}
 915 -- Dead code is now discarded by the occurrence analyser,
 916
 917 simplNonRec env binder@(id,occ_info) rhs body_c body_ty
 918   | inlineUnconditionally ok_to_dup id occ_info
 919   =     -- The binder is used in definitely-inline way in the body
 920         -- So add it to the environment, drop the binding, and continue
 921     body_c (extendEnvGivenInlining env id occ_info rhs)
 922
 923   | idWantsToBeINLINEd id
 924   = complete_bind env rhs       -- Don't mess about with floating or let-to-case on
 925                                 -- INLINE things
 926   | otherwise
 927   = simpl_bind env rhs
 928   where
 929     -- Try let-to-case; see notes below about let-to-case
 930     simpl_bind env rhs | try_let_to_case &&
 931                          will_be_demanded &&
 932                          (rhs_is_bot ||
 933                           not rhs_is_whnf &&
 934                           singleConstructorType rhs_ty
 935                                 -- Only do let-to-case for single constructor types.
 936                                 -- For other types we defer doing it until the tidy-up phase at
 937                                 -- the end of simplification.
 938                          )
 939       = tick Let2Case                           `thenSmpl_`
 940         simplCase env rhs (AlgAlts [] (BindDefault binder (Var id)))
 941                           (\env rhs -> complete_bind env rhs) body_ty
 942                 -- OLD COMMENT:  [now the new RHS is only "x" so there's less worry]
 943                 -- NB: it's tidier to call complete_bind not simpl_bind, else
 944                 -- we nearly end up in a loop.  Consider:
 945                 --      let x = rhs in b
 946                 -- ==>  case rhs of (p,q) -> let x=(p,q) in b
 947                 -- This effectively what the above simplCase call does.
 948                 -- Now, the inner let is a let-to-case target again!  Actually, since
 949                 -- the RHS is in WHNF it won't happen, but it's a close thing!
 950
 951     -- Try let-from-let
 952     simpl_bind env (Let bind rhs) | let_floating_ok
 953       = tick LetFloatFromLet                    `thenSmpl_`
 954         simplBind env (fix_up_demandedness will_be_demanded bind)
 955                       (\env -> simpl_bind env rhs) body_ty
 956
 957     -- Try case-from-let; this deals with a strict let of error too
 958     simpl_bind env (Case scrut alts) | case_floating_ok scrut
 959       = tick CaseFloatFromLet                           `thenSmpl_`
 960
 961         -- First, bind large let-body if necessary
 962         if ok_to_dup || isSingleton (nonErrorRHSs alts)
 963         then
 964             simplCase env scrut alts (\env rhs -> simpl_bind env rhs) body_ty
 965         else
 966             bindLargeRhs env [binder] body_ty body_c    `thenSmpl` \ (extra_binding, new_body) ->
 967             let
 968                 body_c' = \env -> simplExpr env new_body [] body_ty
 969                 case_c  = \env rhs -> simplNonRec env binder rhs body_c' body_ty
 970             in
 971             simplCase env scrut alts case_c body_ty     `thenSmpl` \ case_expr ->
 972             returnSmpl (Let extra_binding case_expr)
 973
 974     -- None of the above; simplify rhs and tidy up
 975     simpl_bind env rhs = complete_bind env rhs
 976
 977     complete_bind env rhs
 978       = cloneId env binder                      `thenSmpl` \ new_id ->
 979         simplRhsExpr env binder rhs new_id      `thenSmpl` \ (rhs',arity) ->
 980         completeNonRec env binder
 981                 (new_id `withArity` arity) rhs' `thenSmpl` \ (new_env, binds) ->
 982         body_c new_env                          `thenSmpl` \ body' ->
 983         returnSmpl (mkCoLetsAny binds body')
 984
 985
 986         -- All this stuff is computed at the start of the simpl_bind loop
 987     float_lets                = switchIsSet env SimplFloatLetsExposingWHNF
 988     float_primops             = switchIsSet env SimplOkToFloatPrimOps
 989     ok_to_dup                 = switchIsSet env SimplOkToDupCode
 990     always_float_let_from_let = switchIsSet env SimplAlwaysFloatLetsFromLets
 991     try_let_to_case           = switchIsSet env SimplLetToCase
 992     no_float                  = switchIsSet env SimplNoLetFromStrictLet
 993
 994     demand_info      = getIdDemandInfo id
 995     will_be_demanded = willBeDemanded demand_info
 996     rhs_ty           = idType id
 997
 998     form        = mkFormSummary rhs
 999     rhs_is_bot  = case form of
1000                         BottomForm -> True
1001                         other      -> False
1002     rhs_is_whnf = case form of
1003                         VarForm -> True
1004                         ValueForm -> True
1005                         other -> False
1006
1007     float_exposes_hnf = floatExposesHNF float_lets float_primops ok_to_dup rhs
1008
1009     let_floating_ok  = (will_be_demanded && not no_float) ||
1010                        always_float_let_from_let ||
1011                        float_exposes_hnf
1012
1013     case_floating_ok scrut = (will_be_demanded && not no_float) ||
1014                              (float_exposes_hnf && is_cheap_prim_app scrut && float_primops)
1015         -- See note below
1016 \end{code}
1017
1018
1019 @completeNonRec@ looks at the simplified post-floating RHS of the
1020 let-expression, with a view to turning
1021         x = e
1022 into
1023         x = y
1024 where y is just a variable.  Now we can eliminate the binding
1025 altogether, and replace x by y throughout.
1026
1027 There are two cases when we can do this:
1028
1029         * When e is a constructor application, and we have
1030           another variable in scope bound to the same
1031           constructor application.  [This is just a special
1032           case of common-subexpression elimination.]
1033
1034         * When e can be eta-reduced to a variable.  E.g.
1035                 x = \a b -> y a b
1036
1037
1038 HOWEVER, if x is exported, we don't attempt this at all.  Why not?
1039 Because then we can't remove the x=y binding, in which case we
1040 have just made things worse, perhaps a lot worse.
1041
1042 \begin{code}
1043         -- Right hand sides that are constructors
1044         --      let v = C args
1045         --      in
1046         --- ...(let w = C same-args in ...)...
1047         -- Then use v instead of w.      This may save
1048         -- re-constructing an existing constructor.
1049 completeNonRec env binder new_id new_rhs
1050   |  not (isExported new_id)            -- Don't bother for exported things
1051                                         -- because we won't be able to drop
1052                                         -- its binding.
1053   && maybeToBool maybe_atomic_rhs
1054   = tick tick_type      `thenSmpl_`
1055     returnSmpl (extendIdEnvWithAtom env binder rhs_arg, [])
1056   where
1057     Just (rhs_arg, tick_type) = maybe_atomic_rhs
1058     maybe_atomic_rhs
1059       =                 -- Try first for an existing constructor application
1060         case maybe_con new_rhs of {
1061         Just con -> Just (VarArg con, ConReused);
1062
1063         Nothing  ->     -- No good; try eta-reduction
1064         case etaCoreExpr new_rhs of {
1065         Var v -> Just (VarArg v, AtomicRhs);
1066         Lit l -> Just (LitArg l, AtomicRhs);
1067
1068         other -> Nothing -- Neither worked, so return Nothing
1069         }}
1070
1071
1072     maybe_con (Con con con_args) | switchIsSet env SimplReuseCon
1073                                  = lookForConstructor env con con_args
1074     maybe_con other_rhs          = Nothing
1075
1076 completeNonRec env binder@(id,occ_info) new_id new_rhs
1077   = returnSmpl (new_env , [NonRec new_id new_rhs])
1078   where
1079     new_env = extendEnvGivenBinding (extendIdEnvWithClone env binder new_id)
1080                                     occ_info new_id new_rhs
1081 \end{code}
1082
1083 ----------------------------------------------------------------------------
1084         A digression on constructor CSE
1085
1086 Consider
1087 @
1088         f = \x -> case x of
1089                     (y:ys) -> y:ys
1090                     []     -> ...
1091 @
1092 Is it a good idea to replace the rhs @y:ys@ with @x@?  This depends a
1093 bit on the compiler technology, but in general I believe not. For
1094 example, here's some code from a real program:
1095 @
1096 const.Int.max.wrk{-s2516-} =
1097     \ upk.s3297#  upk.s3298# ->
1098         let {
1099           a.s3299 :: Int
1100           _N_ {-# U(P) #-}
1101           a.s3299 = I#! upk.s3297#
1102         } in
1103           case (const.Int._tagCmp.wrk{-s2513-} upk.s3297# upk.s3298#) of {
1104             _LT -> I#! upk.s3298#
1105             _EQ -> a.s3299
1106             _GT -> a.s3299
1107           }
1108 @
1109 The a.s3299 really isn't doing much good.  We'd be better off inlining
1110 it.  (Actually, let-no-escapery means it isn't as bad as it looks.)
1111
1112 So the current strategy is to inline all known-form constructors, and
1113 only do the reverse (turn a constructor application back into a
1114 variable) when we find a let-expression:
1115 @
1116         let x = C a1 .. an
1117         in
1118         ... (let y = C a1 .. an in ...) ...
1119 @
1120 where it is always good to ditch the binding for y, and replace y by
1121 x.
1122                 End of digression
1123 ----------------------------------------------------------------------------
1124
1125 ----------------------------------------------------------------------------
1126                 A digression on "optimising" coercions
1127
1128    The trouble is that we kept transforming
1129                 let x = coerce e
1130                     y = coerce x
1131                 in ...
1132    to
1133                 let x' = coerce e
1134                     y' = coerce x'
1135                 in ...
1136    and counting a couple of ticks for this non-transformation
1137 \begin{pseudocode}
1138         -- We want to ensure that all let-bound Coerces have
1139         -- atomic bodies, so they can freely be inlined.
1140 completeNonRec env binder new_id (Coerce coercion ty rhs)
1141   | not (is_atomic rhs)
1142   = newId (coreExprType rhs)                            `thenSmpl` \ inner_id ->
1143     completeNonRec env
1144                    (inner_id, dangerousArgOcc) inner_id rhs `thenSmpl` \ (env1, binds1) ->
1145         -- Dangerous occ because, like constructor args,
1146         -- it can be duplicated easily
1147     let
1148         atomic_rhs = case runEager $ lookupId env1 inner_id of
1149                         LitArg l -> Lit l
1150                         VarArg v -> Var v
1151     in
1152     completeNonRec env1 binder new_id
1153                    (Coerce coercion ty atomic_rhs)      `thenSmpl` \ (env2, binds2) ->
1154
1155     returnSmpl (env2, binds1 ++ binds2)
1156 \end{pseudocode}
1157 ----------------------------------------------------------------------------
1158
1159
1160
1161 %************************************************************************
1162 %*                                                                      *
1163 \subsection[Simplify-letrec]{Letrec-expressions}
1164 %*                                                                      *
1165 %************************************************************************
1166
1167 Letrec expressions
1168 ~~~~~~~~~~~~~~~~~~
1169 Here's the game plan
1170
1171 1. Float any let(rec)s out of the RHSs
1172 2. Clone all the Ids and extend the envt with these clones
1173 3. Simplify one binding at a time, adding each binding to the
1174    environment once it's done.
1175
1176 This relies on the occurrence analyser to
1177         a) break all cycles with an Id marked MustNotBeInlined
1178         b) sort the decls into topological order
1179 The former prevents infinite inlinings, and the latter means
1180 that we get maximum benefit from working top to bottom.
1181
1182
1183 \begin{code}
1184 simplRec env pairs body_c body_ty
1185   =     -- Do floating, if necessary
1186     floatBind env False (Rec pairs)     `thenSmpl` \ [Rec pairs'] ->
1187     let
1188         binders = map fst pairs'
1189     in
1190     cloneIds env binders                        `thenSmpl` \ ids' ->
1191     let
1192        env_w_clones = extendIdEnvWithClones env binders ids'
1193     in
1194     simplRecursiveGroup env_w_clones ids' pairs'        `thenSmpl` \ (pairs', new_env) ->
1195
1196     body_c new_env                              `thenSmpl` \ body' ->
1197
1198     returnSmpl (Let (Rec pairs') body')
1199 \end{code}
1200
1201 \begin{code}
1202 -- The env passed to simplRecursiveGroup already has
1203 -- bindings that clone the variables of the group.
1204 simplRecursiveGroup env new_ids []
1205   = returnSmpl ([], env)
1206
1207 simplRecursiveGroup env (new_id : new_ids) ((binder@(id, occ_info), rhs) : pairs)
1208   | inlineUnconditionally ok_to_dup id occ_info
1209   =     -- Single occurrence, so drop binding and extend env with the inlining
1210         -- This is a little delicate, because what if the unique occurrence
1211         -- is *before* this binding?  This'll never happen, because
1212         -- either it'll be marked "never inline" or else its occurrence will
1213         -- occur after its binding in the group.
1214         --
1215         -- If these claims aren't right Core Lint will spot an unbound
1216         -- variable.  A quick fix is to delete this clause for simplRecursiveGroup
1217     let
1218         new_env = extendEnvGivenInlining env new_id occ_info rhs
1219     in
1220     simplRecursiveGroup new_env new_ids pairs
1221
1222   | otherwise
1223   = simplRhsExpr env binder rhs new_id          `thenSmpl` \ (new_rhs, arity) ->
1224     let
1225         new_id' = new_id `withArity` arity
1226
1227         -- ToDo: this next bit could usefully share code with completeNonRec
1228
1229         new_env
1230           | idMustNotBeINLINEd new_id           -- Occurrence analyser says "don't inline"
1231           = env
1232
1233           | is_atomic eta'd_rhs                 -- If rhs (after eta reduction) is atomic
1234           = extendIdEnvWithAtom env binder the_arg
1235
1236           | otherwise                           -- Non-atomic
1237           = extendEnvGivenBinding env occ_info new_id new_rhs
1238                                                 -- Don't eta if it doesn't eliminate the binding
1239
1240         eta'd_rhs = etaCoreExpr new_rhs
1241         the_arg   = case eta'd_rhs of
1242                           Var v -> VarArg v
1243                           Lit l -> LitArg l
1244     in
1245     simplRecursiveGroup new_env new_ids pairs   `thenSmpl` \ (new_pairs, final_env) ->
1246     returnSmpl ((new_id', new_rhs) : new_pairs, final_env)
1247   where
1248     ok_to_dup = switchIsSet env SimplOkToDupCode
1249 \end{code}
1250
1251
1252
1253 \begin{code}
1254 floatBind :: SimplEnv
1255           -> Bool                               -- True <=> Top level
1256           -> InBinding
1257           -> SmplM [InBinding]
1258
1259 floatBind env top_level bind
1260   | not float_lets ||
1261     n_extras == 0
1262   = returnSmpl [bind]
1263
1264   | otherwise
1265   = tickN LetFloatFromLet n_extras              `thenSmpl_`
1266                 -- It's important to increment the tick counts if we
1267                 -- do any floating.  A situation where this turns out
1268                 -- to be important is this:
1269                 -- Float in produces:
1270                 --      letrec  x = let y = Ey in Ex
1271                 --      in B
1272                 -- Now floating gives this:
1273                 --      letrec x = Ex
1274                 --             y = Ey
1275                 --      in B
1276                 --- We now want to iterate once more in case Ey doesn't
1277                 -- mention x, in which case the y binding can be pulled
1278                 -- out as an enclosing let(rec), which in turn gives
1279                 -- the strictness analyser more chance.
1280     returnSmpl binds'
1281
1282   where
1283     (binds', _, n_extras) = fltBind bind
1284
1285     float_lets                = switchIsSet env SimplFloatLetsExposingWHNF
1286     always_float_let_from_let = switchIsSet env SimplAlwaysFloatLetsFromLets
1287
1288         -- fltBind guarantees not to return leaky floats
1289         -- and all the binders of the floats have had their demand-info zapped
1290     fltBind (NonRec bndr rhs)
1291       = (binds ++ [NonRec (un_demandify bndr) rhs'],
1292          leakFree bndr rhs',
1293          length binds)
1294       where
1295         (binds, rhs') = fltRhs rhs
1296
1297     fltBind (Rec pairs)
1298       = ([Rec (extras
1299                ++
1300                binders `zip` rhss')],
1301          and (zipWith leakFree binders rhss'),
1302          length extras
1303         )
1304
1305       where
1306         (binders, rhss)  = unzip pairs
1307         (binds_s, rhss') = mapAndUnzip fltRhs rhss
1308         extras           = concat (map get_pairs (concat binds_s))
1309
1310         get_pairs (NonRec bndr rhs) = [(bndr,rhs)]
1311         get_pairs (Rec pairs)       = pairs
1312
1313         -- fltRhs has same invariant as fltBind
1314     fltRhs rhs
1315       |  (always_float_let_from_let ||
1316           floatExposesHNF True False False rhs)
1317       = fltExpr rhs
1318
1319       | otherwise
1320       = ([], rhs)
1321
1322
1323         -- fltExpr has same invariant as fltBind
1324     fltExpr (Let bind body)
1325       | not top_level || binds_wont_leak
1326             -- fltExpr guarantees not to return leaky floats
1327       = (binds' ++ body_binds, body')
1328       where
1329         (body_binds, body')          = fltExpr body
1330         (binds', binds_wont_leak, _) = fltBind bind
1331
1332     fltExpr expr = ([], expr)
1333
1334 -- Crude but effective
1335 leakFree (id,_) rhs = case getIdArity id of
1336                         ArityAtLeast n | n > 0 -> True
1337                         ArityExactly n | n > 0 -> True
1338                         other                  -> whnfOrBottom (mkFormSummary rhs)
1339 \end{code}
1340
1341
1342 %************************************************************************
1343 %*                                                                      *
1344 \subsection[Simplify-atoms]{Simplifying atoms}
1345 %*                                                                      *
1346 %************************************************************************
1347
1348 \begin{code}
1349 simplArg :: SimplEnv -> InArg -> Eager ans OutArg
1350
1351 simplArg env (LitArg lit) = returnEager (LitArg lit)
1352 simplArg env (TyArg  ty)  = simplTy env ty      `appEager` \ ty' ->
1353                             returnEager (TyArg ty')
1354 simplArg env (VarArg id)  = lookupId env id
1355 \end{code}
1356
1357 %************************************************************************
1358 %*                                                                      *
1359 \subsection[Simplify-quickies]{Some local help functions}
1360 %*                                                                      *
1361 %************************************************************************
1362
1363
1364 \begin{code}
1365 -- fix_up_demandedness switches off the willBeDemanded Info field
1366 -- for bindings floated out of a non-demanded let
1367 fix_up_demandedness True {- Will be demanded -} bind
1368    = bind       -- Simple; no change to demand info needed
1369 fix_up_demandedness False {- May not be demanded -} (NonRec binder rhs)
1370    = NonRec (un_demandify binder) rhs
1371 fix_up_demandedness False {- May not be demanded -} (Rec pairs)
1372    = Rec [(un_demandify binder, rhs) | (binder,rhs) <- pairs]
1373
1374 un_demandify (id, occ_info) = (id `addIdDemandInfo` noDemandInfo, occ_info)
1375
1376 is_cheap_prim_app (Prim op _) = primOpOkForSpeculation op
1377 is_cheap_prim_app other       = False
1378
1379 computeResultType :: SimplEnv -> InType -> [OutArg] -> OutType
1380 computeResultType env expr_ty orig_args
1381   = simplTy env expr_ty         `appEager` \ expr_ty' ->
1382     let
1383         go ty [] = ty
1384         go ty (TyArg ty_arg : args) = go (mkAppTy ty ty_arg) args
1385         go ty (a:args) | isValArg a = case (getFunTy_maybe ty) of
1386                                         Just (_, res_ty) -> go res_ty args
1387                                         Nothing          ->
1388                                             pprPanic "computeResultType" (vcat [
1389                                                                         ppr PprDebug (a:args),
1390                                                                         ppr PprDebug orig_args,
1391                                                                         ppr PprDebug expr_ty',
1392                                                                         ppr PprDebug ty])
1393     in
1394     go expr_ty' orig_args
1395
1396
1397 var `withArity` UnknownArity = var
1398 var `withArity` arity        = var `addIdArity` arity
1399
1400 is_atomic (Var v) = True
1401 is_atomic (Lit l) = not (isNoRepLit l)
1402 is_atomic other   = False
1403 \end{code}
1404