Improve Foldable instances.
authorMilan Straka <fox@ucw.cz>
Sun, 9 Jun 2013 11:23:22 +0000 (13:23 +0200)
committerMilan Straka <fox@ucw.cz>
Sun, 9 Jun 2013 11:23:22 +0000 (13:23 +0200)
- 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.

Data/IntMap/Base.hs
Data/Map/Base.hs
Data/Set/Base.hs

index 263f539..8e21d7c 100644 (file)
@@ -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)
index e44bb9e..19918b1 100644 (file)
@@ -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 = ()
index a7a73e6..3037717 100644 (file)
@@ -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__