Improve eta expansion (again)

The presenting issue was that we were never eta-expanding

    f (\x -> case x of (a,b) -> \s -> blah)

and that meant we were allocating two lambdas instead of one.
See Note [Eta expanding lambdas] in SimplUtils.

However I didn't want to eta expand the lambda, and then try all over
again for tryEtaExpandRhs.  Yet the latter is important in the context
of a let-binding it can do simple arity analysis.  So I ended up
refactoring CallCtxt so that it tells when we are on the RHS of a let.

I also moved findRhsArity from SimplUtils to CoreArity.

Performance increases nicely. Here are the ones where allocation improved
by more than 0.5%. Notice the nice decrease in binary size too.

--------------------------------------------------------------------------------
        Program           Size    Allocs   Runtime   Elapsed  TotalMem
--------------------------------------------------------------------------------
           ansi          -2.3%     -0.9%      0.00      0.00     +0.0%
           bspt          -2.1%     -9.7%      0.01      0.01    -33.3%
          fasta          -1.8%    -11.7%     -3.4%     -3.6%     +0.0%
            fft          -1.9%     -1.3%      0.06      0.06    +11.1%
reverse-complem          -1.9%    -18.1%     -1.9%     -2.8%     +0.0%
         sphere          -1.8%     -4.5%      0.09      0.09     +0.0%
      transform          -1.8%     -2.3%     -4.6%     -3.1%     +0.0%
--------------------------------------------------------------------------------
            Min          -3.0%    -18.1%    -13.9%    -14.6%    -35.7%
            Max          -1.3%     +0.0%     +7.7%     +7.7%    +50.0%
 Geometric Mean          -1.9%     -0.6%     -2.1%     -2.1%     -0.2%

4 files changed, 200 insertions, 150 deletions

diff --git a/compiler/coreSyn/CoreArity.lhs b/compiler/coreSyn/CoreArity.lhs
index d0fa106295..2c9a1375fb 100644
--- a/compiler/coreSyn/CoreArity.lhs
+++ b/compiler/coreSyn/CoreArity.lhs
@@ -16,7 +16,7 @@
 -- | Arit and eta expansion
 module CoreArity (
 	manifestArity, exprArity, exprBotStrictness_maybe,
-	exprEtaExpandArity, CheapFun, etaExpand
+	exprEtaExpandArity, findRhsArity, CheapFun, etaExpand
     ) where
 
 #include "HsVersions.h"
@@ -38,6 +38,7 @@ import DynFlags ( DynFlags, GeneralFlag(..), gopt )
 import Outputable
 import FastString
 import Pair
+import Util     ( debugIsOn )
 \end{code}
 
 %************************************************************************
@@ -490,25 +491,18 @@ vanillaArityType = ATop []	-- Totally uninformative
 
 -- ^ The Arity returned is the number of value args the
 -- expression can be applied to without doing much work
-exprEtaExpandArity :: DynFlags -> CheapAppFun -> CoreExpr -> Arity
+exprEtaExpandArity :: DynFlags -> CoreExpr -> Arity
 -- exprEtaExpandArity is used when eta expanding
 -- 	e  ==>  \xy -> e x y
-exprEtaExpandArity dflags cheap_app e
+exprEtaExpandArity dflags e
   = case (arityType env e) of
-      ATop (os:oss) 
-        | os || has_lam e -> 1 + length oss	-- Note [Eta expanding thunks]
-        | otherwise       -> 0
-      ATop []             -> 0
-      ABot n              -> n
+      ATop oss -> length oss
+      ABot n   -> n
   where
     env = AE { ae_bndrs    = []
-             , ae_cheap_fn = mk_cheap_fn dflags cheap_app
+             , ae_cheap_fn = mk_cheap_fn dflags isCheapApp
              , ae_ped_bot  = gopt Opt_PedanticBottoms dflags }
 
-    has_lam (Tick _ e) = has_lam e
-    has_lam (Lam b e)  = isId b || has_lam e
-    has_lam _          = False
-
 getBotArity :: ArityType -> Maybe Arity
 -- Arity of a divergent function
 getBotArity (ABot n) = Just n
@@ -523,8 +517,94 @@ mk_cheap_fn dflags cheap_app
              || case mb_ty of
                   Nothing -> False
                   Just ty -> isDictLikeTy ty
