diff options
| author | Simon Peyton Jones <simonpj@microsoft.com> | 2020-06-26 23:47:50 +0100 |
|---|---|---|
| committer | Marge Bot <ben+marge-bot@smart-cactus.org> | 2020-06-28 09:21:32 -0400 |
| commit | bfa5698b1ab0190820a2df19487d3d72d3a7924d (patch) | |
| tree | d9d47a4d9fbab9adb63bcba4f84df31c90e7cace | |
| parent | 15b79befc246aa9c63dd084012dc7843ea93daaa (diff) | |
| download | haskell-bfa5698b1ab0190820a2df19487d3d72d3a7924d.tar.gz | |
Fix a typo in Lint
This simple error in GHC.Core.Litn.lintJoinLams meant that
Lint reported bogus errors.
Fixes #18399
| -rw-r--r-- | compiler/GHC/Core/Lint.hs | 14 | ||||
| -rw-r--r-- | testsuite/tests/simplCore/should_compile/T18399.hs | 5 | ||||
| -rw-r--r-- | testsuite/tests/simplCore/should_compile/all.T | 1 |
3 files changed, 13 insertions, 7 deletions
diff --git a/compiler/GHC/Core/Lint.hs b/compiler/GHC/Core/Lint.hs index eb51508314..e7385be78f 100644 --- a/compiler/GHC/Core/Lint.hs +++ b/compiler/GHC/Core/Lint.hs @@ -727,15 +727,15 @@ lintJoinLams :: JoinArity -> Maybe Id -> CoreExpr -> LintM (LintedType, UsageEnv lintJoinLams join_arity enforce rhs = go join_arity rhs where - go 0 rhs = lintCoreExpr rhs - go n (Lam var expr) = lintLambda var $ go (n-1) expr + go 0 expr = lintCoreExpr expr + go n (Lam var body) = lintLambda var $ go (n-1) body -- N.B. join points can be cast. e.g. we consider ((\x -> ...) `cast` ...) -- to be a join point at join arity 1. - go n _other | Just bndr <- enforce -- Join point with too few RHS lambdas - = failWithL $ mkBadJoinArityMsg bndr join_arity n rhs - | otherwise -- Future join point, not yet eta-expanded - = markAllJoinsBad $ lintCoreExpr rhs - -- Body of lambda is not a tail position + go n expr | Just bndr <- enforce -- Join point with too few RHS lambdas + = failWithL $ mkBadJoinArityMsg bndr join_arity n rhs + | otherwise -- Future join point, not yet eta-expanded + = markAllJoinsBad $ lintCoreExpr expr + -- Body of lambda is not a tail position lintIdUnfolding :: Id -> Type -> Unfolding -> LintM () lintIdUnfolding bndr bndr_ty uf diff --git a/testsuite/tests/simplCore/should_compile/T18399.hs b/testsuite/tests/simplCore/should_compile/T18399.hs new file mode 100644 index 0000000000..68fb2608d4 --- /dev/null +++ b/testsuite/tests/simplCore/should_compile/T18399.hs @@ -0,0 +1,5 @@ +module Bug where + +f :: p b d -> (a -> b) -> (c -> d) -> p a c -> p b d +{-# INLINE f #-} +f = const . const . const diff --git a/testsuite/tests/simplCore/should_compile/all.T b/testsuite/tests/simplCore/should_compile/all.T index ea77a92c36..e363a4ec26 100644 --- a/testsuite/tests/simplCore/should_compile/all.T +++ b/testsuite/tests/simplCore/should_compile/all.T @@ -329,3 +329,4 @@ test('T18231', [ only_ways(['optasm']), grep_errmsg(r'^[\w\.]+ ::.*->.*') ], com test('T17673', [ only_ways(['optasm']), grep_errmsg(r'^\w+\.\$wf') ], compile, ['-ddump-simpl -dsuppress-uniques -dppr-cols=9999']) test('T18078', [ only_ways(['optasm']), grep_errmsg(r'^\w+\.\$wf') ], compile, ['-ddump-simpl -dsuppress-uniques -dppr-cols=9999']) test('T18347', normal, compile, ['-dcore-lint -O']) +test('T18399', normal, compile, ['-dcore-lint -O']) |