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.

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