+
+
+----------------------
+findRhsArity :: DynFlags -> Id -> CoreExpr -> Arity -> Arity
+-- This implements the fixpoint loop for arity analysis
+-- See Note [Arity analysis]
+findRhsArity dflags bndr rhs old_arity
+  = go (rhsEtaExpandArity dflags init_cheap_app rhs)
+       -- We always call exprEtaExpandArity once, but usually
+       -- that produces a result equal to old_arity, and then
+       -- we stop right away (since arities should not decrease)
+       -- Result: the common case is that there is just one iteration
+  where
+    init_cheap_app :: CheapAppFun
+    init_cheap_app fn n_val_args
+      | fn == bndr = True   -- On the first pass, this binder gets infinite arity
+      | otherwise  = isCheapApp fn n_val_args
+
+    go :: Arity -> Arity
+    go cur_arity
+      | cur_arity <= old_arity = cur_arity
+      | new_arity == cur_arity = cur_arity
+      | otherwise = ASSERT( new_arity < cur_arity )
+#ifdef DEBUG
+                    pprTrace "Exciting arity"
+                       (vcat [ ppr bndr <+> ppr cur_arity <+> ppr new_arity
+                             , ppr rhs])
+#endif
+                    go new_arity
+      where
+        new_arity = rhsEtaExpandArity dflags cheap_app rhs
+
+        cheap_app :: CheapAppFun
+        cheap_app fn n_val_args
+          | fn == bndr = n_val_args < cur_arity
+          | otherwise  = isCheapApp fn n_val_args
+
+-- ^ The Arity returned is the number of value args the
+-- expression can be applied to without doing much work
+rhsEtaExpandArity :: DynFlags -> CheapAppFun -> CoreExpr -> Arity
+-- exprEtaExpandArity is used when eta expanding
+-- 	e  ==>  \xy -> e x y
+rhsEtaExpandArity dflags cheap_app e
+  = case (arityType env e) of
+      ATop (os:oss)
+        | os || has_lam e -> 1 + length oss  -- Don't expand PAPs/thunks
+                                             -- Note [Eta expanding thunks]
+        | otherwise       -> 0
+      ATop []             -> 0
+      ABot n              -> n
+  where
+    env = AE { ae_bndrs    = []
+             , ae_cheap_fn = mk_cheap_fn dflags cheap_app
+             , ae_ped_bot  = gopt Opt_PedanticBottoms dflags }
+
+    has_lam (Tick _ e) = has_lam e
+    has_lam (Lam b e)  = isId b || has_lam e
+    has_lam _          = False
 \end{code}
 
+Note [Arity analysis]
+~~~~~~~~~~~~~~~~~~~~~
+The motivating example for arity analysis is this:
+
+  f = \x. let g = f (x+1)
+          in \y. ...g...
+
+What arity does f have?  Really it should have arity 2, but a naive
+look at the RHS won't see that.  You need a fixpoint analysis which
+says it has arity "infinity" the first time round.
+
+This example happens a lot; it first showed up in Andy Gill's thesis,
+fifteen years ago!  It also shows up in the code for 'rnf' on lists
+in Trac #4138.
+
+The analysis is easy to achieve because exprEtaExpandArity takes an
+argument
+     type CheapFun = CoreExpr -> Maybe Type -> Bool
+used to decide if an expression is cheap enough to push inside a
+lambda.  And exprIsCheap' in turn takes an argument
+     type CheapAppFun = Id -> Int -> Bool
+which tells when an application is cheap. This makes it easy to
+write the analysis loop.
+
+The analysis is cheap-and-cheerful because it doesn't deal with
+mutual recursion.  But the self-recursive case is the important one.
+
+
 Note [Eta expanding through dictionaries]
 ~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~
 If the experimental -fdicts-cheap flag is on, we eta-expand through
@@ -549,6 +629,11 @@ isDictLikeTy here rather than isDictTy
 
 Note [Eta expanding thunks]
 ~~~~~~~~~~~~~~~~~~~~~~~~~~~
+We don't eta-expand
+   * Trivial RHSs     x = y
+   * PAPs             x = map g
+   * Thunks           f = case y of p -> \x -> blah
+
 When we see
      f = case y of p -> \x -> blah
 should we eta-expand it? Well, if 'x' is a one-shot state token 
