summaryrefslogtreecommitdiff
diff options
context:
space:
mode:
authorSimon Peyton Jones <simonpj@microsoft.com>2022-07-22 12:13:54 +0100
committerMarge Bot <ben+marge-bot@smart-cactus.org>2022-07-25 09:45:09 -0400
commitb77d95f8a4b0f8a5025dbd5036c17ecf85ca3ab2 (patch)
tree2d7a990ac39d8b329076b63607b9d8e4edb2a618
parent5f2fbd5e217802b3ae2bcab505bba05dc69115ec (diff)
downloadhaskell-b77d95f8a4b0f8a5025dbd5036c17ecf85ca3ab2.tar.gz
Fix a small buglet in tryEtaReduce
Gergo points out (#21801) that GHC.Core.Opt.Arity.tryEtaReduce was making an ill-formed cast. It didn't matter, because the subsequent guard discarded it; but still worth fixing. Spurious warnings are distracting.
-rw-r--r--compiler/GHC/Core/Opt/Arity.hs14
-rw-r--r--compiler/GHC/Core/Utils.hs2
-rw-r--r--testsuite/tests/simplCore/should_compile/T21801.hs14
-rw-r--r--testsuite/tests/simplCore/should_compile/all.T1
4 files changed, 24 insertions, 7 deletions
diff --git a/compiler/GHC/Core/Opt/Arity.hs b/compiler/GHC/Core/Opt/Arity.hs
index 8a0a69ca97..9312e7d48b 100644
--- a/compiler/GHC/Core/Opt/Arity.hs
+++ b/compiler/GHC/Core/Opt/Arity.hs
@@ -2353,7 +2353,7 @@ tryEtaReduce rec_ids bndrs body eval_sd
-- for why we have an accumulating coercion
--
-- Invariant: (go bs body co) returns an expression
- -- equivalent to (\(reverse bs). body |> co)
+ -- equivalent to (\(reverse bs). (body |> co))
-- See Note [Eta reduction with casted function]
go bs (Cast e co1) co2
@@ -2380,14 +2380,16 @@ tryEtaReduce rec_ids bndrs body eval_sd
, remaining_bndrs `ltLength` bndrs
-- Only reply Just if /something/ has happened
, ok_fun fun
- , let etad_expr = mkLams (reverse remaining_bndrs) (mkCast fun co)
- used_vars = exprFreeVars etad_expr
+ , let used_vars = exprFreeVars fun `unionVarSet` tyCoVarsOfCo co
reduced_bndrs = mkVarSet (dropList remaining_bndrs bndrs)
+ -- reduced_bndrs are the ones we are eta-reducing away
, used_vars `disjointVarSet` reduced_bndrs
- -- Check for any of the binders free in the result,
- -- including the accumulated coercion
+ -- Check for any of the reduced_bndrs (about to be dropped)
+ -- free in the result, including the accumulated coercion.
-- See Note [Eta reduction makes sense], intro and point (1)
- = Just etad_expr
+ -- NB: don't compute used_vars from exprFreeVars (mkCast fun co)
+ -- because the latter may be ill formed if the guard fails (#21801)
+ = Just (mkLams (reverse remaining_bndrs) (mkCast fun co))
go _remaining_bndrs _fun _ = -- pprTrace "tER fail" (ppr _fun $$ ppr _remaining_bndrs) $
Nothing
diff --git a/compiler/GHC/Core/Utils.hs b/compiler/GHC/Core/Utils.hs
index e34e77ef9b..5ae6bf235a 100644
--- a/compiler/GHC/Core/Utils.hs
+++ b/compiler/GHC/Core/Utils.hs
@@ -275,7 +275,7 @@ mkPiMCo v (MCo co) = MCo (mkPiCo Representational v co)
-- | Wrap the given expression in the coercion safely, dropping
-- identity coercions and coalescing nested coercions
-mkCast :: CoreExpr -> CoercionR -> CoreExpr
+mkCast :: HasDebugCallStack => CoreExpr -> CoercionR -> CoreExpr
mkCast e co
| assertPpr (coercionRole co == Representational)
(text "coercion" <+> ppr co <+> text "passed to mkCast"
diff --git a/testsuite/tests/simplCore/should_compile/T21801.hs b/testsuite/tests/simplCore/should_compile/T21801.hs
new file mode 100644
index 0000000000..28add577ec
--- /dev/null
+++ b/testsuite/tests/simplCore/should_compile/T21801.hs
@@ -0,0 +1,14 @@
+{-# LANGUAGE NoImplicitPrelude #-}
+module Endo where
+
+-- This test threw up a WARNING (in a -DDEBUG compiler)
+-- in GHC.Core.Opt.Arity.tryEtaReduce
+
+newtype Endo a = Endo { appEndo :: a -> a }
+
+foo :: Endo a -> Endo a -> Endo a
+foo (Endo f) (Endo g) = Endo (comp f g)
+
+comp :: (b -> c) -> (a -> b) -> (a -> c)
+comp f g x = f (g x)
+{-# OPAQUE comp #-}
diff --git a/testsuite/tests/simplCore/should_compile/all.T b/testsuite/tests/simplCore/should_compile/all.T
index 2ddbef16bb..ff55f67806 100644
--- a/testsuite/tests/simplCore/should_compile/all.T
+++ b/testsuite/tests/simplCore/should_compile/all.T
@@ -418,3 +418,4 @@ test('T21391a', normal, compile, ['-O -dcore-lint'])
# We don't want to see a thunk allocation for the insertBy expression after CorePrep.
test('T21392', [ grep_errmsg(r'sat.* :: \[\(.*Unique, .*Int\)\]'), expect_broken(21392) ], compile, ['-O -ddump-prep -dno-typeable-binds -dsuppress-uniques'])
test('T21689', [extra_files(['T21689a.hs'])], multimod_compile, ['T21689', '-v0 -O'])
+test('T21801', normal, compile, ['-O -dcore-lint'])