Re: [GHC] #16357: Add `oneShot` to the implementation of foldlM

#16357: Add `oneShot` to the implementation of foldlM -------------------------------------+------------------------------------- Reporter: autotaker | Owner: (none) Type: bug | Status: new Priority: normal | Milestone: Component: libraries/base | Version: 8.9 Resolution: | Keywords: Operating System: Unknown/Multiple | Architecture: | Unknown/Multiple Type of failure: None/Unknown | Test Case: Blocked By: | Blocking: Related Tickets: | Differential Rev(s): Wiki Page: | -------------------------------------+------------------------------------- Description changed by autotaker: Old description:

The current (473632d7671619ee08a2a0025aa22bd4f79eca2d) implementation of `Data.Foldable.foldlM` is the like this {{{#!hs 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 {-# INLINE c #-} }}}

It generates an inefficient core for the following example. {{{#!hs f :: Int -> IO Int f = foldlM (\a b -> pure $! (a + b)) 0 (filter even [1..n]) }}}

Generated core: {{{#!hs -- RHS size: {terms: 48, types: 22, coercions: 12, joins: 0/1} Main.$wf [InlPrag=NOUSERINLINE[2]] :: GHC.Prim.Int# -> GHC.Prim.State# GHC.Prim.RealWorld -> (# GHC.Prim.State# GHC.Prim.RealWorld, Int #) [GblId, Arity=2, Caf=NoCafRefs, Str=, Unf=Unf{Src=<vanilla>, TopLvl=True, Value=True, ConLike=True, WorkFree=True, Expandable=True, Guidance=IF_ARGS [0 0] 216 30}] Main.$wf = \ (ww_s6TZ :: GHC.Prim.Int#) (w_s6TW :: GHC.Prim.State# GHC.Prim.RealWorld) -> case GHC.Prim.># 1# ww_s6TZ of { __DEFAULT -> letrec { go_a5un [Occ=LoopBreaker] :: GHC.Prim.Int# -> Int -> IO Int [LclId, Arity=1, Str=, Unf=OtherCon []] go_a5un = \ (x_a5uo :: GHC.Prim.Int#) -> case GHC.Prim.remInt# x_a5uo 2# of { __DEFAULT -> case GHC.Prim.==# x_a5uo ww_s6TZ of { __DEFAULT -> go_a5un (GHC.Prim.+# x_a5uo 1#); 1# -> (GHC.Base.$fApplicativeIO4 @ Int) `cast` (<Int>_R ->_R Sym (GHC.Types.N:IO[0] <Int>_R) :: (Int -> GHC.Prim.State# GHC.Prim.RealWorld -> (# GHC.Prim.State# GHC.Prim.RealWorld, Int #)) ~R# (Int -> IO Int)) }; 0# -> Main.main_c @ Int (GHC.Types.I# x_a5uo) (case GHC.Prim.==# x_a5uo ww_s6TZ of { __DEFAULT -> go_a5un (GHC.Prim.+# x_a5uo 1#); 1# -> (GHC.Base.$fApplicativeIO4 @ Int) `cast` (<Int>_R ->_R Sym (GHC.Types.N:IO[0] <Int>_R) :: (Int -> GHC.Prim.State# GHC.Prim.RealWorld -> (# GHC.Prim.State# GHC.Prim.RealWorld, Int #)) ~R# (Int -> IO Int)) }) }; } in ((go_a5un 1# Main.main4) `cast` (GHC.Types.N:IO[0] <Int>_R :: IO Int ~R# (GHC.Prim.State# GHC.Prim.RealWorld -> (# GHC.Prim.State# GHC.Prim.RealWorld, Int #)))) w_s6TW; 1# -> (# w_s6TW, Main.main4 #) } }}} It seems that the main loop `go_a5un` is not eta-expanded.

I think problem is that `oneShot` is missing in the definition of `foldlM`.

When I changed the definition of `foldlM` as follows, {{{#!hs import GHC.Exts(oneShot) 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 = oneShot (\z -> f z x >>= k) {-# INLINE c #-} }}}

Then, the main loop of the `wf` is eta-expaned as expected. {{{#!hs -- RHS size: {terms: 64, types: 46, coercions: 0, joins: 1/1} Main.$wf [InlPrag=NOUSERINLINE[2]] :: GHC.Prim.Int# -> GHC.Prim.State# GHC.Prim.RealWorld -> (# GHC.Prim.State# GHC.Prim.RealWorld, Int #) [GblId, Arity=2, Caf=NoCafRefs, Str=, Unf=Unf{Src=<vanilla>, TopLvl=True, Value=True, ConLike=True, WorkFree=True, Expandable=True, Guidance=IF_ARGS [0 0] 136 30}] Main.$wf = \ (ww_s6Xc :: GHC.Prim.Int#) (w_s6X9 :: GHC.Prim.State# GHC.Prim.RealWorld) -> case GHC.Prim.># 1# ww_s6Xc of { __DEFAULT -> joinrec { go_s6WG [Occ=LoopBreaker] :: GHC.Prim.Int# -> Int -> GHC.Prim.State# GHC.Prim.RealWorld -> (# GHC.Prim.State# GHC.Prim.RealWorld, Int #) [LclId[JoinId(3)], Arity=3, Str=, Unf=OtherCon []] go_s6WG (x_a5xy :: GHC.Prim.Int#) (eta_B2 :: Int) (eta1_Xz :: GHC.Prim.State# GHC.Prim.RealWorld) = case GHC.Prim.remInt# x_a5xy 2# of { __DEFAULT -> case GHC.Prim.==# x_a5xy ww_s6Xc of { __DEFAULT -> jump go_s6WG (GHC.Prim.+# x_a5xy 1#) eta_B2 eta1_Xz; 1# -> (# eta1_Xz, eta_B2 #) }; 0# -> case eta_B2 of { GHC.Types.I# x1_a5t8 -> case GHC.Prim.==# x_a5xy ww_s6Xc of { __DEFAULT -> jump go_s6WG (GHC.Prim.+# x_a5xy 1#) (GHC.Types.I# (GHC.Prim.+# x1_a5t8 x_a5xy)) eta1_Xz; 1# -> (# eta1_Xz, GHC.Types.I# (GHC.Prim.+# x1_a5t8 x_a5xy) #) } } }; } in jump go_s6WG 1# Main.main4 w_s6X9; 1# -> (# w_s6X9, Main.main4 #) } }}}

New description: The current (473632d7671619ee08a2a0025aa22bd4f79eca2d) implementation of `Data.Foldable.foldlM` is the like this {{{#!hs 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 {-# INLINE c #-} }}} It generates an inefficient core for the following example. {{{#!hs f :: Int -> IO Int f n = foldlM (\a b -> pure $! (a + b)) 0 (filter even [1..n]) }}} Generated core: {{{#!hs -- RHS size: {terms: 48, types: 22, coercions: 12, joins: 0/1} Main.$wf [InlPrag=NOUSERINLINE[2]] :: GHC.Prim.Int# -> GHC.Prim.State# GHC.Prim.RealWorld -> (# GHC.Prim.State# GHC.Prim.RealWorld, Int #) [GblId, Arity=2, Caf=NoCafRefs, Str=, Unf=Unf{Src=<vanilla>, TopLvl=True, Value=True, ConLike=True, WorkFree=True, Expandable=True, Guidance=IF_ARGS [0 0] 216 30}] Main.$wf = \ (ww_s6TZ :: GHC.Prim.Int#) (w_s6TW :: GHC.Prim.State# GHC.Prim.RealWorld) -> case GHC.Prim.># 1# ww_s6TZ of { __DEFAULT -> letrec { go_a5un [Occ=LoopBreaker] :: GHC.Prim.Int# -> Int -> IO Int [LclId, Arity=1, Str=, Unf=OtherCon []] go_a5un = \ (x_a5uo :: GHC.Prim.Int#) -> case GHC.Prim.remInt# x_a5uo 2# of { __DEFAULT -> case GHC.Prim.==# x_a5uo ww_s6TZ of { __DEFAULT -> go_a5un (GHC.Prim.+# x_a5uo 1#); 1# -> (GHC.Base.$fApplicativeIO4 @ Int) `cast` (<Int>_R ->_R Sym (GHC.Types.N:IO[0] <Int>_R) :: (Int -> GHC.Prim.State# GHC.Prim.RealWorld -> (# GHC.Prim.State# GHC.Prim.RealWorld, Int #)) ~R# (Int -> IO Int)) }; 0# -> Main.main_c @ Int (GHC.Types.I# x_a5uo) (case GHC.Prim.==# x_a5uo ww_s6TZ of { __DEFAULT -> go_a5un (GHC.Prim.+# x_a5uo 1#); 1# -> (GHC.Base.$fApplicativeIO4 @ Int) `cast` (<Int>_R ->_R Sym (GHC.Types.N:IO[0] <Int>_R) :: (Int -> GHC.Prim.State# GHC.Prim.RealWorld -> (# GHC.Prim.State# GHC.Prim.RealWorld, Int #)) ~R# (Int -> IO Int)) }) }; } in ((go_a5un 1# Main.main4) `cast` (GHC.Types.N:IO[0] <Int>_R :: IO Int ~R# (GHC.Prim.State# GHC.Prim.RealWorld -> (# GHC.Prim.State# GHC.Prim.RealWorld, Int #)))) w_s6TW; 1# -> (# w_s6TW, Main.main4 #) } }}} It seems that the main loop `go_a5un` is not eta-expanded. I think problem is that `oneShot` is missing in the definition of `foldlM`. When I changed the definition of `foldlM` as follows, {{{#!hs import GHC.Exts(oneShot) 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 = oneShot (\z -> f z x >>= k) {-# INLINE c #-} }}} Then, the main loop of the `wf` is eta-expaned as expected. {{{#!hs -- RHS size: {terms: 64, types: 46, coercions: 0, joins: 1/1} Main.$wf [InlPrag=NOUSERINLINE[2]] :: GHC.Prim.Int# -> GHC.Prim.State# GHC.Prim.RealWorld -> (# GHC.Prim.State# GHC.Prim.RealWorld, Int #) [GblId, Arity=2, Caf=NoCafRefs, Str=, Unf=Unf{Src=<vanilla>, TopLvl=True, Value=True, ConLike=True, WorkFree=True, Expandable=True, Guidance=IF_ARGS [0 0] 136 30}] Main.$wf = \ (ww_s6Xc :: GHC.Prim.Int#) (w_s6X9 :: GHC.Prim.State# GHC.Prim.RealWorld) -> case GHC.Prim.># 1# ww_s6Xc of { __DEFAULT -> joinrec { go_s6WG [Occ=LoopBreaker] :: GHC.Prim.Int# -> Int -> GHC.Prim.State# GHC.Prim.RealWorld -> (# GHC.Prim.State# GHC.Prim.RealWorld, Int #) [LclId[JoinId(3)], Arity=3, Str=, Unf=OtherCon []] go_s6WG (x_a5xy :: GHC.Prim.Int#) (eta_B2 :: Int) (eta1_Xz :: GHC.Prim.State# GHC.Prim.RealWorld) = case GHC.Prim.remInt# x_a5xy 2# of { __DEFAULT -> case GHC.Prim.==# x_a5xy ww_s6Xc of { __DEFAULT -> jump go_s6WG (GHC.Prim.+# x_a5xy 1#) eta_B2 eta1_Xz; 1# -> (# eta1_Xz, eta_B2 #) }; 0# -> case eta_B2 of { GHC.Types.I# x1_a5t8 -> case GHC.Prim.==# x_a5xy ww_s6Xc of { __DEFAULT -> jump go_s6WG (GHC.Prim.+# x_a5xy 1#) (GHC.Types.I# (GHC.Prim.+# x1_a5t8 x_a5xy)) eta1_Xz; 1# -> (# eta1_Xz, GHC.Types.I# (GHC.Prim.+# x1_a5t8 x_a5xy) #) } } }; } in jump go_s6WG 1# Main.main4 w_s6X9; 1# -> (# w_s6X9, Main.main4 #) } }}} -- -- Ticket URL: http://ghc.haskell.org/trac/ghc/ticket/16357#comment:1 GHC http://www.haskell.org/ghc/ The Glasgow Haskell Compiler