Attemp fix for core lint failureswip/arity-type-9.4

For an expression:

  joinrec foo = ... in expr

we compute the arityType as `foldr andArityType (arityType expr) [arityType foo]`
which is the same as `andArityType (arityType expr) (arityType foo)`. However,
this is incorrect:

  joinrec go x = ... in go 0

then the arity of go is 1 (\?. T), but the arity of the overall expression is
0 (_|_). `andArityType` however returns (\?. T) for these, which is wrong.

4 files changed, 30 insertions, 16 deletions

diff --git a/compiler/GHC/Core/Opt/Arity.hs b/compiler/GHC/Core/Opt/Arity.hs
index 47ac5e129d..aaca8cc93a 100644
--- a/compiler/GHC/Core/Opt/Arity.hs
+++ b/compiler/GHC/Core/Opt/Arity.hs
@@ -1185,22 +1185,6 @@ arityType env (Let (NonRec b r) e)
     cheap_rhs = myExprIsCheap env r (Just (idType b))
     env'      = extendSigEnv env b (arityType env r)
 
-arityType env (Let (Rec pairs) body)
-  | ((j,_):_) <- pairs
-  , isJoinId j
-  = -- See Note [arityType for join bindings]
-    foldr (andArityType env . do_one) (arityType rec_env body) pairs
-  where
-    rec_env = foldl add_bot env pairs
-    add_bot env (j,_) = extendSigEnv env j botArityType
-
-    do_one :: (JoinId, CoreExpr) -> ArityType
-    do_one (j,rhs)
-      | Just arity <- isJoinId_maybe j
-      = arityType rec_env $ snd $ collectNBinders arity rhs
-      | otherwise
-      = pprPanic "arityType:joinrec" (ppr pairs)
-
 arityType env (Let (Rec prs) e)
   = floatIn (all is_cheap prs) (arityType env' e)
   where
diff --git a/testsuite/tests/arityanal/should_compile/Arity17.hs b/testsuite/tests/arityanal/should_compile/Arity17.hs
new file mode 100644
index 0000000000..4ef9cc45fb
--- /dev/null
+++ b/testsuite/tests/arityanal/should_compile/Arity17.hs
@@ -0,0 +1,27 @@
+module Bug (downsweep) where
+
+import GHC.Utils.Misc ( filterOut )
+import qualified Data.Map.Strict as M ( Map, elems )
+import qualified Data.Map as Map ( fromListWith )
+
+type DownsweepCache = M.Map Int Int
+
+downsweep :: [Int] -> IO DownsweepCache
+downsweep rootSummariesOk = do
+    let root_map = mkRootMap rootSummariesOk
+    checkDuplicates root_map
+    return root_map
+  where
+    checkDuplicates :: DownsweepCache -> IO ()
+    checkDuplicates root_map = multiRootsErr dup_roots
+       where
+         dup_roots = filterOut (>2) (M.elems root_map)
+
+mkRootMap
+  :: [Int]
+  -> DownsweepCache
+mkRootMap summaries = Map.fromListWith const
+  [ (s, s) | s <- summaries ]
+
+multiRootsErr :: [a] -> IO ()
+multiRootsErr [] = pure ()
diff --git a/testsuite/tests/arityanal/should_compile/all.T b/testsuite/tests/arityanal/should_compile/all.T
index 6124bf12c9..3aeb24ec32 100644
--- a/testsuite/tests/arityanal/should_compile/all.T
+++ b/testsuite/tests/arityanal/should_compile/all.T
@@ -16,6 +16,7 @@ test('Arity13', [ only_ways(['optasm']), grep_errmsg('Arity=') ], compile, ['-dn
 test('Arity14', [ only_ways(['optasm']), grep_errmsg('Arity=') ], compile, ['-dno-typeable-binds -ddump-simpl -dppr-cols=99999 -dsuppress-uniques'])
 test('Arity15', [ only_ways(['optasm']), grep_errmsg('Arity=') ], compile, ['-dno-typeable-binds -ddump-simpl -dppr-cols=99999 -dsuppress-uniques'])
 test('Arity16', [ only_ways(['optasm']), grep_errmsg('Arity=') ], compile, ['-dno-typeable-binds -ddump-simpl -dppr-cols=99999 -dsuppress-uniques'])
+test('Arity17', [ only_ways(['optasm']), grep_errmsg('Arity=') ], compile, ['-package ghc -dcore-lint -O2'])
 
 # Regression tests
 test('T18793', [ only_ways(['optasm']), grep_errmsg('Arity=') ], compile, ['-dno-typeable-binds -ddump-simpl -dppr-cols=99999 -dsuppress-uniques'])
diff --git a/testsuite/tests/linters/notes.stdout b/testsuite/tests/linters/notes.stdout
index 16fd6a02ac..142f0081e2 100644
--- a/testsuite/tests/linters/notes.stdout
+++ b/testsuite/tests/linters/notes.stdout
@@ -1,4 +1,6 @@
 ref    compiler/GHC/Core/Coercion/Axiom.hs:458:2:     Note [RoughMap and rm_empty]
+ref    compiler/GHC/Core/Opt/Arity.hs<line>:<no>:     Note [Combining case branches]
+ref    compiler/GHC/Core/Opt/Arity.hs<line>:<no>:     Note [ArityType for let-bindings]
 ref    compiler/GHC/Core/Opt/OccurAnal.hs:851:15:     Note [Loop breaking]
 ref    compiler/GHC/Core/Opt/SetLevels.hs:1598:30:     Note [Top level scope]
 ref    compiler/GHC/Core/Opt/Simplify.hs:2618:13:     Note [Case binder next]