[GHC] #7994: Make foldl into a good consumer

[GHC]

#7994: Make foldl into a good consumer
---------------------------------+------------------------------------------
    Reporter:  simonpj           |       Owner:                  
        Type:  bug               |      Status:  new             
    Priority:  normal            |   Milestone:                  
   Component:  Compiler          |     Version:  7.6.3           
    Keywords:                    |          Os:  Unknown/Multiple
Architecture:  Unknown/Multiple  |     Failure:  None/Unknown    
  Difficulty:  Unknown           |    Testcase:                  
   Blockedby:                    |    Blocking:                  
     Related:                    |  
---------------------------------+------------------------------------------
 I really want `foldl` to be a good consumer, but our arity/cardinality
 analysis still isn't up to it. Here's a test case, derived from nofib's
 `x2n1`:
 {{{
 module Foo( foo ) where
 import Data.Complex

 foo x = sum [f n | n <- [1 .. x]]

 f :: Int -> Complex Double
 {-# NOINLINE f #-}
 f n = mkPolar 1 ((2*pi)/fromIntegral n) ^ n
 }}}
 With the patch below (which is what I'd like to use), we get very
 obviously bad code:
 {{{
 Foo.foo :: GHC.Types.Int -> Data.Complex.Complex GHC.Types.Double
 Foo.foo =
   \ (x_aia :: GHC.Types.Int) ->
     case x_aia of _ { GHC.Types.I# y_aye ->
     case GHC.Prim.># 1 y_aye of _ {
       GHC.Types.False ->
         letrec {
           go_aD8 [Occ=LoopBreaker]
             :: GHC.Prim.Int#
                -> Data.Complex.Complex GHC.Types.Double
                -> Data.Complex.Complex GHC.Types.Double
           go_aD8 =
             \ (x_aD9 :: GHC.Prim.Int#) ->
               let {
                 ds_doR [Lbv=OneShot]
                   :: Data.Complex.Complex GHC.Types.Double
                      -> Data.Complex.Complex GHC.Types.Double
                 ds_doR =
                   case GHC.Prim.==# x_aD9 y_aye of _ {
                     GHC.Types.False -> go_aD8 (GHC.Prim.+# x_aD9 1);
                     GHC.Types.True ->
                       GHC.Base.id @ (Data.Complex.Complex
 GHC.Types.Double)
                   } } in
               let {
                 ds_aCs :: Data.Complex.Complex GHC.Types.Double
                 ds_aCs = Foo.f (GHC.Types.I# x_aD9) } in
               \ (ds2_aCu :: Data.Complex.Complex GHC.Types.Double) ->
                 ds_doR (Data.Complex.$fFloatingComplex_$s$c+ ds2_aCu
 ds_aCs); } in
         go_aD8
           1
           (Data.Complex.:+
              @ GHC.Types.Double
              (GHC.Types.D# 0.0)
              Data.Complex.$fFloatingComplex1);
       GHC.Types.True ->
         Data.Complex.:+
           @ GHC.Types.Double
           (GHC.Types.D# 0.0)
           Data.Complex.$fFloatingComplex1   }   }
 }}}
 The local `go` function should have arity 2.

 The patch below is the one I'd like to apply to `base`:


 {{{
 simonpj at cam-05-unx:~/code/HEAD/libraries/base$ git diff
 diff --git a/Data/List.hs b/Data/List.hs
 index e7e8602..a2e7ac0 100644
 --- a/Data/List.hs
 +++ b/Data/List.hs
 @@ -1,5 +1,5 @@
  {-# LANGUAGE Trustworthy #-}
 -{-# LANGUAGE CPP, NoImplicitPrelude, MagicHash #-}
 +{-# LANGUAGE CPP, NoImplicitPrelude, ScopedTypeVariables, MagicHash #-}

 -----------------------------------------------------------------------------
  -- |
 @@ -995,11 +995,15 @@ unfoldr f b  =
  --
 -----------------------------------------------------------------------------

  -- | A strict version of 'foldl'.
 -foldl'           :: (b -> a -> b) -> b -> [a] -> b
 +foldl' :: forall a b. (b -> a -> b) -> b -> [a] -> b
  #ifdef __GLASGOW_HASKELL__
 +{-# INLINE foldl' #-}
 +foldl' k z xs = foldr (\(v::a) (fn::b->b) (z::b) -> z `seq` fn (k z v))
 (id :: b -> b) xs z
 +{-
  foldl' f z0 xs0 = lgo z0 xs0
      where lgo z []     = z
            lgo z (x:xs) = let z' = f z x in z' `seq` lgo z' xs
 +-}
  #else
  foldl' f a []     = a
  foldl' f a (x:xs) = let a' = f a x in a' `seq` foldl' f a' xs
 @@ -1022,6 +1026,17 @@ foldl1' _ []             =  errorEmptyList
 "foldl1'"
  --
 -----------------------------------------------------------------------------
  -- List sum and product

 +-- | The 'sum' function computes the sum of a finite list of numbers.
 +sum                     :: (Num a) => [a] -> a
 +-- | The 'product' function computes the product of a finite list of
 numbers.
 +product                 :: (Num a) => [a] -> a
 +
 +{-# INLINE sum #-}
 +sum                     =  foldl (+) 0
 +{-# INLINE product #-}
 +product                 =  foldl (*) 1
 +
 +{-
  {-# SPECIALISE sum     :: [Int] -> Int #-}
  {-# SPECIALISE sum     :: [Integer] -> Integer #-}
  {-# INLINABLE sum #-}
 @@ -1048,6 +1063,7 @@ product l       = prod l 1
      prod []     a = a
      prod (x:xs) a = prod xs (a*x)
  #endif
 +-}

  --
 -----------------------------------------------------------------------------
  -- Functions on strings
 diff --git a/GHC/List.lhs b/GHC/List.lhs
 index 049aa2a..87c93ae 100644
 --- a/GHC/List.lhs
 +++ b/GHC/List.lhs
 @@ -1,6 +1,6 @@
  \begin{code}
  {-# LANGUAGE Trustworthy #-}
 -{-# LANGUAGE CPP, NoImplicitPrelude, MagicHash #-}
 +{-# LANGUAGE CPP, NoImplicitPrelude, ScopedTypeVariables, MagicHash #-}
  {-# OPTIONS_HADDOCK hide #-}

 -----------------------------------------------------------------------------
 @@ -179,11 +179,17 @@ filterFB c p x r | p x       = x `c` r
  -- can be inlined, and then (often) strictness-analysed,
  -- and hence the classic space leak on foldl (+) 0 xs

 +foldl :: forall a b. (b -> a -> b) -> b -> [a] -> b
 +{-# INLINE foldl #-}
 +foldl k z xs = foldr (\(v::a) (fn::b->b) (z::b) -> fn (k z v)) (id :: b
 -> b) xs z
 +
 +{-
  foldl        :: (b -> a -> b) -> b -> [a] -> b
  foldl f z0 xs0 = lgo z0 xs0
               where
                  lgo z []     =  z
                  lgo z (x:xs) = lgo (f z x) xs
 +-}

  -- | 'scanl' is similar to 'foldl', but returns a list of successive
  -- reduced values from the left:
 }}}

-- 
Ticket URL: <http://hackage.haskell.org/trac/ghc/ticket/7994>
GHC <http://www.haskell.org/ghc/>
The Glasgow Haskell Compiler