base: Fix eta expansion of foldlMwip/T16357

Previously a program like,

    f :: Int -> IO Int
    f n = foldlM (\a b -> pure $! (a + b)) 0 (filter even [1..n])

would allocate heavily due to repeated allocation of "cons" function
passed to

Fixes #16537.

3 files changed, 13 insertions, 2 deletions

diff --git a/libraries/base/Data/Foldable.hs b/libraries/base/Data/Foldable.hs
index 9460cee2eb..86ea4e0b58 100644
--- a/libraries/base/Data/Foldable.hs
+++ b/libraries/base/Data/Foldable.hs
@@ -1000,8 +1000,8 @@ foldrM f z0 xs = foldl c return xs z0
 --
 foldlM :: (Foldable t, Monad m) => (b -> a -> m b) -> b -> t a -> m b
 foldlM f z0 xs = foldr c return xs z0
-  -- See Note [List fusion and continuations in 'c']
-  where c x k z = f z x >>= k
+  -- See Note [List fusion and continuations in 'c' (foldlM)]
+  where c x k = \z -> f z x >>= k
         {-# INLINE c #-}
 
 -- | Map each element of a structure to an 'Applicative' action, evaluate these
diff --git a/libraries/base/tests/T16357.hs b/libraries/base/tests/T16357.hs
new file mode 100644
index 0000000000..bbf53ff338
--- /dev/null
+++ b/libraries/base/tests/T16357.hs
@@ -0,0 +1,10 @@
+module Main (main) where
+
+import Data.Foldable (foldlM)
+
+f :: Int -> IO Int
+f n = foldlM (\a b -> a `seq` pure (a + b)) 0 (filter even [1..n])
+{-# NOINLINE f #-}
+
+main :: IO ()
+main = f 1000000 >> pure ()
diff --git a/libraries/base/tests/all.T b/libraries/base/tests/all.T
index ac65224ef0..a817794909 100644
--- a/libraries/base/tests/all.T
+++ b/libraries/base/tests/all.T
@@ -255,6 +255,7 @@ test('T13896', normal, compile_and_run, [''])
 test('T13167', fragile_for(16536, concurrent_ways), compile_and_run, [''])
 test('T15349', [exit_code(1), expect_broken_for(15349, ['ghci'])], compile_and_run, [''])
 test('T16111', exit_code(1), compile_and_run, [''])
+test('T16537', collect_stats('bytes allocated', 5), compile_and_run, [''])
 test('T16943a', normal, compile_and_run, [''])
 test('T16943b', normal, compile_and_run, [''])
 test('T17499', [collect_stats('bytes allocated',5)], compile_and_run, ['-O -w'])