Make findRhsArity take RecFlag

This avoids a fixpoint iteration for the common case of
non-recursive bindings.

3 files changed, 11 insertions, 7 deletions

diff --git a/compiler/GHC/Core/Opt/Arity.hs b/compiler/GHC/Core/Opt/Arity.hs
index ed08f6c70d..811beb6c0a 100644
--- a/compiler/GHC/Core/Opt/Arity.hs
+++ b/compiler/GHC/Core/Opt/Arity.hs
@@ -679,14 +679,18 @@ getBotArity (AT oss div)
   | otherwise        = Nothing
 
 ----------------------
-findRhsArity :: ArityOpts -> Id -> CoreExpr -> Arity -> ArityType
+findRhsArity :: ArityOpts -> RecFlag -> Id -> CoreExpr -> Arity -> ArityType
 -- This implements the fixpoint loop for arity analysis
 -- See Note [Arity analysis]
 -- If findRhsArity e = (n, is_bot) then
 --  (a) any application of e to <n arguments will not do much work,
 --      so it is safe to expand e  ==>  (\x1..xn. e x1 .. xn)
 --  (b) if is_bot=True, then e applied to n args is guaranteed bottom
-findRhsArity opts bndr rhs old_arity
+
+findRhsArity opts NonRecursive _ rhs _
+  = arityType (findRhsArityEnv opts) rhs
+
+findRhsArity opts Recursive bndr rhs old_arity
   = go 0 botArityType
       -- We always do one step, but usually that produces a result equal to
       -- old_arity, and then we stop right away, because old_arity is assumed
diff --git a/compiler/GHC/Core/Opt/Simplify.hs b/compiler/GHC/Core/Opt/Simplify.hs
index d83f7f7719..445fabe682 100644
--- a/compiler/GHC/Core/Opt/Simplify.hs
+++ b/compiler/GHC/Core/Opt/Simplify.hs
@@ -845,7 +845,7 @@ makeTrivialBinding env top_lvl occ_fs info expr expr_ty
 
         -- Now something very like completeBind,
         -- but without the postInlineUnconditionally part
-        ; (arity_type, expr2) <- tryEtaExpandRhs env var expr1
+        ; (arity_type, expr2) <- tryEtaExpandRhs env NonRecursive var expr1
           -- Technically we should extend the in-scope set in 'env' with
           -- the 'floats' from prepareRHS; but they are all fresh, so there is
           -- no danger of introducing name shadowig in eta expansion
@@ -945,7 +945,7 @@ completeBind env bind_cxt old_bndr new_bndr new_rhs
 
          -- Do eta-expansion on the RHS of the binding
          -- See Note [Eta-expanding at let bindings] in GHC.Core.Opt.Simplify.Utils
-      ; (new_arity, eta_rhs) <- tryEtaExpandRhs env new_bndr new_rhs
+      ; (new_arity, eta_rhs) <- tryEtaExpandRhs env is_rec new_bndr new_rhs
 
         -- Simplify the unfolding
       ; new_unfolding <- simplLetUnfolding env bind_cxt old_bndr
diff --git a/compiler/GHC/Core/Opt/Simplify/Utils.hs b/compiler/GHC/Core/Opt/Simplify/Utils.hs
index 8b26945d05..8afaef82ce 100644
--- a/compiler/GHC/Core/Opt/Simplify/Utils.hs
+++ b/compiler/GHC/Core/Opt/Simplify/Utils.hs
@@ -1774,13 +1774,13 @@ Wrinkles
 ************************************************************************
 -}
 
-tryEtaExpandRhs :: SimplEnv -> OutId -> OutExpr
+tryEtaExpandRhs :: SimplEnv -> RecFlag -> OutId -> OutExpr
                 -> SimplM (ArityType, OutExpr)
 -- See Note [Eta-expanding at let bindings]
 -- If tryEtaExpandRhs rhs = (n, is_bot, rhs') then
 --   (a) rhs' has manifest arity n
 --   (b) if is_bot is True then rhs' applied to n args is guaranteed bottom
-tryEtaExpandRhs env bndr rhs
+tryEtaExpandRhs env is_rec bndr rhs
   | Just join_arity <- isJoinId_maybe bndr
   = do { let (join_bndrs, join_body) = collectNBinders join_arity rhs
              oss   = [idOneShotInfo id | id <- join_bndrs, isId id]
@@ -1809,7 +1809,7 @@ tryEtaExpandRhs env bndr rhs
     old_arity = exprArity rhs
     ty_arity  = typeArity (idType bndr)
 
-    arity_type = findRhsArity arityOpts bndr rhs old_arity
+    arity_type = findRhsArity arityOpts is_rec bndr rhs old_arity
                  `maxWithArity` idCallArity bndr
                  `minWithArity` ty_arity
     -- minWithArity: see Note [Arity trimming] in GHC.Core.Opt.Arity