diff options
author | Zubin Duggal <zubin.duggal@gmail.com> | 2022-10-28 18:23:42 +0530 |
---|---|---|
committer | Zubin Duggal <zubin.duggal@gmail.com> | 2022-11-03 15:12:38 +0530 |
commit | 5674eb8bd13566dd2eaf8ab07240b3876fd08802 (patch) | |
tree | 0ab153b875ccc963f0a8c062cb8ad0d17b38c97c | |
parent | 45459ccebe081c119f9f8a0108355419ee524d1a (diff) | |
download | haskell-5674eb8bd13566dd2eaf8ab07240b3876fd08802.tar.gz |
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.
(cherry picked from commit 53235edd478bd4c5e29e4f254ce02559af259dd5)
-rw-r--r-- | compiler/GHC/Core/Opt/Arity.hs | 16 | ||||
-rw-r--r-- | testsuite/tests/arityanal/should_compile/Arity17.hs | 27 | ||||
-rw-r--r-- | testsuite/tests/arityanal/should_compile/all.T | 1 |
3 files changed, 28 insertions, 16 deletions
diff --git a/compiler/GHC/Core/Opt/Arity.hs b/compiler/GHC/Core/Opt/Arity.hs index 5a9b723ec6..1c6f9bed8b 100644 --- a/compiler/GHC/Core/Opt/Arity.hs +++ b/compiler/GHC/Core/Opt/Arity.hs @@ -1104,22 +1104,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']) |