Take care to not eta-reduce jumps in CorePrep

CorePrep already had a check to prevent it from eta-reducing Ids that
respond true to hasNoBinding (foreign calls, constructors for unboxed
sums and products, and Ids with compulsory unfoldings). It did not,
however, consider join points as ids that 'must be saturated'.

Checking whether the Id responds True to 'isJoinId' should prevent
CorePrep from turning saturated jumps like the following (from #17429)
into undersaturated ones:

      (\ eta_XP ->
         join { mapped_s1vo _ = lvl_s1vs } in jump mapped_s1vo eta_XP)

3 files changed, 30 insertions, 2 deletions

diff --git a/compiler/coreSyn/CorePrep.hs b/compiler/coreSyn/CorePrep.hs
index 6757f7aac9..771163d562 100644
--- a/compiler/coreSyn/CorePrep.hs
+++ b/compiler/coreSyn/CorePrep.hs
@@ -1180,8 +1180,12 @@ tryEtaReducePrep bndrs expr@(App _ _)
     ok bndr (Var arg) = bndr == arg
     ok _    _         = False
 
-          -- We can't eta reduce something which must be saturated.
-    ok_to_eta_reduce (Var f) = not (hasNoBinding f)
+    -- We can't eta reduce something which must be saturated.
+    -- This includes binds which have no binding (respond True to
+    -- hasNoBinding) and join points (responds True to isJoinId)
+    -- Eta-reducing join points led to #17429.
+    ok_to_eta_reduce (Var f) =
+      not (isJoinId f) && not (hasNoBinding f)
     ok_to_eta_reduce _       = False -- Safe. ToDo: generalise
 
 tryEtaReducePrep bndrs (Let bind@(NonRec _ r) body)
diff --git a/testsuite/tests/simplCore/should_compile/T17429.hs b/testsuite/tests/simplCore/should_compile/T17429.hs
new file mode 100644
index 0000000000..bd01c140ff
--- /dev/null
+++ b/testsuite/tests/simplCore/should_compile/T17429.hs
@@ -0,0 +1,23 @@
+{-# LANGUAGE ConstraintKinds #-}
+{-# LANGUAGE TypeFamilies #-}
+
+module T17429
+  ( zoomAcceptor
+  ) where
+
+type Zoom m = ( m ~ Emitter Int )
+
+zoomAcceptor :: Zoom m => Emitter w a -> m w
+zoomAcceptor = fmap id . zoomEmitter
+
+zoomEmitter :: Emitter w a -> Emitter b w
+zoomEmitter (Emitter go) =
+  Emitter $ const ([], fst $ go ())
+
+newtype Emitter w a = Emitter (() -> ([w], [a]))
+
+instance Functor (Emitter w) where
+  fmap f (Emitter go) = Emitter mapped
+    where
+    {-# INLINE mapped #-}
+    mapped _ = fmap f <$> go ()
diff --git a/testsuite/tests/simplCore/should_compile/all.T b/testsuite/tests/simplCore/should_compile/all.T
index 5867a11a29..7146b76e6d 100644
--- a/testsuite/tests/simplCore/should_compile/all.T
+++ b/testsuite/tests/simplCore/should_compile/all.T
@@ -311,3 +311,4 @@ test('T17140',
 test('T17409',
      normal,
      makefile_test, ['T17409'])
+test('T17429', normal, compile, ['-dcore-lint -O2'])