[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:
53235edd by Zubin Duggal at 2022-11-01T14:50:52+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.

- - - - -


4 changed files:

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


Changes:

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


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


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



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

-- 
View it on GitLab: https://gitlab.haskell.org/ghc/ghc/-/commit/53235edd478bd4c5e29e4f254ce02559af259dd5
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/20221101/2d81623d/attachment-0001.html>