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 Pretty           -- these are for debugging only
  12 import Outputable
  13
  14 import SimplMonad
  15 import SimplEnv
  16
  17 import PrelInfo         ( getPrimOpResultInfo, PrimOpResultInfo(..),
  18                           primOpOkForSpeculation, PrimOp(..), PrimRep,
  19                           realWorldStateTy
  20                           IF_ATTACK_PRAGMAS(COMMA realWorldTy)
  21                           IF_ATTACK_PRAGMAS(COMMA tagOf_PrimOp)
  22                           IF_ATTACK_PRAGMAS(COMMA pprPrimOp)
  23                         )
  24 import Type             ( maybeDataTyCon, mkTyVarTy, applyTy,
  25                           splitTyArgs, splitTypeWithDictsAsArgs,
  26                           maybeUnpackFunTy, isPrimType
  27                         )
  28 import Literal          ( isNoRepLit, Literal(..) )
  29 import BinderInfo
  30 import CmdLineOpts      ( SimplifierSwitch(..) )
  31 import ConFold          ( completePrim )
  32 import Id
  33 import IdInfo
  34 import Maybes           ( Maybe(..), catMaybes, maybeToBool )
  35 import SimplCase
  36 import SimplUtils
  37 import SimplVar         ( completeVar )
  38 import Util
  39 \end{code}
  40
  41 The controlling flags, and what they do
  42 ~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~
  43
  44 passes:
  45 ------
  46 -fsimplify              = run the simplifier
  47 -ffloat-inwards         = runs the float lets inwards pass
  48 -ffloat                 = runs the full laziness pass
  49                           (ToDo: rename to -ffull-laziness)
  50 -fupdate-analysis       = runs update analyser
  51 -fstrictness            = runs strictness analyser
  52 -fsaturate-apps         = saturates applications (eta expansion)
  53
  54 options:
  55 -------
  56 -ffloat-past-lambda     = OK to do full laziness.
  57                           (ToDo: remove, as the full laziness pass is
  58                                  useless without this flag, therefore
  59                                  it is unnecessary. Just -ffull-laziness
  60                                  should be kept.)
  61
  62 -ffloat-lets-ok         = OK to float lets out of lets if the enclosing
  63                           let is strict or if the floating will expose
  64                           a WHNF [simplifier].
  65
  66 -ffloat-primops-ok      = OK to float out of lets cases whose scrutinee
  67                           is a primop that cannot fail [simplifier].
  68
  69 -fcode-duplication-ok   = allows the previous option to work on cases with
  70                           multiple branches [simplifier].
  71
  72 -flet-to-case           = does let-to-case transformation [simplifier].
  73
  74 -fcase-of-case          = does case of case transformation [simplifier].
  75
  76 -fpedantic-bottoms      = does not allow:
  77                              case x of y -> e  ===>  e[x/y]
  78                           (which may turn bottom into non-bottom)
  79
  80
  81                         NOTES ON INLINING
  82                         ~~~~~~~~~~~~~~~~~
  83
  84 Inlining is one of the delicate aspects of the simplifier.  By
  85 ``inlining'' we mean replacing an occurrence of a variable ``x'' by
  86 the RHS of x's definition.  Thus
  87
  88         let x = e in ...x...    ===>   let x = e in ...e...
  89
  90 We have two mechanisms for inlining:
  91
  92 1.  Unconditional.  The occurrence analyser has pinned an (OneOcc
  93 FunOcc NoDupDanger NotInsideSCC n) flag on the variable, saying ``it's
  94 certainly safe to inline this variable, and to drop its binding''.
  95 (...Umm... if n <= 1; if n > 1, it is still safe, provided you are
  96 happy to be duplicating code...) When it encounters such a beast, the
  97 simplifer binds the variable to its RHS (in the id_env) and continues.
  98 It doesn't even look at the RHS at that stage.  It also drops the
  99 binding altogether.
 100
 101 2.  Conditional.  In all other situations, the simplifer simplifies
 102 the RHS anyway, and keeps the new binding.  It also binds the new
 103 (cloned) variable to a ``suitable'' UnfoldingDetails in the UnfoldEnv.
 104
 105 Here, ``suitable'' might mean NoUnfoldingDetails (if the occurrence
 106 info is ManyOcc and the RHS is not a manifest HNF, or UnfoldAlways (if
 107 the variable has an INLINE pragma on it).  The idea is that anything
 108 in the UnfoldEnv is safe to use, but also has an enclosing binding if
 109 you decide not to use it.
 110
 111 Head normal forms
 112 ~~~~~~~~~~~~~~~~~
 113 We *never* put a non-HNF unfolding in the UnfoldEnv except in the
 114 INLINE-pragma case.
 115
 116 At one time I thought it would be OK to put non-HNF unfoldings in for
 117 variables which occur only once [if they got inlined at that
 118 occurrence the RHS of the binding would become dead, so no duplication
 119 would occur].   But consider:
 120 @
 121         let x = <expensive>
 122             f = \y -> ...y...y...y...
 123         in f x
 124 @
 125 Now, it seems that @x@ appears only once, but even so it is NOT safe to put @x@
 126 in the UnfoldEnv, because @f@ will be inlined, and will duplicate the references to
 127 @x@.
 128
 129 Becuase of this, the "unconditional-inline" mechanism above is the only way
 130 in which non-HNFs can get inlined.
 131
 132 INLINE pragmas
 133 ~~~~~~~~~~~~~~
 134
 135 When a variable has an INLINE pragma on it --- which includes wrappers
 136 produced by the strictness analyser --- we treat it rather carefully.
 137
 138 For a start, we are careful not to substitute into its RHS, because
 139 that might make it BIG, and the user said "inline exactly this", not
 140 "inline whatever you get after inlining other stuff inside me".  For
 141 example
 142
 143         let f = BIG
 144         in {-# INLINE y #-} y = f 3
 145         in ...y...y...
 146
 147 Here we don't want to substitute BIG for the (single) occurrence of f,
 148 because then we'd duplicate BIG when we inline'd y.  (Exception:
 149 things in the UnfoldEnv with UnfoldAlways flags, which originated in
 150 other INLINE pragmas.)
 151
 152 So, we clean out the UnfoldEnv of all GenForm inlinings before
 153 going into such an RHS.
 154
 155 What about imports?  They don't really matter much because we only
 156 inline relatively small things via imports.
 157
 158 We augment the the UnfoldEnv with UnfoldAlways guidance if there's an
 159 INLINE pragma.  We also do this for the RHSs of recursive decls,
 160 before looking at the recursive decls. That way we achieve the effect
 161 of inlining a wrapper in the body of its worker, in the case of a
 162 mutually-recursive worker/wrapper split.
 163
 164
 165 %************************************************************************
 166 %*                                                                      *
 167 \subsection[Simplify-simplExpr]{The main function: simplExpr}
 168 %*                                                                      *
 169 %************************************************************************
 170
 171 At the top level things are a little different.
 172
 173   * No cloning (not allowed for exported Ids, unnecessary for the others)
 174
 175   * No floating.   Case floating is obviously out.  Let floating is
 176         theoretically OK, but dangerous because of space leaks.
 177         The long-distance let-floater lifts these lets.
 178
 179 \begin{code}
 180 simplTopBinds :: SimplEnv -> [InBinding] -> SmplM [OutBinding]
 181
 182 simplTopBinds env [] = returnSmpl []
 183
 184 -- Dead code is now discarded by the occurrence analyser,
 185
 186 simplTopBinds env (NonRec binder@(in_id, occ_info) rhs : binds)
 187   | inlineUnconditionally ok_to_dup_code occ_info
 188   = --pprTrace "simplTopBinds (inline):" (ppr PprDebug in_id) (
 189     let
 190         new_env = extendIdEnvWithInlining env env binder rhs
 191     in
 192     simplTopBinds new_env binds
 193     --)
 194   where
 195     ok_to_dup_code = switchIsSet env SimplOkToDupCode
 196
 197 simplTopBinds env (NonRec binder@(in_id,occ_info) rhs : binds)
 198   =     -- No cloning necessary at top level
 199         -- Process the binding
 200     simplRhsExpr env binder rhs         `thenSmpl` \ rhs' ->
 201     let
 202        new_env = case rhs' of
 203          Var var                          -> extendIdEnvWithAtom env binder (VarArg var)
 204          Lit lit | not (isNoRepLit lit) -> extendIdEnvWithAtom env binder (LitArg lit)
 205          other                            -> extendUnfoldEnvGivenRhs env binder in_id rhs'
 206     in
 207     --pprTrace "simplTopBinds (nonrec):" (ppCat [ppr PprDebug in_id, ppr PprDebug rhs']) (
 208
 209         -- Process the other bindings
 210     simplTopBinds new_env binds `thenSmpl` \ binds' ->
 211
 212         -- Glue together and return ...
 213         -- We leave it to susequent occurrence analysis to throw away
 214         -- an unused atom binding. This localises the decision about
 215         -- discarding top-level bindings.
 216     returnSmpl (NonRec in_id rhs' : binds')
 217     --)
 218
 219 simplTopBinds env (Rec pairs : binds)
 220   = simplRecursiveGroup env triples     `thenSmpl` \ (bind', new_env) ->
 221
 222     --pprTrace "simplTopBinds (rec):" (ppCat [ppr PprDebug bind']) (
 223
 224         -- Process the other bindings
 225     simplTopBinds new_env binds         `thenSmpl` \ binds' ->
 226
 227         -- Glue together and return
 228     returnSmpl (bind' : binds')
 229     --)
 230   where
 231     triples = [(id, (binder, rhs)) | (binder@(id,_), rhs) <- pairs]
 232                 -- No cloning necessary at top level
 233 \end{code}
 234
 235 %************************************************************************
 236 %*                                                                      *
 237 \subsection[Simplify-simplExpr]{The main function: simplExpr}
 238 %*                                                                      *
 239 %************************************************************************
 240
 241
 242 \begin{code}
 243 simplExpr :: SimplEnv
 244           -> InExpr -> [OutArg]
 245           -> SmplM OutExpr
 246 \end{code}
 247
 248 The expression returned has the same meaning as the input expression
 249 applied to the specified arguments.
 250
 251
 252 Variables
 253 ~~~~~~~~~
 254 Check if there's a macro-expansion, and if so rattle on.  Otherwise
 255 do the more sophisticated stuff.
 256
 257 \begin{code}
 258 simplExpr env (Var v) args
 259   = --pprTrace "simplExpr:Var:" (ppr PprDebug v) (
 260     case lookupId env v of
 261       Nothing -> let
 262                         new_v = simplTyInId env v
 263                  in
 264                  completeVar env new_v args
 265
 266       Just info ->
 267         case info of
 268           ItsAnAtom (LitArg lit)        -- A boring old literal
 269                         -- Paranoia check for args empty
 270             ->  case args of
 271                   []    -> returnSmpl (Lit lit)
 272                   other -> panic "simplExpr:coVar"
 273
 274           ItsAnAtom (VarArg var)        -- More interesting!  An id!
 275                                         -- No need to substitute the type env here,
 276                                         -- because we already have!
 277             -> completeVar env var args
 278
 279           InlineIt id_env ty_env in_expr        -- A macro-expansion
 280             -> simplExpr (replaceInEnvs env (ty_env, id_env)) in_expr args
 281     --)
 282 \end{code}
 283
 284 Literals
 285 ~~~~~~~~~
 286
 287 \begin{code}
 288 simplExpr env (Lit l) [] = returnSmpl (Lit l)
 289 simplExpr env (Lit l) _  = panic "simplExpr:Lit with argument"
 290 \end{code}
 291
 292 Primitive applications are simple.
 293 ~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~
 294
 295 NB: Prim expects an empty argument list! (Because it should be
 296 saturated and not higher-order. ADR)
 297
 298 \begin{code}
 299 simplExpr env (Prim op tys prim_args) args
 300   = ASSERT (null args)
 301     let
 302         tys'       = [simplTy   env ty       | ty       <- tys]
 303         prim_args' = [simplAtom env prim_arg | prim_arg <- prim_args]
 304         op'        = simpl_op op
 305     in
 306     completePrim env op' tys' prim_args'
 307   where
 308     -- PrimOps just need any types in them renamed.
 309
 310     simpl_op (CCallOp label is_asm may_gc arg_tys result_ty)
 311       = let
 312             arg_tys'    = map (simplTy env) arg_tys
 313             result_ty'  = simplTy env result_ty
 314         in
 315         CCallOp label is_asm may_gc arg_tys' result_ty'
 316
 317     simpl_op other_op = other_op
 318 \end{code}
 319
 320 Constructor applications
 321 ~~~~~~~~~~~~~~~~~~~~~~~~
 322 Nothing to try here.  We only reuse constructors when they appear as the
 323 rhs of a let binding (see completeLetBinding).
 324
 325 \begin{code}
 326 simplExpr env (Con con tys con_args) args
 327   = ASSERT( null args )
 328     returnSmpl (Con con tys' con_args')
 329   where
 330     con_args' = [simplAtom env con_arg | con_arg <- con_args]
 331     tys'      = [simplTy   env ty      | ty <- tys]
 332 \end{code}
 333
 334
 335 Applications are easy too:
 336 ~~~~~~~~~~~~~~~~~~~~~~~~~~
 337 Just stuff 'em in the arg stack
 338
 339 \begin{code}
 340 simplExpr env (App fun arg) args
 341   = simplExpr env fun (ValArg (simplAtom env arg) : args)
 342
 343 simplExpr env (CoTyApp fun ty) args
 344   = simplExpr env fun (TypeArg (simplTy env ty) : args)
 345 \end{code}
 346
 347 Type lambdas
 348 ~~~~~~~~~~~~
 349
 350 We only eta-reduce a type lambda if all type arguments in the body can
 351 be eta-reduced. This requires us to collect up all tyvar parameters so
 352 we can pass them all to @mkCoTyLamTryingEta@.
 353
 354 \begin{code}
 355 simplExpr env (CoTyLam tyvar body) (TypeArg ty : args)
 356   = -- ASSERT(not (isPrimType ty))
 357     let
 358         new_env = extendTyEnv env tyvar ty
 359     in
 360     tick TyBetaReduction        `thenSmpl_`
 361     simplExpr new_env body args
 362
 363 simplExpr env tylam@(CoTyLam tyvar body) []
 364   = do_tylambdas env [] tylam
 365   where
 366     do_tylambdas env tyvars' (CoTyLam tyvar body)
 367       =   -- Clone the type variable
 368         cloneTyVarSmpl tyvar            `thenSmpl` \ tyvar' ->
 369         let
 370             new_env = extendTyEnv env tyvar (mkTyVarTy tyvar')
 371         in
 372         do_tylambdas new_env (tyvar':tyvars') body
 373
 374     do_tylambdas env tyvars' body
 375       = simplExpr env body []           `thenSmpl` \ body' ->
 376         returnSmpl (
 377            (if switchIsSet env SimplDoEtaReduction
 378            then mkCoTyLamTryingEta
 379            else mkCoTyLam) (reverse tyvars')  body'
 380         )
 381
 382 simplExpr env (CoTyLam tyvar body) (ValArg _ : _)
 383   = panic "simplExpr:CoTyLam ValArg"
 384 \end{code}
 385
 386
 387 Ordinary lambdas
 388 ~~~~~~~~~~~~~~~~
 389
 390 \begin{code}
 391 simplExpr env (Lam binder body) args
 392   | null leftover_binders
 393   =     -- The lambda is saturated (or over-saturated)
 394     tick BetaReduction  `thenSmpl_`
 395     simplExpr env_for_enough_args body leftover_args
 396
 397   | otherwise
 398   =     -- Too few args to saturate the lambda
 399     ASSERT( null leftover_args )
 400
 401     (if not (null args) -- ah, we must've gotten rid of some...
 402      then tick BetaReduction
 403      else returnSmpl (panic "BetaReduction")
 404     ) `thenSmpl_`
 405
 406     simplLam env_for_too_few_args leftover_binders body
 407              0 {- Guaranteed applied to at least 0 args! -}
 408
 409   where
 410     (binder_args_pairs, leftover_binders, leftover_args) = collect_val_args [binder] args
 411
 412     env_for_enough_args  = extendIdEnvWithAtomList env binder_args_pairs
 413
 414     env_for_too_few_args = extendIdEnvWithAtomList env zapped_binder_args_pairs
 415
 416         -- Since there aren't enough args the binders we are cancelling with
 417         -- the args supplied are, in effect, ocurring inside a lambda.
 418         -- So we modify their occurrence info to reflect this fact.
 419         -- Example:     (\ x y z -> e) p q
 420         --          ==> (\z -> e[p/x, q/y])
 421         --      but we should behave as if x and y are marked "inside lambda".
 422         -- The occurrence analyser does not mark them so itself because then we
 423         -- do badly on the very common case of saturated lambdas applications:
 424         --              (\ x y z -> e) p q r
 425         --          ==> e[p/x, q/y, r/z]
 426         --
 427     zapped_binder_args_pairs = [ ((id, markDangerousToDup occ_info), arg)
 428                                | ((id, occ_info), arg) <- binder_args_pairs ]
 429
 430     collect_val_args :: [InBinder]      -- Binders
 431                      -> [OutArg]        -- Arguments
 432                      -> ([(InBinder,OutAtom)],  -- Binder,arg pairs
 433                           [InBinder],           -- Leftover binders
 434                           [OutArg])             -- Leftover args
 435
 436         -- collect_val_args strips off the leading ValArgs from
 437         -- the current arg list, returning them along with the
 438         -- depleted list
 439     collect_val_args []      args = ([], [], args)
 440     collect_val_args binders []   = ([], binders, [])
 441     collect_val_args (binder:binders) (ValArg val_arg : args)
 442         = ((binder,val_arg):rest_pairs, leftover_binders, leftover_args)
 443         where
 444           (rest_pairs, leftover_binders, leftover_args) = collect_val_args binders args
 445
 446     collect_val_args (binder:binders) (other_val_arg : args) = panic "collect_val_args"
 447                 -- TypeArg should never meet a Lam
 448 \end{code}
 449
 450
 451 Let expressions
 452 ~~~~~~~~~~~~~~~
 453
 454 \begin{code}
 455 simplExpr env (Let bind body) args
 456   | not (switchIsSet env SimplNoLetFromApp)             -- The common case
 457   = simplBind env bind (\env -> simplExpr env body args)
 458                        (computeResultType env body args)
 459
 460   | otherwise           -- No float from application
 461   = simplBind env bind (\env -> simplExpr env body [])
 462                        (computeResultType env body [])  `thenSmpl` \ let_expr' ->
 463     returnSmpl (mkGenApp let_expr' args)
 464 \end{code}
 465
 466 Case expressions
 467 ~~~~~~~~~~~~~~~~
 468
 469 \begin{code}
 470 simplExpr env expr@(Case scrut alts) args
 471   = simplCase env scrut alts (\env rhs -> simplExpr env rhs args)
 472                              (computeResultType env expr args)
 473 \end{code}
 474
 475
 476 Set-cost-centre
 477 ~~~~~~~~~~~~~~~
 478
 479 A special case we do:
 480 \begin{verbatim}
 481         scc "foo" (\x -> e)  ===>   \x -> scc "foo" e
 482 \end{verbatim}
 483 Simon thinks it's OK, at least for lexical scoping; and it makes
 484 interfaces change less (arities).
 485
 486 \begin{code}
 487 simplExpr env (SCC cc (Lam binder body)) args
 488   = simplExpr env (Lam binder (SCC cc body)) args
 489
 490 simplExpr env (SCC cc (CoTyLam tyvar body)) args
 491   = simplExpr env (CoTyLam tyvar (SCC cc body)) args
 492 \end{code}
 493
 494 Some other slightly turgid SCC tidying-up cases:
 495 \begin{code}
 496 simplExpr env (SCC cc1 expr@(SCC _ _)) args
 497   = simplExpr env expr args
 498     -- the outer _scc_ serves no purpose
 499
 500 simplExpr env (SCC cc expr) args
 501   | squashableDictishCcExpr cc expr
 502   = simplExpr env expr args
 503     -- the DICT-ish CC is no longer serving any purpose
 504 \end{code}
 505
 506 NB: for other set-cost-centre we move arguments inside the body.
 507 ToDo: check with Patrick that this is ok.
 508
 509 \begin{code}
 510 simplExpr env (SCC cost_centre body) args
 511   = let
 512         new_env = setEnclosingCC env (EnclosingCC cost_centre)
 513     in
 514     simplExpr new_env body args         `thenSmpl` \ body' ->
 515     returnSmpl (SCC cost_centre body')
 516 \end{code}
 517
 518 %************************************************************************
 519 %*                                                                      *
 520 \subsection{Simplify RHS of a Let/Letrec}
 521 %*                                                                      *
 522 %************************************************************************
 523
 524 simplRhsExpr does arity-expansion.  That is, given:
 525
 526         * a right hand side /\ tyvars -> \a1 ... an -> e
 527         * the information (stored in BinderInfo) that the function will always
 528           be applied to at least k arguments
 529
 530 it transforms the rhs to
 531
 532         /\tyvars -> \a1 ... an b(n+1) ... bk -> (e b(n+1) ... bk)
 533
 534 This is a Very Good Thing!
 535
 536 \begin{code}
 537 simplRhsExpr
 538         :: SimplEnv
 539         -> InBinder
 540         -> InExpr
 541         -> SmplM OutExpr
 542
 543 simplRhsExpr env binder@(id,occ_info) rhs
 544   | dont_eta_expand rhs
 545   = simplExpr rhs_env rhs []
 546
 547   | otherwise   -- Have a go at eta expansion
 548   =     -- Deal with the big lambda part
 549     mapSmpl cloneTyVarSmpl tyvars                       `thenSmpl` \ tyvars' ->
 550     let
 551         lam_env  = extendTyEnvList rhs_env (tyvars `zip` (map mkTyVarTy tyvars'))
 552     in
 553         -- Deal with the little lambda part
 554         -- Note that we call simplLam even if there are no binders, in case
 555         -- it can do arity expansion.
 556     simplLam lam_env binders body min_no_of_args        `thenSmpl` \ lambda' ->
 557
 558         -- Put it back together
 559     returnSmpl (
 560        (if switchIsSet env SimplDoEtaReduction
 561        then mkCoTyLamTryingEta
 562        else mkCoTyLam) tyvars' lambda'
 563     )
 564   where
 565         -- Note from ANDY:
 566         -- If you say {-# INLINE #-} then you get what's coming to you;
 567         -- you are saying inline the rhs, please.
 568         -- we might want a {-# INLINE UNSIMPLIFIED #-} option.
 569     rhs_env | simplIdWantsToBeINLINEd id env = filterUnfoldEnvForInlines env
 570             | otherwise                      = env
 571
 572     (uvars, tyvars, binders, body) = digForLambdas rhs
 573
 574     min_no_of_args | not (null binders)                 &&      -- It's not a thunk
 575                      switchIsSet env SimplDoArityExpand         -- Arity expansion on
 576                    = getBinderInfoArity occ_info - length binders
 577
 578                    | otherwise  -- Not a thunk
 579                    = 0          -- Play safe!
 580
 581         -- dont_eta_expand prevents eta expansion in silly situations.
 582         -- For example, consider the defn
 583         --      x = y
 584         -- It would be silly to eta expand the "y", because it would just
 585         -- get eta-reduced back to y.  Furthermore, if this was a top level defn,
 586         -- and x was exported, then the defn won't be eliminated, so this
 587         -- silly expand/reduce cycle will happen every time, which makes the
 588         -- simplifier loop!.
 589         -- The solution is to not even try eta expansion unless the rhs looks
 590         -- non-trivial.
 591     dont_eta_expand (Lit _)     = True
 592     dont_eta_expand (Var _)     = True
 593     dont_eta_expand (CoTyApp f _) = dont_eta_expand f
 594     dont_eta_expand (CoTyLam _ b) = dont_eta_expand b
 595     dont_eta_expand (Con _ _ _) = True
 596     dont_eta_expand _             = False
 597 \end{code}
 598
 599
 600 %************************************************************************
 601 %*                                                                      *
 602 \subsection{Simplify a lambda abstraction}
 603 %*                                                                      *
 604 %************************************************************************
 605
 606 Simplify (\binders -> body) trying eta expansion and reduction, given that
 607 the abstraction will always be applied to at least min_no_of_args.
 608
 609 \begin{code}
 610 simplLam env binders body min_no_of_args
 611   | not (switchIsSet env SimplDoLambdaEtaExpansion) ||  -- Bale out if eta expansion off
 612     null potential_extra_binder_tys                 ||  -- or ain't a function
 613     no_of_extra_binders == 0                            -- or no extra binders needed
 614   = cloneIds env binders                `thenSmpl` \ binders' ->
 615     let
 616         new_env = extendIdEnvWithClones env binders binders'
 617     in
 618     simplExpr new_env body []           `thenSmpl` \ body' ->
 619     returnSmpl (
 620       (if switchIsSet new_env SimplDoEtaReduction
 621        then mkCoLamTryingEta
 622        else mkValLam) binders' body'
 623     )
 624
 625   | otherwise                           -- Eta expansion possible
 626   = tick EtaExpansion                   `thenSmpl_`
 627     cloneIds env binders                `thenSmpl` \ binders' ->
 628     let
 629         new_env = extendIdEnvWithClones env binders binders'
 630     in
 631     newIds extra_binder_tys                                             `thenSmpl` \ extra_binders' ->
 632     simplExpr new_env body (map (ValArg.VarArg) extra_binders') `thenSmpl` \ body' ->
 633     returnSmpl (
 634       (if switchIsSet new_env SimplDoEtaReduction
 635        then mkCoLamTryingEta
 636        else mkValLam) (binders' ++ extra_binders') body'
 637     )
 638
 639   where
 640     (potential_extra_binder_tys, res_ty)
 641         = splitTyArgs (simplTy env (coreExprType (unTagBinders body)))
 642         -- Note: it's possible that simplLam will be applied to something
 643         -- with a forall type.  Eg when being applied to the rhs of
 644         --              let x = wurble
 645         -- where wurble has a forall-type, but no big lambdas at the top.
 646         -- We could be clever an insert new big lambdas, but we don't bother.
 647
 648     extra_binder_tys = take no_of_extra_binders potential_extra_binder_tys
 649
 650     no_of_extra_binders =       -- First, use the info about how many args it's
 651                                 -- always applied to in its scope
 652                            min_no_of_args
 653
 654                                 -- Next, try seeing if there's a lambda hidden inside
 655                                 -- something cheap
 656                            `max`
 657                            etaExpandCount body
 658
 659                                 -- Finally, see if it's a state transformer, in which
 660                                 -- case we eta-expand on principle! This can waste work,
 661                                 -- but usually doesn't
 662                            `max`
 663                            case potential_extra_binder_tys of
 664                                 [ty] | ty == realWorldStateTy -> 1
 665                                 other                         -> 0
 666
 667 \end{code}
 668
 669
 670 %************************************************************************
 671 %*                                                                      *
 672 \subsection[Simplify-let]{Let-expressions}
 673 %*                                                                      *
 674 %************************************************************************
 675
 676 \begin{code}
 677 simplBind :: SimplEnv
 678           -> InBinding
 679           -> (SimplEnv -> SmplM OutExpr)
 680           -> OutUniType
 681           -> SmplM OutExpr
 682 \end{code}
 683
 684 When floating cases out of lets, remember this:
 685
 686         let x* = case e of alts
 687         in <small expr>
 688
 689 where x* is sure to be demanded or e is a cheap operation that cannot
 690 fail, e.g. unboxed addition.  Here we should be prepared to duplicate
 691 <small expr>.  A good example:
 692
 693         let x* = case y of
 694                    p1 -> build e1
 695                    p2 -> build e2
 696         in
 697         foldr c n x*
 698 ==>
 699         case y of
 700           p1 -> foldr c n (build e1)
 701           p2 -> foldr c n (build e2)
 702
 703 NEW: We use the same machinery that we use for case-of-case to
 704 *always* do case floating from let, that is we let bind and abstract
 705 the original let body, and let the occurrence analyser later decide
 706 whether the new let should be inlined or not. The example above
 707 becomes:
 708
 709 ==>
 710       let join_body x' = foldr c n x'
 711         in case y of
 712         p1 -> let x* = build e1
 713                 in join_body x*
 714         p2 -> let x* = build e2
 715                 in join_body x*
 716
 717 note that join_body is a let-no-escape.
 718 In this particular example join_body will later be inlined,
 719 achieving the same effect.
 720 ToDo: check this is OK with andy
 721
 722
 723
 724 \begin{code}
 725 -- Dead code is now discarded by the occurrence analyser,
 726
 727 simplBind env (NonRec binder@(id,occ_info) rhs) body_c body_ty
 728   |  inlineUnconditionally ok_to_dup occ_info
 729   = body_c (extendIdEnvWithInlining env env binder rhs)
 730
 731 -- Try let-to-case
 732 -- It's important to try let-to-case before floating. Consider
 733 --
 734 --      let a*::Int = case v of {p1->e1; p2->e2}
 735 --      in b
 736 --
 737 -- (The * means that a is sure to be demanded.)
 738 -- If we do case-floating first we get this:
 739 --
 740 --      let k = \a* -> b
 741 --      in case v of
 742 --              p1-> let a*=e1 in k a
 743 --              p2-> let a*=e2 in k a
 744 --
 745 -- Now watch what happens if we do let-to-case first:
 746 --
 747 --      case (case v of {p1->e1; p2->e2}) of
 748 --        Int a# -> let a*=I# a# in b
 749 -- ===>
 750 --      let k = \a# -> let a*=I# a# in b
 751 --      in case v of
 752 --              p1 -> case e1 of I# a# -> k a#
 753 --              p1 -> case e1 of I# a# -> k a#
 754 --
 755 -- The latter is clearly better.  (Remember the reboxing let-decl
 756 -- for a is likely to go away, because after all b is strict in a.)
 757
 758   | will_be_demanded &&
 759     try_let_to_case &&
 760     type_ok_for_let_to_case rhs_ty &&
 761     not (manifestlyWHNF rhs)
 762         -- note: no "manifestlyBottom rhs" in there... (comment below)
 763     = tick Let2Case                             `thenSmpl_`
 764       mkIdentityAlts rhs_ty                     `thenSmpl` \ id_alts ->
 765       simplCase env rhs id_alts (\env rhs -> done_float env rhs body_c) body_ty
 766         {-
 767         We do not do let to case for WHNFs, e.g.
 768
 769           let x = a:b in ...
 770           =/=>
 771           case a:b of x in ...
 772
 773           as this is less efficient.
 774           but we don't mind doing let-to-case for "bottom", as that
 775           will
 776           allow us to remove more dead code, if anything:
 777           let x = error in ...
 778           ===>
 779           case error  of x -> ...
 780           ===>
 781           error
 782
 783           Notice that let to case occurs only if x is used strictly in
 784           its body (obviously).
 785         -}
 786
 787   | (will_be_demanded && not no_float) ||
 788     always_float_let_from_let ||
 789     floatExposesHNF float_lets float_primops ok_to_dup rhs
 790   = try_float env rhs body_c
 791
 792   | otherwise
 793   = done_float env rhs body_c
 794
 795   where
 796     will_be_demanded = willBeDemanded (getIdDemandInfo id)
 797     rhs_ty           = idType id
 798
 799     float_lets                = switchIsSet env SimplFloatLetsExposingWHNF
 800     float_primops             = switchIsSet env SimplOkToFloatPrimOps
 801     ok_to_dup                 = switchIsSet env SimplOkToDupCode
 802     always_float_let_from_let = switchIsSet env SimplAlwaysFloatLetsFromLets
 803     try_let_to_case           = switchIsSet env SimplLetToCase
 804     no_float                  = switchIsSet env SimplNoLetFromStrictLet
 805
 806     -------------------------------------------
 807     done_float env rhs body_c
 808         = simplRhsExpr env binder rhs   `thenSmpl` \ rhs' ->
 809           completeLet env binder rhs rhs' body_c body_ty
 810
 811     ---------------------------------------
 812     try_float env (Let bind rhs) body_c
 813       = tick LetFloatFromLet                    `thenSmpl_`
 814         simplBind env (fix_up_demandedness will_be_demanded bind)
 815                       (\env -> try_float env rhs body_c) body_ty
 816
 817     try_float env (Case scrut alts) body_c
 818       | will_be_demanded || (float_primops && is_cheap_prim_app scrut)
 819       = tick CaseFloatFromLet                           `thenSmpl_`
 820
 821         -- First, bind large let-body if necessary
 822         if no_need_to_bind_large_body then
 823             simplCase env scrut alts (\env rhs -> try_float env rhs body_c) body_ty
 824         else
 825             bindLargeRhs env [binder] body_ty body_c    `thenSmpl` \ (extra_binding, new_body) ->
 826             let
 827                 body_c' = \env -> simplExpr env new_body []
 828             in
 829             simplCase env scrut alts
 830                       (\env rhs -> try_float env rhs body_c')
 831                       body_ty                           `thenSmpl` \ case_expr ->
 832
 833             returnSmpl (Let extra_binding case_expr)
 834       where
 835         no_need_to_bind_large_body
 836           = ok_to_dup || isSingleton (nonErrorRHSs alts)
 837
 838     try_float env other_rhs body_c = done_float env other_rhs body_c
 839 \end{code}
 840
 841 Letrec expressions
 842 ~~~~~~~~~~~~~~~~~~
 843
 844 Simplify each RHS, float any let(recs) from the RHSs (if let-floating is
 845 on and it'll expose a HNF), and bang the whole resulting mess together
 846 into a huge letrec.
 847
 848 1. Any "macros" should be expanded.  The main application of this
 849 macro-expansion is:
 850
 851         letrec
 852                 f = ....g...
 853                 g = ....f...
 854         in
 855         ....f...
 856
 857 Here we would like the single call to g to be inlined.
 858
 859 We can spot this easily, because g will be tagged as having just one
 860 occurrence.  The "inlineUnconditionally" predicate is just what we want.
 861
 862 A worry: could this lead to non-termination?  For example:
 863
 864         letrec
 865                 f = ...g...
 866                 g = ...f...
 867                 h = ...h...
 868         in
 869         ..h..
 870
 871 Here, f and g call each other (just once) and neither is used elsewhere.
 872 But it's OK:
 873
 874 * the occurrence analyser will drop any (sub)-group that isn't used at
 875   all.
 876
 877 * If the group is used outside itself (ie in the "in" part), then there
 878   can't be a cyle.
 879
 880 ** IMPORTANT: check that NewOccAnal has the property that a group of
 881    bindings like the above has f&g dropped.! ***
 882
 883
 884 2. We'd also like to pull out any top-level let(rec)s from the
 885 rhs of the defns:
 886
 887         letrec
 888                 f = let h = ... in \x -> ....h...f...h...
 889         in
 890         ...f...
 891 ====>
 892         letrec
 893                 h = ...
 894                 f = \x -> ....h...f...h...
 895         in
 896         ...f...
 897
 898 But floating cases is less easy?  (Don't for now; ToDo?)
 899
 900
 901 3.  We'd like to arrange that the RHSs "know" about members of the
 902 group that are bound to constructors.  For example:
 903
 904     let rec
 905        d.Eq      = (==,/=)
 906        f a b c d = case d.Eq of (h,_) -> let x = (a,b); y = (c,d) in not (h x y)
 907        /= a b    = unpack tuple a, unpack tuple b, call f
 908     in d.Eq
 909
 910 here, by knowing about d.Eq in f's rhs, one could get rid of
 911 the case (and break out the recursion completely).
 912 [This occurred with more aggressive inlining threshold (4),
 913 nofib/spectral/knights]
 914
 915 How to do it?
 916         1: we simplify constructor rhss first.
 917         2: we record the "known constructors" in the environment
 918         3: we simplify the other rhss, with the knowledge about the constructors
 919
 920
 921
 922 \begin{code}
 923 simplBind env (Rec pairs) body_c body_ty
 924   =     -- Do floating, if necessary
 925     (if float_lets || always_float_let_from_let
 926      then
 927         mapSmpl float pairs     `thenSmpl` \ floated_pairs_s ->
 928         returnSmpl (concat floated_pairs_s)
 929      else
 930         returnSmpl pairs
 931     )                                   `thenSmpl` \ floated_pairs ->
 932     let
 933         binders = map fst floated_pairs
 934     in
 935     cloneIds env binders                `thenSmpl` \ ids' ->
 936     let
 937         env_w_clones = extendIdEnvWithClones env binders ids'
 938         triples      = ids' `zip` floated_pairs
 939     in
 940
 941     simplRecursiveGroup env_w_clones triples    `thenSmpl` \ (binding, new_env) ->
 942
 943     body_c new_env                              `thenSmpl` \ body' ->
 944
 945     returnSmpl (Let binding body')
 946
 947   where
 948     ------------ Floating stuff -------------------
 949
 950     float_lets                = switchIsSet env SimplFloatLetsExposingWHNF
 951     always_float_let_from_let = switchIsSet env SimplAlwaysFloatLetsFromLets
 952
 953     float (binder,rhs)
 954       = let
 955             pairs_s = float_pair (binder,rhs)
 956         in
 957         case pairs_s of
 958           [_] -> returnSmpl pairs_s
 959           more_than_one
 960             -> tickN LetFloatFromLet (length pairs_s - 1) `thenSmpl_`
 961                 -- It's important to increment the tick counts if we
 962                 -- do any floating.  A situation where this turns out
 963                 -- to be important is this:
 964                 -- Float in produces:
 965                 --      letrec  x = let y = Ey in Ex
 966                 --      in B
 967                 -- Now floating gives this:
 968                 --      letrec x = Ex
 969                 --             y = Ey
 970                 --      in B
 971                 --- We now want to iterate once more in case Ey doesn't
 972                 -- mention x, in which case the y binding can be pulled
 973                 -- out as an enclosing let(rec), which in turn gives
 974                 -- the strictness analyser more chance.
 975                 returnSmpl pairs_s
 976
 977     float_pairs pairs = concat (map float_pair pairs)
 978
 979     float_pair (binder, rhs)
 980         | always_float_let_from_let ||
 981           floatExposesHNF True False False rhs
 982         = (binder,rhs') : pairs'
 983
 984         | otherwise
 985         = [(binder,rhs)]
 986         where
 987           (pairs', rhs') = do_float rhs
 988
 989         -- Float just pulls out any top-level let(rec) bindings
 990     do_float :: InExpr -> ([(InBinder,InExpr)], InExpr)
 991     do_float (Let (Rec pairs) body)     = (float_pairs pairs    ++ pairs', body')
 992                                             where
 993                                               (pairs', body') = do_float body
 994     do_float (Let (NonRec id rhs) body) = (float_pair (id,rhs) ++ pairs', body')
 995                                             where
 996                                               (pairs', body') = do_float body
 997     do_float other                          = ([], other)
 998
 999 simplRecursiveGroup env triples
1000   =     -- Toss out all the dead pairs?  No, there shouldn't be any!
1001         -- Dead code is discarded by the occurrence analyser
1002     let
1003             -- Separate the live triples into "inline"able and
1004             -- "ordinary" We're paranoid about duplication!
1005         (inline_triples, ordinary_triples)
1006           = partition is_inline_triple triples
1007
1008         is_inline_triple (_, ((_,occ_info),_))
1009           = inlineUnconditionally False {-not ok_to_dup-} occ_info
1010
1011             -- Now add in the inline_pairs info (using "env_w_clones"),
1012             -- so that we will save away suitably-clone-laden envs
1013             -- inside the InlineIts...).
1014
1015             -- NOTE ALSO that we tie a knot here, because the
1016             -- saved-away envs must also include these very inlinings
1017             -- (they aren't stored anywhere else, and a late one might
1018             -- be used in an early one).
1019
1020         env_w_inlinings = foldl add_inline env inline_triples
1021
1022         add_inline env (id', (binder,rhs))
1023           = extendIdEnvWithInlining env env_w_inlinings binder rhs
1024
1025             -- Separate the remaining bindings into the ones which
1026             -- need to be dealt with first (the "early" ones)
1027             -- and the others (the "late" ones)
1028         (early_triples, late_triples)
1029           = partition is_early_triple ordinary_triples
1030
1031         is_early_triple (_, (_, Con _ _ _)) = True
1032         is_early_triple (i, _               ) = idWantsToBeINLINEd i
1033     in
1034         -- Process the early bindings first
1035     mapSmpl (do_one_binding env_w_inlinings) early_triples      `thenSmpl` \ early_triples' ->
1036
1037         -- Now further extend the environment to record our knowledge
1038         -- about the form of the binders bound in the constructor bindings
1039     let
1040         env_w_early_info = foldr add_early_info env_w_inlinings early_triples'
1041         add_early_info (binder, (id', rhs')) env = extendUnfoldEnvGivenRhs env binder id' rhs'
1042     in
1043         -- Now process the non-constructor bindings
1044     mapSmpl (do_one_binding env_w_early_info) late_triples      `thenSmpl` \ late_triples' ->
1045
1046         -- Phew! We're done
1047     let
1048         binding = Rec (map snd early_triples' ++ map snd late_triples')
1049     in
1050     returnSmpl (binding, env_w_early_info)
1051   where
1052
1053     do_one_binding env (id', (binder,rhs))
1054       = simplRhsExpr env binder rhs `thenSmpl` \ rhs' ->
1055         returnSmpl (binder, (id', rhs'))
1056 \end{code}
1057
1058
1059 @completeLet@ looks at the simplified post-floating RHS of the
1060 let-expression, and decides what to do.  There's one interesting
1061 aspect to this, namely constructor reuse.  Consider
1062 @
1063         f = \x -> case x of
1064                     (y:ys) -> y:ys
1065                     []     -> ...
1066 @
1067 Is it a good idea to replace the rhs @y:ys@ with @x@?  This depends a
1068 bit on the compiler technology, but in general I believe not. For
1069 example, here's some code from a real program:
1070 @
1071 const.Int.max.wrk{-s2516-} =
1072     \ upk.s3297#  upk.s3298# ->
1073         let {
1074           a.s3299 :: Int
1075           _N_ {-# U(P) #-}
1076           a.s3299 = I#! upk.s3297#
1077         } in
1078           case (const.Int._tagCmp.wrk{-s2513-} upk.s3297# upk.s3298#) of {
1079             _LT -> I#! upk.s3298#
1080             _EQ -> a.s3299
1081             _GT -> a.s3299
1082           }
1083 @
1084 The a.s3299 really isn't doing much good.  We'd be better off inlining
1085 it.  (Actually, let-no-escapery means it isn't as bad as it looks.)
1086
1087 So the current strategy is to inline all known-form constructors, and
1088 only do the reverse (turn a constructor application back into a
1089 variable) when we find a let-expression:
1090 @
1091         let x = C a1 .. an
1092         in
1093         ... (let y = C a1 .. an in ...) ...
1094 @
1095 where it is always good to ditch the binding for y, and replace y by
1096 x.  That's just what completeLetBinding does.
1097
1098 \begin{code}
1099 completeLet
1100         :: SimplEnv
1101         -> InBinder
1102         -> InExpr               -- Original RHS
1103         -> OutExpr              -- The simplified RHS
1104         -> (SimplEnv -> SmplM OutExpr)          -- Body handler
1105         -> OutUniType           -- Type of body
1106         -> SmplM OutExpr
1107
1108 completeLet env binder@(id,binder_info) old_rhs new_rhs body_c body_ty
1109
1110   -- See if RHS is an atom, or a reusable constructor
1111   | maybeToBool maybe_atomic_rhs
1112   = let
1113         new_env = extendIdEnvWithAtom env binder rhs_atom
1114     in
1115     tick atom_tick_type                 `thenSmpl_`
1116     body_c new_env
1117
1118   -- Maybe the rhs is an application of error, and sure to be demanded
1119   | will_be_demanded &&
1120     maybeToBool maybe_error_app
1121   = tick CaseOfError                    `thenSmpl_`
1122     returnSmpl retyped_error_app
1123
1124   -- The general case
1125   | otherwise
1126   = cloneId env binder                  `thenSmpl` \ id' ->
1127     let
1128         env1    = extendIdEnvWithClone env binder id'
1129         new_env = _scc_ "euegR2" (extendUnfoldEnvGivenRhs env1 binder id' new_rhs)
1130     in
1131     body_c new_env                      `thenSmpl` \ body' ->
1132     returnSmpl (Let (NonRec id' new_rhs) body')
1133
1134   where
1135     will_be_demanded = willBeDemanded (getIdDemandInfo id)
1136     try_to_reuse_constr   = switchIsSet env SimplReuseCon
1137
1138     Just (rhs_atom, atom_tick_type) = maybe_atomic_rhs
1139
1140     maybe_atomic_rhs :: Maybe (OutAtom, TickType)
1141         -- If the RHS is atomic, we return Just (atom, tick type)
1142         -- otherwise Nothing
1143
1144     maybe_atomic_rhs
1145       = case new_rhs of
1146           Var var -> Just (VarArg var, AtomicRhs)
1147
1148           Lit lit | not (isNoRepLit lit)
1149             -> Just (LitArg lit, AtomicRhs)
1150
1151           Con con tys con_args
1152             | try_to_reuse_constr
1153                    -- Look out for
1154                    --   let v = C args
1155                    --   in
1156                    --- ...(let w = C same-args in ...)...
1157                    -- Then use v instead of w.   This may save
1158                    -- re-constructing an existing constructor.
1159              -> case lookForConstructor env con tys con_args of
1160                   Nothing  -> Nothing
1161                   Just var -> Just (VarArg var, ConReused)
1162
1163           other -> Nothing
1164
1165     maybe_error_app        = maybeErrorApp new_rhs (Just body_ty)
1166     Just retyped_error_app = maybe_error_app
1167 \end{code}
1168
1169 %************************************************************************
1170 %*                                                                      *
1171 \subsection[Simplify-atoms]{Simplifying atoms}
1172 %*                                                                      *
1173 %************************************************************************
1174
1175 \begin{code}
1176 simplAtom :: SimplEnv -> InAtom -> OutAtom
1177
1178 simplAtom env (LitArg lit) = LitArg lit
1179
1180 simplAtom env (VarArg id)
1181   | isLocallyDefined id
1182   = case lookupId env id of
1183         Just (ItsAnAtom atom) -> atom
1184         Just (InlineIt _ _ _) -> pprPanic "simplAtom InLineIt:" (ppAbove (ppr PprDebug id) (pprSimplEnv env))
1185         Nothing               -> VarArg id      -- Must be an uncloned thing
1186
1187   | otherwise
1188   =     -- Not locally defined, so no change
1189     VarArg id
1190 \end{code}
1191
1192
1193 %************************************************************************
1194 %*                                                                      *
1195 \subsection[Simplify-quickies]{Some local help functions}
1196 %*                                                                      *
1197 %************************************************************************
1198
1199
1200 \begin{code}
1201 -- fix_up_demandedness switches off the willBeDemanded Info field
1202 -- for bindings floated out of a non-demanded let
1203 fix_up_demandedness True {- Will be demanded -} bind
1204    = bind       -- Simple; no change to demand info needed
1205 fix_up_demandedness False {- May not be demanded -} (NonRec binder rhs)
1206    = NonRec (un_demandify binder) rhs
1207 fix_up_demandedness False {- May not be demanded -} (Rec pairs)
1208    = Rec [(un_demandify binder, rhs) | (binder,rhs) <- pairs]
1209
1210 un_demandify (id, occ_info) = (id `addIdDemandInfo` noInfo, occ_info)
1211
1212 is_cheap_prim_app (Prim op tys args) = primOpOkForSpeculation op
1213 is_cheap_prim_app other                = False
1214
1215 computeResultType :: SimplEnv -> InExpr -> [OutArg] -> OutUniType
1216 computeResultType env expr args
1217   = do expr_ty' args
1218   where
1219     expr_ty  = coreExprType (unTagBinders expr)
1220     expr_ty' = simplTy env expr_ty
1221
1222     do ty [] = ty
1223     do ty (TypeArg ty_arg : args) = do (applyTy ty ty_arg) args
1224     do ty (ValArg a       : args) = case maybeUnpackFunTy ty of
1225                                       Just (_, res_ty) -> do res_ty args
1226                                       Nothing          -> panic "computeResultType"
1227 \end{code}
1228