[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