GitLab

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@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:

Trac metadata

Trac field	Value
Version	7.6.3
Type	Bug
TypeOfFailure	OtherFailure
Priority	normal
Resolution	Unresolved
Component	Compiler
Test case
Differential revisions
BlockedBy
Related
Blocking
CC
Operating system
Architecture