[commit: containers] master: Improve {Map, Set}.intersection. (b19776e)

Repository : ssh://darcs.haskell.org//srv/darcs/packages/containers

On branch  : master

http://hackage.haskell.org/trac/ghc/changeset/b19776e51d99f9264c9449952950f5f6071a0aa3

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

commit b19776e51d99f9264c9449952950f5f6071a0aa3
Author: Milan Straka <[email protected]>
Date:   Fri Apr 27 11:30:13 2012 +0200

    Improve {Map, Set}.intersection.
    
    Use the hedge-intersection algorithm, similar to hedge-union and
    hedge-difference.
    
    Depending on inputs, this causes up to 80% speedup.
    
    Also remove Set.splitLookup, which was used only to define intersection.

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

 Data/Map/Base.hs |   23 ++++++++++++++---------
 Data/Set/Base.hs |   48 ++++++++++++++++++++----------------------------
 2 files changed, 34 insertions(+), 37 deletions(-)

diff --git a/Data/Map/Base.hs b/Data/Map/Base.hs
index 900099e..ae22b51 100644
--- a/Data/Map/Base.hs
+++ b/Data/Map/Base.hs
@@ -1401,19 +1401,24 @@ hedgeDiffWithKey f blo bhi t (Bin _ kx x l r)
 intersection :: Ord k => Map k a -> Map k b -> Map k a
 intersection Tip _ = Tip
 intersection _ Tip = Tip
-intersection t1@(Bin s1 k1 x1 l1 r1) t2@(Bin s2 k2 _ l2 r2) =
-   if s1 >= s2 then
-     case splitLookupWithKey k2 t1 of
-       (lt, Just (k, x), gt) -> join k x (intersection lt l2) (intersection gt r2)
-       (lt, Nothing, gt) -> merge (intersection lt l2) (intersection gt r2)
-   else
-      case splitLookup k1 t2 of
-        (lt, Just _, gt) -> join k1 x1 (intersection l1 lt) (intersection r1 gt)
-        (lt, Nothing, gt) -> merge (intersection l1 lt) (intersection r1 gt)
+intersection t1 t2 = hedgeInt NothingS NothingS t1 t2
 #if __GLASGOW_HASKELL__ >= 700
 {-# INLINABLE intersection #-}
 #endif
 
+hedgeInt :: Ord k => MaybeS k -> MaybeS k -> Map k a -> Map k b -> Map k a
+hedgeInt _ _ _   Tip = Tip
+hedgeInt _ _ Tip _   = Tip
+hedgeInt blo bhi (Bin _ kx x l r) t2
+  = let l' = (hedgeInt blo bmi l (trim blo bmi t2))
+        r' = (hedgeInt bmi bhi r (trim bmi bhi t2))
+    in if kx `member` t2 then join kx x l' r' else merge l' r'
+  where
+    bmi = JustS kx
+#if __GLASGOW_HASKELL__ >= 700
+{-# INLINABLE hedgeInt #-}
+#endif
+
 -- | /O(n+m)/. Intersection with a combining function.
 --
 -- > intersectionWith (++) (fromList [(5, "a"), (3, "b")]) (fromList [(5, "A"), (7, "C")]) == singleton 5 "aA"
diff --git a/Data/Set/Base.hs b/Data/Set/Base.hs
index d72c161..a8573c7 100644
--- a/Data/Set/Base.hs
+++ b/Data/Set/Base.hs
@@ -621,23 +621,24 @@ hedgeDiff blo bhi t (Bin _ x l r)
 intersection :: Ord a => Set a -> Set a -> Set a
 intersection Tip _ = Tip
 intersection _ Tip = Tip
-intersection t1@(Bin s1 x1 l1 r1) t2@(Bin s2 x2 l2 r2) =
-   if s1 >= s2 then
-      let (lt,found,gt) = splitLookup x2 t1
-          tl            = intersection lt l2
-          tr            = intersection gt r2
-      in case found of
-      Just x -> join x tl tr
-      Nothing -> merge tl tr
-   else let (lt,found,gt) = splitMember x1 t2
-            tl            = intersection l1 lt
-            tr            = intersection r1 gt
-        in if found then join x1 tl tr
-           else merge tl tr
+intersection t1 t2 = hedgeInt NothingS NothingS t1 t2
 #if __GLASGOW_HASKELL__ >= 700
 {-# INLINABLE intersection #-}
 #endif
 
+hedgeInt :: Ord a => MaybeS a -> MaybeS a -> Set a -> Set a -> Set a
+hedgeInt _ _ _   Tip = Tip
+hedgeInt _ _ Tip _   = Tip
+hedgeInt blo bhi (Bin _ x l r) t2
+  = let l' = (hedgeInt blo bmi l (trim blo bmi t2))
+        r' = (hedgeInt bmi bhi r (trim bmi bhi t2))
+    in if x `member` t2 then join x l' r' else merge l' r'
+  where
+    bmi = JustS x
+#if __GLASGOW_HASKELL__ >= 700
+{-# INLINABLE hedgeInt #-}
+#endif
+
 {--------------------------------------------------------------------
   Filter and partition
 --------------------------------------------------------------------}
@@ -1000,23 +1001,14 @@ split x (Bin _ y l r)
 -- | /O(log n)/. Performs a 'split' but also returns whether the pivot
 -- element was found in the original set.
 splitMember :: Ord a => a -> Set a -> (Set a,Bool,Set a)
-splitMember x t = let (l,m,r) = splitLookup x t in
-     (l,maybe False (const True) m,r)
-#if __GLASGOW_HASKELL__ >= 700
-{-# INLINABLE splitMember #-}
-#endif
-
--- | /O(log n)/. Performs a 'split' but also returns the pivot
--- element that was found in the original set.
-splitLookup :: Ord a => a -> Set a -> (Set a,Maybe a,Set a)
-splitLookup _ Tip = (Tip,Nothing,Tip)
-splitLookup x (Bin _ y l r)
+splitMember _ Tip = (Tip, False, Tip)
+splitMember x (Bin _ y l r)
    = case compare x y of
-       LT -> let (lt,found,gt) = splitLookup x l in (lt,found,join y gt r)
-       GT -> let (lt,found,gt) = splitLookup x r in (join y l lt,found,gt)
-       EQ -> (l,Just y,r)
+       LT -> let (lt, found, gt) = splitMember x l in (lt, found, join y gt r)
+       GT -> let (lt, found, gt) = splitMember x r in (join y l lt, found, gt)
+       EQ -> (l, True, r)
 #if __GLASGOW_HASKELL__ >= 700
-{-# INLINABLE splitLookup #-}
+{-# INLINABLE splitMember #-}
 #endif
 
 {--------------------------------------------------------------------