diff --git a/compiler/coreSyn/CoreUnfold.lhs b/compiler/coreSyn/CoreUnfold.lhs
index 46ec56ab79..a219de8a8c 100644
--- a/compiler/coreSyn/CoreUnfold.lhs
+++ b/compiler/coreSyn/CoreUnfold.lhs
@@ -25,7 +25,7 @@ find, unsurprisingly, a Core expression.
 module CoreUnfold (
 	Unfolding, UnfoldingGuidance,	-- Abstract types
 
-	noUnfolding, mkImplicitUnfolding, 
+	noUnfolding, mkImplicitUnfolding,
         mkUnfolding, mkCoreUnfolding,
 	mkTopUnfolding, mkSimpleUnfolding,
 	mkInlineUnfolding, mkInlinableUnfolding, mkWwInlineRule,
@@ -881,28 +881,26 @@ instance Outputable ArgSummary where
   ppr NonTrivArg = ptext (sLit "NonTrivArg")
   ppr ValueArg   = ptext (sLit "ValueArg")
 
-data CallCtxt = BoringCtxt
+data CallCtxt
+  = BoringCtxt
+  | RhsCtxt             -- Rhs of a let-binding; see Note [RHS of lets]
+  | DiscArgCtxt         -- Argument of a fuction with non-zero arg discount
+  | RuleArgCtxt		-- We are somewhere in the argument of a function with rules
 
-	      | ArgCtxt		-- We are somewhere in the argument of a function
-                        Bool	-- True  <=> we're somewhere in the RHS of function with rules
-				-- False <=> we *are* the argument of a function with non-zero
-				-- 	     arg discount
-                                --        OR 
-                                --           we *are* the RHS of a let  Note [RHS of lets]
-                                -- In both cases, be a little keener to inline
+  | ValAppCtxt 	        -- We're applied to at least one value arg
+		        -- This arises when we have ((f x |> co) y)
+		        -- Then the (f x) has argument 'x' but in a ValAppCtxt
 
-	      | ValAppCtxt 	-- We're applied to at least one value arg
-				-- This arises when we have ((f x |> co) y)
-				-- Then the (f x) has argument 'x' but in a ValAppCtxt
-
-	      | CaseCtxt	-- We're the scrutinee of a case
-				-- that decomposes its scrutinee
+  | CaseCtxt	        -- We're the scrutinee of a case
+		        -- that decomposes its scrutinee
 
 instance Outputable CallCtxt where
-  ppr BoringCtxt      = ptext (sLit "BoringCtxt")
-  ppr (ArgCtxt rules) = ptext (sLit "ArgCtxt") <+> ppr rules
-  ppr CaseCtxt 	      = ptext (sLit "CaseCtxt")
-  ppr ValAppCtxt      = ptext (sLit "ValAppCtxt")
+  ppr CaseCtxt 	  = ptext (sLit "CaseCtxt")
+  ppr ValAppCtxt  = ptext (sLit "ValAppCtxt")
+  ppr BoringCtxt  = ptext (sLit "BoringCtxt")
+  ppr RhsCtxt     = ptext (sLit "RhsCtxt")
+  ppr DiscArgCtxt = ptext (sLit "DiscArgCtxt")
+  ppr RuleArgCtxt = ptext (sLit "RuleArgCtxt")
 
 callSiteInline dflags id active_unfolding lone_variable arg_infos cont_info
   = case idUnfolding id of 
@@ -971,10 +969,13 @@ tryUnfolding dflags id lone_variable
 
     interesting_call 
       = case cont_info' of
-          BoringCtxt -> not is_top && uf_arity > 0	  -- Note [Nested functions]
-          CaseCtxt   -> not (lone_variable && is_wf)      -- Note [Lone variables]
-          ArgCtxt {} -> uf_arity > 0     		  -- Note [Inlining in ArgCtxt]
-          ValAppCtxt -> True			          -- Note [Cast then apply]
+          CaseCtxt   -> not (lone_variable && is_wf)  -- Note [Lone variables]
+          ValAppCtxt -> True			      -- Note [Cast then apply]
+          RuleArgCtxt -> uf_arity > 0  -- See Note [Unfold info lazy contexts]
+          DiscArgCtxt -> uf_arity > 0  --
+          RhsCtxt     -> uf_arity > 0  --
+          _           -> not is_top && uf_arity > 0   -- Note [Nested functions]
+                                                      -- Note [Inlining in ArgCtxt]
 
     (yes_or_no, extra_doc)
       = case guidance of
@@ -995,15 +996,20 @@ tryUnfolding dflags id lone_variable
     	         		          res_discount arg_infos cont_info'
 \end{code}
 
-Note [RHS of lets]
-~~~~~~~~~~~~~~~~~~
-Be a tiny bit keener to inline in the RHS of a let, because that might
-lead to good thing later
+Note [Unfold into lazy contexts], Note [RHS of lets]
+~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~
+When the call is the argument of a function with a RULE, or the RHS of a let,
+we are a little bit keener to inline.  For example
      f y = (y,y,y)
      g y = let x = f y in ...(case x of (a,b,c) -> ...) ...
 We'd inline 'f' if the call was in a case context, and it kind-of-is,
-only we can't see it.  So we treat the RHS of a let as not-totally-boring.
-    
+only we can't see it.  Also
+     x = f v
+could be expensive whereas
+     x = case v of (a,b) -> a
+is patently cheap and may allow more eta expansion.
+So we treat the RHS of a let as not-totally-boring.
+
 Note [Unsaturated applications]
 ~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~
 When a call is not saturated, we *still* inline if one of the
@@ -1212,7 +1218,15 @@ computeDiscount dflags uf_arity arg_discounts res_discount arg_infos cont_info
 			BoringCtxt  -> 0
 			CaseCtxt    -> res_discount  -- Presumably a constructor
 			ValAppCtxt  -> res_discount  -- Presumably a function
-                        ArgCtxt {}  -> 40 `min` res_discount
+			_           -> 40 `min` res_discount
+                -- ToDo: this 40 `min` res_dicount doesn't seem right
+                --   for DiscArgCtxt it shouldn't matter because the function will
+                --    get the arg discount for any non-triv arg
+                --   for RuleArgCtxt we do want to be keener to inline; but not only
+                --    constructor results
+                --   for RhsCtxt I suppose that exposing a data con is good in general
+                --   And 40 seems very arbitrary
+                --
 		-- res_discount can be very large when a function returns
 		-- constructors; but we only want to invoke that large discount
 		-- when there's a case continuation.
diff --git a/compiler/simplCore/SimplUtils.lhs b/compiler/simplCore/SimplUtils.lhs
index 5cf82ed3ac..6c7dcc2042 100644
--- a/compiler/simplCore/SimplUtils.lhs
+++ b/compiler/simplCore/SimplUtils.lhs
@@ -6,7 +6,7 @@
 \begin{code}
 module SimplUtils (
         -- Rebuilding
-        mkLam, mkCase, prepareAlts, tryEtaExpand,
+        mkLam, mkCase, prepareAlts, tryEtaExpandRhs,
 
         -- Inlining,
         preInlineUnconditionally, postInlineUnconditionally,
@@ -93,12 +93,14 @@ Key points:
 data SimplCont
   = Stop                -- An empty context, or <hole>
         OutType         -- Type of the <hole>
-        CallCtxt        -- True <=> There is something interesting about
+        CallCtxt        -- Tells if there is something interesting about
                         --          the context, and hence the inliner
                         --          should be a bit keener (see interestingCallContext)
                         -- Specifically:
                         --     This is an argument of a function that has RULES
                         --     Inlining the call might allow the rule to fire
+                        -- Never ValAppCxt (use ApplyTo instead)
+                        -- or CaseCtxt (use Select instead)
 
   | CoerceIt            -- <hole> `cast` co
         OutCoercion             -- The coercion simplified
@@ -224,7 +226,7 @@ mkBoringStop :: OutType -> SimplCont
 mkBoringStop ty = Stop ty BoringCtxt
 
 mkRhsStop :: OutType -> SimplCont       -- See Note [RHS of lets] in CoreUnfold
-mkRhsStop ty = Stop ty (ArgCtxt False)
+mkRhsStop ty = Stop ty RhsCtxt
 
 mkLazyArgStop :: OutType -> CallCtxt -> SimplCont
 mkLazyArgStop ty cci = Stop ty cci
@@ -236,6 +238,10 @@ contIsRhsOrArg (StrictBind {}) = True
 contIsRhsOrArg (StrictArg {})  = True
 contIsRhsOrArg _               = False
 
+contIsRhs :: SimplCont -> Bool
+contIsRhs (Stop _ RhsCtxt) = True
+contIsRhs _                = False
+
 -------------------
 contIsDupable :: SimplCont -> Bool
 contIsDupable (Stop {})                  = True
@@ -361,11 +367,7 @@ interestingCallContext :: SimplCont -> CallCtxt
 interestingCallContext cont
   = interesting cont
   where
-    interesting (Select _ bndr _ _ _)
-        | isDeadBinder bndr = CaseCtxt
-        | otherwise         = ArgCtxt False     -- If the binder is used, this
-                                                -- is like a strict let
-                                                -- See Note [RHS of lets] in CoreUnfold
+    interesting (Select _ _bndr _ _ _) = CaseCtxt
 
     interesting (ApplyTo _ arg _ cont)
         | isTypeArg arg = interesting cont
@@ -505,8 +507,8 @@ interestingArgContext rules call_cont
     go (Stop _ cci)        = interesting cci
     go (TickIt _ c)        = go c
 
-    interesting (ArgCtxt rules) = rules
-    interesting _               = False
+    interesting RuleArgCtxt = True
+    interesting _           = False
 \end{code}
 
 
@@ -1084,14 +1086,14 @@ won't inline because 'e' is too big.
 %************************************************************************
 
 \begin{code}
-mkLam :: SimplEnv -> [OutBndr] -> OutExpr -> SimplM OutExpr
+mkLam :: [OutBndr] -> OutExpr -> SimplCont -> SimplM OutExpr
 -- mkLam tries three things
 --      a) eta reduction, if that gives a trivial expression
 --      b) eta expansion [only if there are some value lambdas]
 
