summaryrefslogtreecommitdiff
path: root/testsuite/tests/simplCore/should_run
diff options
context:
space:
mode:
authorSimon Peyton Jones <simonpj@microsoft.com>2020-09-10 16:46:57 +0100
committerMarge Bot <ben+marge-bot@smart-cactus.org>2020-09-17 01:27:25 -0400
commit7cf09ab013778227caa07b5d7ec9acd5dedd1817 (patch)
tree6a7b6a09e122ff2e73d7a1d5eef971d9ad85a0c1 /testsuite/tests/simplCore/should_run
parent6baa67f5500da6ca74272016ec8fd62a4b5b5050 (diff)
downloadhaskell-7cf09ab013778227caa07b5d7ec9acd5dedd1817.tar.gz
Do absence analysis on stable unfoldings
Ticket #18638 showed that Very Bad Things happen if we fail to do absence analysis on stable unfoldings. It's all described in Note [Absence analysis for stable unfoldings and RULES]. I'm a bit surprised this hasn't bitten us before. Fortunately the fix is pretty simple.
Diffstat (limited to 'testsuite/tests/simplCore/should_run')
-rw-r--r--testsuite/tests/simplCore/should_run/T18638.hs54
-rw-r--r--testsuite/tests/simplCore/should_run/T18638.stdout1
-rw-r--r--testsuite/tests/simplCore/should_run/all.T1
3 files changed, 56 insertions, 0 deletions
diff --git a/testsuite/tests/simplCore/should_run/T18638.hs b/testsuite/tests/simplCore/should_run/T18638.hs
new file mode 100644
index 0000000000..daf35a6e55
--- /dev/null
+++ b/testsuite/tests/simplCore/should_run/T18638.hs
@@ -0,0 +1,54 @@
+{-# LANGUAGE ExistentialQuantification, BangPatterns #-}
+{-# OPTIONS_GHC -O #-}
+
+module Main (main) where
+
+import Data.IORef (newIORef, readIORef)
+
+data Step s = Done
+ | Skip !s
+ | Yield !Char !s
+
+data Stream = forall s. Stream (s -> Step s) !s !Int
+
+unstreamList :: Stream -> [Char]
+unstreamList (Stream next s0 _) = unfold s0
+ where unfold !s = case next s of
+ Done -> []
+ Skip s' -> unfold s'
+ Yield x s' -> x : unfold s'
+{-# INLINE [0] unstreamList #-}
+
+appendS :: Stream -> Stream -> Stream
+appendS (Stream next s len) _ = Stream next s len
+{-# INLINE [0] appendS #-}
+
+justifyLeftI :: Int -> Int -> Stream
+justifyLeftI k u =
+ let
+ next Nothing = next (Just 0)
+ next (Just n)
+ | n < k = Yield 'a' (Just (n+1))
+ | otherwise = Done
+ {-# INLINE next #-}
+
+ in Stream next Nothing (max k u)
+{-# INLINE [0] justifyLeftI #-}
+
+prettyPrintLogStats :: Int -> [String]
+prettyPrintLogStats rawResults = map fromRow columns
+ where
+ columns :: [Int]
+ columns = map (\_ -> 0) [rawResults]
+
+ moduleLen, lineLen :: Int
+ (moduleLen, lineLen) = foldr (\_ (_,_) -> (5, 2)) (0, 0) columns
+
+ fromRow :: Int -> String
+ fromRow x = unstreamList (justifyLeftI moduleLen x `appendS` justifyLeftI lineLen x)
+
+main :: IO ()
+main = do
+ timingsRef <- newIORef 0
+ timings <- readIORef timingsRef
+ putStrLn $ concat $ prettyPrintLogStats timings
diff --git a/testsuite/tests/simplCore/should_run/T18638.stdout b/testsuite/tests/simplCore/should_run/T18638.stdout
new file mode 100644
index 0000000000..ccc3e7b48d
--- /dev/null
+++ b/testsuite/tests/simplCore/should_run/T18638.stdout
@@ -0,0 +1 @@
+aaaaa
diff --git a/testsuite/tests/simplCore/should_run/all.T b/testsuite/tests/simplCore/should_run/all.T
index efaf5efdde..a04558be89 100644
--- a/testsuite/tests/simplCore/should_run/all.T
+++ b/testsuite/tests/simplCore/should_run/all.T
@@ -92,3 +92,4 @@ test('T17206', exit_code(1), compile_and_run, [''])
test('T17151', [], multimod_compile_and_run, ['T17151', ''])
test('T18012', normal, compile_and_run, [''])
test('T17744', normal, compile_and_run, [''])
+test('T18638', normal, compile_and_run, [''])