[Git][ghc/ghc][wip/revert-drop-fusion] Revert the main payload of "Make `drop` and `dropWhile` fuse (#18964)"
Sebastian Graf (@sgraf812)
gitlab at gitlab.haskell.org
Tue Feb 28 13:12:58 UTC 2023
Sebastian Graf pushed to branch wip/revert-drop-fusion at Glasgow Haskell Compiler / GHC
Commits:
094ffd1a by Sebastian Graf at 2023-02-28T14:09:58+01:00
Revert the main payload of "Make `drop` and `dropWhile` fuse (#18964)"
This reverts the bits affecting fusion of `drop` and `dropWhile` of commit
0f7588b5df1fc7a58d8202761bf1501447e48914 and keeps just the small refactoring
unifying `flipSeqTake` and `flipSeqScanl'` into `flipSeq`.
It also adds a new test for #23021 (which was the reason for reverting) as
well as adds a clarifying comment to T18964.
Fixes #23021, unfixes #18964.
Metric Increase:
T18964
Metric Decrease:
T18964
- - - - -
5 changed files:
- libraries/base/GHC/List.hs
- testsuite/tests/perf/should_run/T18964.hs
- + testsuite/tests/perf/should_run/T23021.hs
- + testsuite/tests/perf/should_run/T23021.stdout
- testsuite/tests/perf/should_run/all.T
Changes:
=====================================
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 at .
--
@@ -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
=====================================
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]
=====================================
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
=====================================
testsuite/tests/perf/should_run/T23021.stdout
=====================================
@@ -0,0 +1,12 @@
+9999999
+9999999
+9999999
+9999999
+9999999
+9999999
+9999999
+9999999
+9999999
+9999999
+9999999
+9999999
=====================================
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'])
View it on GitLab: https://gitlab.haskell.org/ghc/ghc/-/commit/094ffd1a091d9052f40da8925119e2ba25907f51
--
View it on GitLab: https://gitlab.haskell.org/ghc/ghc/-/commit/094ffd1a091d9052f40da8925119e2ba25907f51
You're receiving this email because of your account on gitlab.haskell.org.
-------------- next part --------------
An HTML attachment was scrubbed...
URL: <http://mail.haskell.org/pipermail/ghc-commits/attachments/20230228/2fb328bb/attachment-0001.html>
More information about the ghc-commits
mailing list