[Git][ghc/ghc][wip/arity-type-9.4] Attemp fix for core lint failures

[Zubin (@wz1000)]

Zubin pushed to branch wip/arity-type-9.4 at Glasgow Haskell Compiler / GHC


Commits:
ee5c6fe5 by Zubin Duggal at 2022-10-28T18:50:53+05:30
Attemp fix for core lint failures

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.

- - - - -


3 changed files:

- compiler/GHC/Core/Opt/Arity.hs
- + testsuite/tests/arityanal/should_compile/Arity17.hs
- testsuite/tests/arityanal/should_compile/all.T


Changes:

=====================================
compiler/GHC/Core/Opt/Arity.hs
=====================================
@@ -1189,18 +1189,11 @@ 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
+    arityType rec_env body
   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


=====================================
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 ()


=====================================
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'])



View it on GitLab: https://gitlab.haskell.org/ghc/ghc/-/commit/ee5c6fe5ee2256e191f134bc29c6582ef9ed395f

-- 
View it on GitLab: https://gitlab.haskell.org/ghc/ghc/-/commit/ee5c6fe5ee2256e191f134bc29c6582ef9ed395f
You're receiving this email because of your account on gitlab.haskell.org.


-------------- next part --------------
An HTML attachment was scrubbed...
URL: <http://mail.haskell.org/pipermail/ghc-commits/attachments/20221028/b96acf7e/attachment-0001.html>