diff options
author | Simon Peyton Jones <simonpj@microsoft.com> | 2020-09-10 16:46:57 +0100 |
---|---|---|
committer | Marge Bot <ben+marge-bot@smart-cactus.org> | 2020-09-17 01:27:25 -0400 |
commit | 7cf09ab013778227caa07b5d7ec9acd5dedd1817 (patch) | |
tree | 6a7b6a09e122ff2e73d7a1d5eef971d9ad85a0c1 /testsuite/tests | |
parent | 6baa67f5500da6ca74272016ec8fd62a4b5b5050 (diff) | |
download | haskell-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')
-rw-r--r-- | testsuite/tests/simplCore/should_run/T18638.hs | 54 | ||||
-rw-r--r-- | testsuite/tests/simplCore/should_run/T18638.stdout | 1 | ||||
-rw-r--r-- | testsuite/tests/simplCore/should_run/all.T | 1 |
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, ['']) |