summaryrefslogtreecommitdiff
path: root/testsuite
diff options
context:
space:
mode:
authorSebastian Graf <sebastian.graf@kit.edu>2022-05-19 18:37:38 +0200
committerSebastian Graf <sebastian.graf@kit.edu>2022-06-20 09:43:29 +0200
commitb570da84b7aad5ca3f90f2d1c1a690c927e99fe9 (patch)
tree9210e2e9c3f37477db705df57dbf359da9e95baa /testsuite
parent94f2e92a2510a3338c5201a4dcc69666fa9575f8 (diff)
downloadhaskell-b570da84b7aad5ca3f90f2d1c1a690c927e99fe9.tar.gz
CorePrep: Don't speculatively evaluate recursive calls (#20836)
In #20836 we have optimised a terminating program into an endless loop, because we speculated the self-recursive call of a recursive DFun. Now we track the set of enclosing recursive binders in CorePrep to prevent speculation of such self-recursive calls. See the updates to Note [Speculative evaluation] for details. Fixes #20836.
Diffstat (limited to 'testsuite')
-rw-r--r--testsuite/tests/count-deps/CountDepsAst.stdout1
-rw-r--r--testsuite/tests/count-deps/CountDepsParser.stdout1
-rw-r--r--testsuite/tests/simplCore/should_run/T20836.hs23
-rw-r--r--testsuite/tests/simplCore/should_run/all.T1
4 files changed, 26 insertions, 0 deletions
diff --git a/testsuite/tests/count-deps/CountDepsAst.stdout b/testsuite/tests/count-deps/CountDepsAst.stdout
index 0c7d753be6..75ef4e13de 100644
--- a/testsuite/tests/count-deps/CountDepsAst.stdout
+++ b/testsuite/tests/count-deps/CountDepsAst.stdout
@@ -76,6 +76,7 @@ GHC.Data.FastString
GHC.Data.FastString.Env
GHC.Data.FiniteMap
GHC.Data.Graph.Directed
+GHC.Data.Graph.UnVar
GHC.Data.IOEnv
GHC.Data.List.SetOps
GHC.Data.Maybe
diff --git a/testsuite/tests/count-deps/CountDepsParser.stdout b/testsuite/tests/count-deps/CountDepsParser.stdout
index 30267860d8..a4a51fbf9a 100644
--- a/testsuite/tests/count-deps/CountDepsParser.stdout
+++ b/testsuite/tests/count-deps/CountDepsParser.stdout
@@ -76,6 +76,7 @@ GHC.Data.FastString
GHC.Data.FastString.Env
GHC.Data.FiniteMap
GHC.Data.Graph.Directed
+GHC.Data.Graph.UnVar
GHC.Data.IOEnv
GHC.Data.List.SetOps
GHC.Data.Maybe
diff --git a/testsuite/tests/simplCore/should_run/T20836.hs b/testsuite/tests/simplCore/should_run/T20836.hs
new file mode 100644
index 0000000000..462fdb3ac7
--- /dev/null
+++ b/testsuite/tests/simplCore/should_run/T20836.hs
@@ -0,0 +1,23 @@
+{-# LANGUAGE FlexibleContexts #-}
+{-# LANGUAGE GeneralizedNewtypeDeriving #-}
+{-# LANGUAGE TypeFamilies #-}
+{-# LANGUAGE UndecidableSuperClasses #-}
+
+import Data.Kind (Type)
+
+class (Monad m, MonadFoo (FooM m)) => MonadFoo m where
+ type FooM m :: Type -> Type
+ runFoo :: FooM m a -> m a
+
+newtype MyMonad m a = MyMonad { runMyMonad :: m a }
+ deriving (Functor, Applicative, Monad)
+
+instance Monad m => MonadFoo (MyMonad m) where
+ type FooM (MyMonad m) = MyMonad m
+ runFoo = id
+
+main :: IO ()
+main = runMyMonad foo
+
+foo :: MonadFoo m => m ()
+foo = runFoo $ return ()
diff --git a/testsuite/tests/simplCore/should_run/all.T b/testsuite/tests/simplCore/should_run/all.T
index 509ae1ff57..bebd839724 100644
--- a/testsuite/tests/simplCore/should_run/all.T
+++ b/testsuite/tests/simplCore/should_run/all.T
@@ -105,3 +105,4 @@ test('T19313', normal, compile_and_run, [''])
test('UnliftedArgRule', normal, compile_and_run, [''])
test('T21229', normal, compile_and_run, ['-O'])
test('T21575', normal, compile_and_run, ['-O'])
+test('T20836', normal, compile_and_run, ['-O0']) # Should not time out; See #20836