Take care to not eta-reduce jumps in CorePrep
authorMatheus Magalhães de Alcantara <matheus.de.alcantara@gmail.com>
Fri, 8 Nov 2019 20:59:26 +0000 (17:59 -0300)
committerMarge Bot <ben+marge-bot@smart-cactus.org>
Sat, 23 Nov 2019 23:55:23 +0000 (18:55 -0500)
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)

compiler/coreSyn/CorePrep.hs
testsuite/tests/simplCore/should_compile/T17429.hs [new file with mode: 0644]
testsuite/tests/simplCore/should_compile/all.T

index 6757f7a..771163d 100644 (file)
@@ -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 (file)
index 0000000..bd01c14
--- /dev/null
@@ -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 ()
index 5867a11..7146b76 100644 (file)
@@ -311,3 +311,4 @@ test('T17140',
 test('T17409',
      normal,
      makefile_test, ['T17409'])
+test('T17429', normal, compile, ['-dcore-lint -O2'])