diff options
-rw-r--r-- | libraries/base/GHC/List.hs | 41 | ||||
-rw-r--r-- | testsuite/tests/perf/should_run/T18964.hs | 3 | ||||
-rw-r--r-- | testsuite/tests/perf/should_run/T23021.hs | 30 | ||||
-rw-r--r-- | testsuite/tests/perf/should_run/T23021.stdout | 12 | ||||
-rw-r--r-- | testsuite/tests/perf/should_run/all.T | 3 |
5 files changed, 56 insertions, 33 deletions
diff --git a/libraries/base/GHC/List.hs b/libraries/base/GHC/List.hs index 4427d1af1b..d88112f0f3 100644 --- a/libraries/base/GHC/List.hs +++ b/libraries/base/GHC/List.hs @@ -886,23 +886,12 @@ takeWhileFB p c n = \x r -> if p x then x `c` r else n -- [] -- >>> dropWhile (< 0) [1,2,3] -- [1,2,3] -{-# NOINLINE [1] dropWhile #-} dropWhile :: (a -> Bool) -> [a] -> [a] dropWhile _ [] = [] dropWhile p xs@(x:xs') | p x = dropWhile p xs' | otherwise = xs -{-# INLINE [0] dropWhileFB #-} -- See Note [Inline FB functions] -dropWhileFB :: (a -> Bool) -> (a -> b -> b) -> b -> a -> (Bool -> b) -> Bool -> b -dropWhileFB p c _n x xs = \drp -> if drp && p x then xs True else x `c` xs False - -{-# RULES -"dropWhile" [~1] forall p xs. dropWhile p xs = - build (\c n -> foldr (dropWhileFB p c n) (flipSeq n) xs True) -"dropWhileList" [1] forall p xs. foldr (dropWhileFB p (:) []) (flipSeq []) xs True = dropWhile p xs - #-} - -- | 'take' @n@, applied to a list @xs@, returns the prefix of @xs@ -- of length @n@, or @xs@ itself if @n >= 'length' xs@. -- @@ -998,31 +987,17 @@ drop n xs | n <= 0 = xs drop _ [] = [] drop n (_:xs) = drop (n-1) xs #else /* hack away */ -{-# INLINE[1] drop #-} -- Why [1]? See justification on take! => RULES +{-# INLINE drop #-} drop n ls | n <= 0 = ls | otherwise = unsafeDrop n ls - --- A version of drop that drops the whole list if given an argument --- less than 1 -{-# NOINLINE [0] unsafeDrop #-} -- See Note [Inline FB functions] -unsafeDrop :: Int -> [a] -> [a] -unsafeDrop !_ [] = [] -unsafeDrop 1 (_:xs) = xs -unsafeDrop m (_:xs) = unsafeDrop (m - 1) xs - -{-# RULES -"drop" [~1] forall n xs . drop n xs = - build (\c nil -> if n <= 0 - then foldr c nil xs - else foldr (dropFB c nil) (flipSeq nil) xs n) -"unsafeDropList" [1] forall n xs . foldr (dropFB (:) []) (flipSeq []) xs n - = unsafeDrop n xs - #-} - -{-# INLINE [0] dropFB #-} -- See Note [Inline FB functions] -dropFB :: (a -> b -> b) -> b -> a -> (Int -> b) -> Int -> b -dropFB c _n x xs = \ m -> if m <= 0 then x `c` xs m else xs (m-1) + where + -- A version of drop that drops the whole list if given an argument + -- less than 1 + unsafeDrop :: Int -> [a] -> [a] + unsafeDrop !_ [] = [] + unsafeDrop 1 (_:xs) = xs + unsafeDrop m (_:xs) = unsafeDrop (m - 1) xs #endif -- | 'splitAt' @n xs@ returns a tuple where first element is @xs@ prefix of diff --git a/testsuite/tests/perf/should_run/T18964.hs b/testsuite/tests/perf/should_run/T18964.hs index e9c7b915e7..8b6b0a0717 100644 --- a/testsuite/tests/perf/should_run/T18964.hs +++ b/testsuite/tests/perf/should_run/T18964.hs @@ -3,6 +3,9 @@ import Data.Int main :: IO () main = do + -- This test aims to track #18964, the fix of which had to be reverted in the + -- wake of #23021. The comments below apply to a world where #18964 is fixed. + -------------------- -- drop should fuse away and the program should consume O(1) space -- If fusion fails, this allocates about 640MB. print $ sum $ drop 10 [0..10000000::Int64] diff --git a/testsuite/tests/perf/should_run/T23021.hs b/testsuite/tests/perf/should_run/T23021.hs new file mode 100644 index 0000000000..f68e7ecbcb --- /dev/null +++ b/testsuite/tests/perf/should_run/T23021.hs @@ -0,0 +1,30 @@ +-- The direct implementation of drop and dropWhile operates in O(1) space. +-- This regression test asserts that potential fusion rules for dropWhile/drop +-- maintain that property for the fused pipelines in dropWhile2 and drop2 (which +-- are marked NOINLINE for that purpose). +-- #23021 was opened because we had fusion rules in place that did not maintain +-- this property. + +dropWhile2 :: Int -> [Int] -> [Int] +dropWhile2 n = dropWhile (< n) . dropWhile (< n) +{-# NOINLINE dropWhile2 #-} + +drop2 :: Int -> [Int] -> [Int] +drop2 n = drop n . drop n +{-# NOINLINE drop2 #-} + +main :: IO () +main = do + let xs = [0..9999999] + print $ last $ dropWhile2 0 xs + print $ last $ dropWhile2 1 xs + print $ last $ dropWhile2 2 xs + print $ last $ dropWhile2 3 xs + print $ last $ dropWhile2 4 xs + print $ last $ dropWhile2 5 xs + print $ last $ drop2 0 xs + print $ last $ drop2 1 xs + print $ last $ drop2 2 xs + print $ last $ drop2 3 xs + print $ last $ drop2 4 xs + print $ last $ drop2 5 xs diff --git a/testsuite/tests/perf/should_run/T23021.stdout b/testsuite/tests/perf/should_run/T23021.stdout new file mode 100644 index 0000000000..2b2ad97061 --- /dev/null +++ b/testsuite/tests/perf/should_run/T23021.stdout @@ -0,0 +1,12 @@ +9999999 +9999999 +9999999 +9999999 +9999999 +9999999 +9999999 +9999999 +9999999 +9999999 +9999999 +9999999 diff --git a/testsuite/tests/perf/should_run/all.T b/testsuite/tests/perf/should_run/all.T index 89b690971a..46c69cbca2 100644 --- a/testsuite/tests/perf/should_run/all.T +++ b/testsuite/tests/perf/should_run/all.T @@ -411,4 +411,7 @@ test('T21839r', compile_and_run, ['-O']) +# #18964 should be marked expect_broken, but it's still useful to track that +# perf doesn't regress further, so it is not marked as such. test('T18964', [collect_stats('bytes allocated', 1), only_ways(['normal'])], compile_and_run, ['-O']) +test('T23021', [collect_stats('bytes allocated', 1), only_ways(['normal'])], compile_and_run, ['-O2']) |