-mkLam _b [] body
+mkLam [] body _cont
   = return body
-mkLam _env bndrs body
+mkLam bndrs body cont
   = do  { dflags <- getDynFlags
         ; mkLam' dflags bndrs body }
   where
@@ -1116,11 +1118,37 @@ mkLam _env bndrs body
       = do { tick (EtaReduction (head bndrs))
            ; return etad_lam }
 
+      | not (contIsRhs cont)   -- See Note [Eta-expanding lambdas]
+      , gopt Opt_DoLambdaEtaExpansion dflags
+      , any isRuntimeVar bndrs
+      , let body_arity = exprEtaExpandArity dflags body
+      , body_arity > 0
+      = do { tick (EtaExpansion (head bndrs))
+           ; return (mkLams bndrs (etaExpand body_arity body)) }
+
       | otherwise
       = return (mkLams bndrs body)
 \end{code}
 
 
+Note [Eta expanding lambdas]
+~~~~~~~~~~~~~~~~~~~~~~~~~~~~
+In general we *do* want to eta-expand lambdas. Consider
+   f (\x -> case x of (a,b) -> \s -> blah)
+where 's' is a state token, and hence can be eta expanded.  This
+showed up in the code for GHc.IO.Handle.Text.hPutChar, a rather
+important function!
+
+The eta-expansion will never happen unless we do it now.  (Well, it's
+possible that CorePrep will do it, but CorePrep only has a half-baked
+eta-expander that can't deal with casts.  So it's much better to do it
+here.)
+
+However, when the lambda is let-bound, as the RHS of a let, we have a
+better eta-expander (in the form of tryEtaExpandRhs), so we don't
+bother to try expansion in mkLam in that case; hence the contIsRhs
+guard.
+
 Note [Casts and lambdas]
 ~~~~~~~~~~~~~~~~~~~~~~~~
 Consider
@@ -1160,10 +1188,10 @@ because the latter is not well-kinded.
 %************************************************************************
 
 \begin{code}
-tryEtaExpand :: SimplEnv -> OutId -> OutExpr -> SimplM (Arity, OutExpr)
+tryEtaExpandRhs :: SimplEnv -> OutId -> OutExpr -> SimplM (Arity, OutExpr)
 -- See Note [Eta-expanding at let bindings]
 -- and Note [Eta expansion to manifest arity]
-tryEtaExpand env bndr rhs
+tryEtaExpandRhs env bndr rhs
   = do { dflags <- getDynFlags
        ; (new_arity, new_rhs) <- try_expand dflags
 
@@ -1178,9 +1206,8 @@ tryEtaExpand env bndr rhs
       = return (exprArity rhs, rhs)
 
       | sm_eta_expand (getMode env)      -- Provided eta-expansion is on
-      , let new_arity = findArity dflags bndr rhs old_arity
+      , let new_arity = findRhsArity dflags bndr rhs old_arity
       , new_arity > manifest_arity      -- And the curent manifest arity isn't enough
-                                        -- See Note [Eta expansion to manifest arity]
       = do { tick (EtaExpansion bndr)
            ; return (new_arity, etaExpand new_arity rhs) }
       | otherwise
@@ -1189,46 +1216,13 @@ tryEtaExpand env bndr rhs
     manifest_arity = manifestArity rhs
     old_arity  = idArity bndr
     _dmd_arity = length $ fst $ splitStrictSig $ idStrictness bndr
-
-findArity :: DynFlags -> Id -> CoreExpr -> Arity -> Arity
--- This implements the fixpoint loop for arity analysis
--- See Note [Arity analysis]
-findArity dflags bndr rhs old_arity
-  = go (exprEtaExpandArity dflags init_cheap_app rhs)
-       -- We always call exprEtaExpandArity once, but usually
-       -- that produces a result equal to old_arity, and then
-       -- we stop right away (since arities should not decrease)
-       -- Result: the common case is that there is just one iteration
-  where
-    init_cheap_app :: CheapAppFun
-    init_cheap_app fn n_val_args
-      | fn == bndr = True   -- On the first pass, this binder gets infinite arity
-      | otherwise  = isCheapApp fn n_val_args
-
-    go :: Arity -> Arity
-    go cur_arity
-      | cur_arity <= old_arity = cur_arity
-      | new_arity == cur_arity = cur_arity
-      | otherwise = ASSERT( new_arity < cur_arity )
-#ifdef DEBUG
-                    pprTrace "Exciting arity"
-                       (vcat [ ppr bndr <+> ppr cur_arity <+> ppr new_arity
-                             , ppr rhs])
-#endif
-                    go new_arity
-      where
-        new_arity = exprEtaExpandArity dflags cheap_app rhs
-
-        cheap_app :: CheapAppFun
-        cheap_app fn n_val_args
-          | fn == bndr = n_val_args < cur_arity
-          | otherwise  = isCheapApp fn n_val_args
 \end{code}
 
 Note [Eta-expanding at let bindings]
 ~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~
-We now eta expand at let-bindings, which is where the payoff
-comes.
+We now eta expand at let-bindings, which is where the payoff comes.
+The most significant thing is that we can do a simple arity analysis
+(in CoreArity.findRhsArity), which we can't do for free-floating lambdas
 
 One useful consequence is this example:
    genMap :: C a => ...
@@ -1248,50 +1242,6 @@ because then 'genMap' will inline, and it really shouldn't: at least
 as far as the programmer is concerned, it's not applied to two
 arguments!
 
-Note [Eta expansion to manifest arity]
-~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~
-Eta expansion does *not* eta-expand trivial RHSs, like
-    x = y
-because these will get substituted out in short order.  (Indeed
-we *eta-contract* if that yields a trivial RHS.)
-
-Otherwise we eta-expand to produce enough manifest lambdas.
-This *does* eta-expand partial applications.  eg
-      x = map g         -->    x = \v -> map g v
-      y = \_ -> map g   -->    y = \_ v -> map g v
-One benefit this is that in the definition of y there was
-a danger that full laziness would transform to
-      lvl = map g
-      y = \_ -> lvl
-which is stupid.  This doesn't happen in the eta-expanded form.
-
-Note [Arity analysis]
-~~~~~~~~~~~~~~~~~~~~~
-The motivating example for arity analysis is this:
-
-  f = \x. let g = f (x+1)
-          in \y. ...g...
-
-What arity does f have?  Really it should have arity 2, but a naive
-look at the RHS won't see that.  You need a fixpoint analysis which
-says it has arity "infinity" the first time round.
-
-This example happens a lot; it first showed up in Andy Gill's thesis,
-fifteen years ago!  It also shows up in the code for 'rnf' on lists
-in Trac #4138.
-
-The analysis is easy to achieve because exprEtaExpandArity takes an
-argument
-     type CheapFun = CoreExpr -> Maybe Type -> Bool
-used to decide if an expression is cheap enough to push inside a
-lambda.  And exprIsCheap' in turn takes an argument
-     type CheapAppFun = Id -> Int -> Bool
-which tells when an application is cheap. This makes it easy to
-write the analysis loop.
-
-The analysis is cheap-and-cheerful because it doesn't deal with
-mutual recursion.  But the self-recursive case is the important one.
-
 
 %************************************************************************
 %*                                                                      *
diff --git a/compiler/simplCore/Simplify.lhs b/compiler/simplCore/Simplify.lhs
index 9b8684e69f..cb9d6e5ef8 100644
--- a/compiler/simplCore/Simplify.lhs
+++ b/compiler/simplCore/Simplify.lhs
@@ -342,16 +342,15 @@ simplLazyBind env top_lvl is_rec bndr bndr1 rhs rhs_se
                 -- See Note [Floating and type abstraction] in SimplUtils
 
         -- Simplify the RHS
-        ; let   body_out_ty :: OutType
-                body_out_ty = substTy body_env (exprType body)
-        ; (body_env1, body1) <- simplExprF body_env body (mkRhsStop body_out_ty)
+        ; let   rhs_cont = mkRhsStop (substTy body_env (exprType body))
+        ; (body_env1, body1) <- simplExprF body_env body rhs_cont
         -- ANF-ise a constructor or PAP rhs
         ; (body_env2, body2) <- prepareRhs top_lvl body_env1 bndr1 body1
 
         ; (env', rhs')
             <-  if not (doFloatFromRhs top_lvl is_rec False body2 body_env2)
                 then                            -- No floating, revert to body1
-                     do { rhs' <- mkLam env tvs' (wrapFloats body_env1 body1)
+                     do { rhs' <- mkLam tvs' (wrapFloats body_env1 body1) rhs_cont
                         ; return (env, rhs') }
 
                 else if null tvs then           -- Simple floating
@@ -361,7 +360,7 @@ simplLazyBind env top_lvl is_rec bndr bndr1 rhs rhs_se
                 else                            -- Do type-abstraction first
                      do { tick LetFloatFromLet
                         ; (poly_binds, body3) <- abstractFloats tvs' body_env2 body2
-                        ; rhs' <- mkLam env tvs' body3
+                        ; rhs' <- mkLam tvs' body3 rhs_cont
                         ; env' <- foldlM (addPolyBind top_lvl) env poly_binds
                         ; return (env', rhs') }
 
@@ -383,7 +382,8 @@ simplNonRecX env bndr new_rhs
                         --               the binding c = (a,b)
   | Coercion co <- new_rhs
   = return (extendCvSubst env bndr co)
-  | otherwise           --               the binding b = (a,b)
+
+  | otherwise
   = do  { (env', bndr') <- simplBinder env bndr
         ; completeNonRecX NotTopLevel env' (isStrictId bndr) bndr bndr' new_rhs }
                 -- simplNonRecX is only used for NotTopLevel things
@@ -656,7 +656,7 @@ completeBind env top_lvl old_bndr new_bndr new_rhs
 
         -- Do eta-expansion on the RHS of the binding
         -- See Note [Eta-expanding at let bindings] in SimplUtils
-      ; (new_arity, final_rhs) <- tryEtaExpand env new_bndr new_rhs
+      ; (new_arity, final_rhs) <- tryEtaExpandRhs env new_bndr new_rhs
 
         -- Simplify the unfolding
       ; new_unfolding <- simplUnfolding env top_lvl old_bndr final_rhs old_unf
@@ -1306,7 +1306,7 @@ simplLam env bndrs body (TickIt tickish cont)
 simplLam env bndrs body cont
   = do  { (env', bndrs') <- simplLamBndrs env bndrs
         ; body' <- simplExpr env' body
-        ; new_lam <- mkLam env' bndrs' body'
+        ; new_lam <- mkLam bndrs' body' cont
         ; rebuild env' new_lam cont }
 
 ------------------
@@ -1481,8 +1481,9 @@ rebuildCall env info@(ArgInfo { ai_encl = encl_rules, ai_type = fun_ty
         ; rebuildCall env (addArgTo info' arg') cont }
   where
     info' = info { ai_strs = strs, ai_discs = discs }
-    cci | encl_rules || disc > 0 = ArgCtxt encl_rules  -- Be keener here
-        | otherwise              = BoringCtxt          -- Nothing interesting
+    cci | encl_rules = RuleArgCtxt
+        | disc > 0   = DiscArgCtxt  -- Be keener here
+        | otherwise  = BoringCtxt   -- Nothing interesting
 
 rebuildCall env (ArgInfo { ai_fun = fun, ai_args = rev_args, ai_rules = rules }) cont
   | null rules