diff options
| -rw-r--r-- | compiler/coreSyn/CorePrep.hs | 8 | ||||
| -rw-r--r-- | testsuite/tests/simplCore/should_compile/T17429.hs | 23 | ||||
| -rw-r--r-- | testsuite/tests/simplCore/should_compile/all.T | 1 |
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']) |