Repository : ssh://[email protected]/containers On branch : ghc-head Link : http://git.haskell.org/?p=packages/containers.git;a=commit;h=29d3fbcc67ea4eebc7b381ea5c59673ef1e10dc9
>--------------------------------------------------------------- commit 29d3fbcc67ea4eebc7b381ea5c59673ef1e10dc9 Author: Milan Straka <[email protected]> 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__ _______________________________________________ ghc-commits mailing list [email protected] http://www.haskell.org/mailman/listinfo/ghc-commits
