[commit: packages/containers] ghc-head: Improve Foldable instances. (29d3fbc)

[git at git.haskell.org]

Repository : ssh://git@git.haskell.org/containers

On branch  : ghc-head
Link       : http://git.haskell.org/?p=packages/containers.git;a=commit;h=29d3fbcc67ea4eebc7b381ea5c59673ef1e10dc9

>---------------------------------------------------------------

commit 29d3fbcc67ea4eebc7b381ea5c59673ef1e10dc9
Author: Milan Straka <fox at ucw.cz>
Date:   Sun Jun 9 13:23:22 2013 +0200

    Improve Foldable instances.
    
    - Employ implementation techniques used in normal folds, i.e.,
      * Inline fold and foldMap
      * Capture the function argument and do not pass it in the worker
    
      The Foldable.fold is only INLINABLE, because mappend and mempty depend
      only on Monoid dictionary and are fully specified when Foldable.fold
      is specialized. On the contrary, INLINE foldMap to allow the mapping
      function to be inlined.
    
      This improves complexity by ~60%.
    
    - For Set and Map, add special case for a leaf. This avoids calling
      mempty for the Tips and mappending them with the value in the leaf.
      The improvement is further ~35% for Set and ~30% for Map.
    
      The leaves are recognized by comparing size of the tree to one. They
      could also be recognized by comparing left and right subtree to Tip,
      but that is slower.
    
      Also, cases when only left or right subtree is Tip could be
      recognized, but the implementation is still slower than recognizing
      only leaves using the tree size. It can be proved that at least 66% of
      Tips are under leaf nodes, so we miss at most one third of Tips in
      current implementation and do not cause so much code growth.


>---------------------------------------------------------------

29d3fbcc67ea4eebc7b381ea5c59673ef1e10dc9
 Data/IntMap/Base.hs |   18 ++++++++++++------
 Data/Map/Base.hs    |   16 ++++++++++++----
 Data/Set/Base.hs    |   16 ++++++++++++----
 3 files changed, 36 insertions(+), 14 deletions(-)

diff --git a/Data/IntMap/Base.hs b/Data/IntMap/Base.hs
index 263f539..8e21d7c 100644
--- a/Data/IntMap/Base.hs
+++ b/Data/IntMap/Base.hs
@@ -295,14 +295,20 @@ instance Monoid (IntMap a) where
     mconcat = unions
 
 instance Foldable.Foldable IntMap where
-  fold Nil = mempty
-  fold (Tip _ v) = v
-  fold (Bin _ _ l r) = Foldable.fold l `mappend` Foldable.fold r
+  fold t = go t
+    where go Nil = mempty
+          go (Tip _ v) = v
+          go (Bin _ _ l r) = go l `mappend` go r
+  {-# INLINABLE fold #-}
   foldr = foldr
+  {-# INLINE foldr #-}
   foldl = foldl
-  foldMap _ Nil = mempty
-  foldMap f (Tip _k v) = f v
-  foldMap f (Bin _ _ l r) = Foldable.foldMap f l `mappend` Foldable.foldMap f r
+  {-# INLINE foldl #-}
+  foldMap f t = go t
+    where go Nil = mempty
+          go (Tip _ v) = f v
+          go (Bin _ _ l r) = go l `mappend` go r
+  {-# INLINE foldMap #-}
 
 instance Traversable IntMap where
     traverse f = traverseWithKey (\_ -> f)
diff --git a/Data/Map/Base.hs b/Data/Map/Base.hs
index e44bb9e..19918b1 100644
--- a/Data/Map/Base.hs
+++ b/Data/Map/Base.hs
@@ -2603,12 +2603,20 @@ instance Traversable (Map k) where
   traverse f = traverseWithKey (\_ -> f)
 
 instance Foldable.Foldable (Map k) where
-  fold Tip = mempty
-  fold (Bin _ _ v l r) = Foldable.fold l `mappend` v `mappend` Foldable.fold r
+  fold t = go t
+    where go Tip = mempty
+          go (Bin 1 _ v _ _) = v
+          go (Bin _ _ v l r) = go l `mappend` (v `mappend` go r)
+  {-# INLINABLE fold #-}
   foldr = foldr
+  {-# INLINE foldr #-}
   foldl = foldl
-  foldMap _ Tip = mempty
-  foldMap f (Bin _ _ v l r) = Foldable.foldMap f l `mappend` f v `mappend` Foldable.foldMap f r
+  {-# INLINE foldl #-}
+  foldMap f t = go t
+    where go Tip = mempty
+          go (Bin 1 _ v _ _) = f v
+          go (Bin _ _ v l r) = go l `mappend` (f v `mappend` go r)
+  {-# INLINE foldMap #-}
 
 instance (NFData k, NFData a) => NFData (Map k a) where
     rnf Tip = ()
diff --git a/Data/Set/Base.hs b/Data/Set/Base.hs
index a7a73e6..3037717 100644
--- a/Data/Set/Base.hs
+++ b/Data/Set/Base.hs
@@ -234,12 +234,20 @@ instance Ord a => Monoid (Set a) where
     mconcat = unions
 
 instance Foldable.Foldable Set where
-    fold Tip = mempty
-    fold (Bin _ k l r) = Foldable.fold l `mappend` k `mappend` Foldable.fold r
+    fold t = go t
+      where go Tip = mempty
+            go (Bin 1 k _ _) = k
+            go (Bin _ k l r) = go l `mappend` (k `mappend` go r)
+    {-# INLINABLE fold #-}
     foldr = foldr
+    {-# INLINE foldr #-}
     foldl = foldl
-    foldMap _ Tip = mempty
-    foldMap f (Bin _ k l r) = Foldable.foldMap f l `mappend` f k `mappend` Foldable.foldMap f r
+    {-# INLINE foldl #-}
+    foldMap f t = go t
+      where go Tip = mempty
+            go (Bin 1 k _ _) = f k
+            go (Bin _ k l r) = go l `mappend` (f k `mappend` go r)
+    {-# INLINE foldMap #-}
 
 #if __GLASGOW_HASKELL__