Arity: Emit "Exciting arity" warning only after second iteration (#18937)wip/T18870

See Note [Exciting arity] why we emit the warning at all and why we only
do after the second iteration now.

Fixes #18937.

2 files changed, 39 insertions, 15 deletions

diff --git a/compiler/GHC/Core/Opt/Arity.hs b/compiler/GHC/Core/Opt/Arity.hs
index 506fb9c926..03a8052328 100644
--- a/compiler/GHC/Core/Opt/Arity.hs
+++ b/compiler/GHC/Core/Opt/Arity.hs
@@ -639,26 +639,26 @@ findRhsArity :: DynFlags -> Id -> CoreExpr -> Arity -> ArityType
 --      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 dflags bndr rhs old_arity
-  = go (step botArityType)
+  = 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
       -- to be sound. In other words, arities should never decrease.
       -- Result: the common case is that there is just one iteration
   where
-    go :: ArityType -> ArityType
-    go cur_atype@(AT oss div)
-      | not (isDeadEndDiv div)              -- the "stop right away" case
-      , length oss <= old_arity = cur_atype -- from above
-      | new_atype == cur_atype  = cur_atype
-      | otherwise =
-#if defined(DEBUG)
-                    pprTrace "Exciting arity"
-                       (vcat [ ppr bndr <+> ppr cur_atype <+> ppr new_atype
-                             , ppr rhs])
-#endif
-                    go new_atype
+    go :: Int -> ArityType -> ArityType
+    go !n cur_at@(AT oss div)
+      | not (isDeadEndDiv div)           -- the "stop right away" case
+      , length oss <= old_arity = cur_at -- from above
+      | next_at == cur_at       = cur_at
+      | otherwise               =
+         -- Warn if more than 2 iterations. Why 2? See Note [Exciting arity]
+         WARN( debugIsOn && n > 2, text "Exciting arity"
+                                   $$ nest 2 (
+                                        ppr bndr <+> ppr cur_at <+> ppr next_at
+                                        $$ ppr rhs) )
+         go (n+1) next_at
       where
-        new_atype = step cur_atype
+        next_at = step cur_at
 
     step :: ArityType -> ArityType
     step at = -- pprTrace "step" (ppr bndr <+> ppr at <+> ppr (arityType env rhs)) $
@@ -706,6 +706,30 @@ until it finds a stable arity type. Two wrinkles
   by the 'am_sigs' field in 'FindRhsArity', and 'lookupSigEnv' in the Var case
   of 'arityType'.
 
+Note [Exciting Arity]
+~~~~~~~~~~~~~~~~~~~~~
+The fixed-point iteration in 'findRhsArity' stabilises very quickly in almost
+all cases. To get notified of cases where we need an usual number of iterations,
+we emit a warning in debug mode, so that we can investigate and make sure that
+we really can't do better. It's a gross hack, but catches real bugs (#18870).
+
+Now, which number is "unusual"? We pick n > 2. Here's a pretty common and
+expected example that takes two iterations and would ruin the specificity
+of the warning (from T18937):
+
+  f :: [Int] -> Int -> Int
+  f []     = id
+  f (x:xs) = let y = sum [0..x]
+             in \z -> f xs (y + z)
+
+Fixed-point iteration starts with arity type ⊥ for f. After the first
+iteration, we get arity type \??.T, e.g. arity 2, because we unconditionally
+'floatIn' the let-binding (see its bottom case).  After the second iteration,
+we get arity type \?.T, e.g. arity 1, because now we are no longer allowed
+to floatIn the non-cheap let-binding.  Which is all perfectly benign, but
+means we do two iterations (well, actually 3 'step's to detect we are stable)
+and don't want to emit the warning.
+
 Note [Eta expanding through dictionaries]
 ~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~
 If the experimental -fdicts-cheap flag is on, we eta-expand through
diff --git a/testsuite/tests/arityanal/should_compile/all.T b/testsuite/tests/arityanal/should_compile/all.T
index 60059b8e9c..cb962dd32a 100644
--- a/testsuite/tests/arityanal/should_compile/all.T
+++ b/testsuite/tests/arityanal/should_compile/all.T
@@ -20,4 +20,4 @@ test('Arity16', [ only_ways(['optasm']), grep_errmsg('Arity=') ], compile, ['-dn
 # Regression tests
 test('T18793', [ only_ways(['optasm']), grep_errmsg('Arity=') ], compile, ['-dno-typeable-binds -ddump-simpl -dppr-cols=99999 -dsuppress-uniques'])
 test('T18870', [ only_ways(['optasm']) ], compile, ['-ddebug-output'])
-test('T18937', [ only_ways(['optasm']), when(compiler_debugged(), expect_broken(18937)) ], compile, ['-ddebug-output'])
+test('T18937', [ only_ways(['optasm']) ], compile, ['-ddebug-output'])