Improve {Map,Set}.fromList.
authorMilan Straka <fox@ucw.cz>
Thu, 30 Aug 2012 22:22:21 +0000 (00:22 +0200)
committerMilan Straka <fox@ucw.cz>
Thu, 30 Aug 2012 22:22:21 +0000 (00:22 +0200)
While the input is sorted, use implementation of fromDistinctAscList.
When first unordered key is found, switch to the general fromList
implementation, which inserts the rest of the keys to the already
constructed tree.

This gives a huge advantage for sorted inputs. The inplementation is
5% (for Map) and 0% (for Set) slower than fromDistinctAscList in that case.
The larger overhead for Map is probably because of the the pair unpacking.

For input list of size 2^12, the fromList is 10 times faster if the input
is sorted.

The fromList could be further improved by trying to handle semi-sorted
inputs. But currently I have no idea how to do it efficiently.

Data/Map/Base.hs
Data/Map/Strict.hs
Data/Set/Base.hs

index 61bcfe6..edf0241 100644 (file)
@@ -250,6 +250,7 @@ module Data.Map.Base (
             , balanceR
             , delta
             , join
+            , insertMax
             , merge
             , glue
             , trim
@@ -1916,15 +1917,52 @@ fromSet f (Set.Bin sz x l r) = Bin sz x (f x) (fromSet f l) (fromSet f r)
 -- If the list contains more than one value for the same key, the last value
 -- for the key is retained.
 --
+-- If the keys of the list are ordered, linear-time implementation is used,
+-- with the performance equal to 'fromDistinctAscList'.
+--
 -- > fromList [] == empty
 -- > fromList [(5,"a"), (3,"b"), (5, "c")] == fromList [(5,"c"), (3,"b")]
 -- > fromList [(5,"c"), (3,"b"), (5, "a")] == fromList [(5,"a"), (3,"b")]
 
+-- For some reason, when 'singleton' is used in fromList or in
+-- create, it is not inlined, so we inline it manually.
 fromList :: Ord k => [(k,a)] -> Map k a
-fromList xs
-  = foldlStrict ins empty xs
+fromList [] = Tip
+fromList [(kx, x)] = Bin 1 kx x Tip Tip
+fromList ((kx0, x0) : xs0) | not_ordered kx0 xs0 = fromList' (Bin 1 kx0 x0 Tip Tip) xs0
+                           | otherwise = go (1::Int) (Bin 1 kx0 x0 Tip Tip) xs0
   where
-    ins t (k,x) = insert k x t
+    not_ordered kx [] = False
+    not_ordered kx ((ky,_) : _) = kx >= ky
+    {-# INLINE not_ordered #-}
+
+    fromList' t xs = foldlStrict ins t xs
+      where ins t (k,x) = insert k x t
+
+    STRICT_1_OF_3(go)
+    go _ t [] = t
+    go _ t [(kx, x)] = insertMax kx x t
+    go s l xs@((kx, x) : xss) | not_ordered kx xss = fromList' l xs
+                              | otherwise = case create s xss of
+                                  (r, ys, []) -> go (s `shiftL` 1) (join kx x l r) ys
+                                  (r, _,  ys) -> fromList' (join kx x l r) ys
+
+    -- The create is returning a triple (tree, xs, ys). Both xs and ys
+    -- represent not yet processed elements and only one of them can be nonempty.
+    -- If ys is nonempty, the keys in ys are not ordered with respect to tree
+    -- and must be inserted using fromList'. Otherwise the keys have been
+    -- ordered so far.
+    STRICT_1_OF_2(create)
+    create _ [] = (Tip, [], [])
+    create s xs@(xp : xss)
+      | s == 1 = case xp of (kx, x) | not_ordered kx xss -> (Bin 1 kx x Tip Tip, [], xss)
+                                    | otherwise -> (Bin 1 kx x Tip Tip, xss, [])
+      | otherwise = case create (s `shiftR` 1) xs of
+                      res@(_, [], _) -> res
+                      (l, [(ky, y)], zs) -> (insertMax ky y l, [], zs)
+                      (l, ys@((ky, y):yss), _) | not_ordered ky yss -> (l, [], ys)
+                                               | otherwise -> case create (s `shiftR` 1) yss of
+                                                   (r, zs, ws) -> (join ky y l r, zs, ws)
 #if __GLASGOW_HASKELL__ >= 700
 {-# INLINABLE fromList #-}
 #endif
index 4d8b81b..7bdbc7d 100644 (file)
@@ -1011,15 +1011,52 @@ fromSet f (Set.Bin sz x l r) = case f x of v -> v `seq` Bin sz x v (fromSet f l)
 -- If the list contains more than one value for the same key, the last value
 -- for the key is retained.
 --
+-- If the keys of the list are ordered, linear-time implementation is used,
+-- with the performance equal to 'fromDistinctAscList'.
+--
 -- > fromList [] == empty
 -- > fromList [(5,"a"), (3,"b"), (5, "c")] == fromList [(5,"c"), (3,"b")]
 -- > fromList [(5,"c"), (3,"b"), (5, "a")] == fromList [(5,"a"), (3,"b")]
 
+-- For some reason, when 'singleton' is used in fromList or in
+-- create, it is not inlined, so we inline it manually.
 fromList :: Ord k => [(k,a)] -> Map k a
-fromList xs
-  = foldlStrict ins empty xs
+fromList [] = Tip
+fromList [(kx, x)] = x `seq` Bin 1 kx x Tip Tip
+fromList ((kx0, x0) : xs0) | not_ordered kx0 xs0 = x0 `seq` fromList' (Bin 1 kx0 x0 Tip Tip) xs0
+                           | otherwise = x0 `seq` go (1::Int) (Bin 1 kx0 x0 Tip Tip) xs0
   where
-    ins t (k,x) = insert k x t
+    not_ordered kx [] = False
+    not_ordered kx ((ky,_) : _) = kx >= ky
+    {-# INLINE not_ordered #-}
+
+    fromList' t xs = foldlStrict ins t xs
+      where ins t (k,x) = insert k x t
+
+    STRICT_1_OF_3(go)
+    go _ t [] = t
+    go _ t [(kx, x)] = x `seq` insertMax kx x t
+    go s l xs@((kx, x) : xss) | not_ordered kx xss = fromList' l xs
+                              | otherwise = case create s xss of
+                                  (r, ys, []) -> x `seq` go (s `shiftL` 1) (join kx x l r) ys
+                                  (r, _,  ys) -> x `seq` fromList' (join kx x l r) ys
+
+    -- The create is returning a triple (tree, xs, ys). Both xs and ys
+    -- represent not yet processed elements and only one of them can be nonempty.
+    -- If ys is nonempty, the keys in ys are not ordered with respect to tree
+    -- and must be inserted using fromList'. Otherwise the keys have been
+    -- ordered so far.
+    STRICT_1_OF_2(create)
+    create _ [] = (Tip, [], [])
+    create s xs@(xp : xss)
+      | s == 1 = case xp of (kx, x) | not_ordered kx xss -> x `seq` (Bin 1 kx x Tip Tip, [], xss)
+                                    | otherwise -> x `seq` (Bin 1 kx x Tip Tip, xss, [])
+      | otherwise = case create (s `shiftR` 1) xs of
+                      res@(_, [], _) -> res
+                      (l, [(ky, y)], zs) -> y `seq` (insertMax ky y l, [], zs)
+                      (l, ys@((ky, y):yss), _) | not_ordered ky yss -> (l, [], ys)
+                                               | otherwise -> case create (s `shiftR` 1) yss of
+                                                   (r, zs, ws) -> y `seq` (join ky y l r, zs, ws)
 #if __GLASGOW_HASKELL__ >= 700
 {-# INLINABLE fromList #-}
 #endif
index f324c8e..a3a49bd 100644 (file)
@@ -778,10 +778,49 @@ foldlFB = foldl
 #endif
 
 -- | /O(n*log n)/. Create a set from a list of elements.
+--
+-- If the elemens are ordered, linear-time implementation is used,
+-- with the performance equal to 'fromDistinctAscList'.
+
+-- For some reason, when 'singleton' is used in fromList or in
+-- create, it is not inlined, so we inline it manually.
 fromList :: Ord a => [a] -> Set a
-fromList = foldlStrict ins empty
+fromList [] = Tip
+fromList [x] = Bin 1 x Tip Tip
+fromList (x0 : xs0) | not_ordered x0 xs0 = fromList' (Bin 1 x0 Tip Tip) xs0
+                    | otherwise = go (1::Int) (Bin 1 x0 Tip Tip) xs0
   where
-    ins t x = insert x t
+    not_ordered x [] = False
+    not_ordered x (y : _) = x >= y
+    {-# INLINE not_ordered #-}
+
+    fromList' t xs = foldlStrict ins t xs
+      where ins t x = insert x t
+
+    STRICT_1_OF_3(go)
+    go _ t [] = t
+    go _ t [x] = insertMax x t
+    go s l xs@(x : xss) | not_ordered x xss = fromList' l xs
+                        | otherwise = case create s xss of
+                            (r, ys, []) -> go (s `shiftL` 1) (join x l r) ys
+                            (r, _,  ys) -> fromList' (join x l r) ys
+
+    -- The create is returning a triple (tree, xs, ys). Both xs and ys
+    -- represent not yet processed elements and only one of them can be nonempty.
+    -- If ys is nonempty, the keys in ys are not ordered with respect to tree
+    -- and must be inserted using fromList'. Otherwise the keys have been
+    -- ordered so far.
+    STRICT_1_OF_2(create)
+    create _ [] = (Tip, [], [])
+    create s xs@(x : xss)
+      | s == 1 = if not_ordered x xss then (Bin 1 x Tip Tip, [], xss)
+                                      else (Bin 1 x Tip Tip, xss, [])
+      | otherwise = case create (s `shiftR` 1) xs of
+                      res@(_, [], _) -> res
+                      (l, [y], zs) -> (insertMax y l, [], zs)
+                      (l, ys@(y:yss), _) | not_ordered y yss -> (l, [], ys)
+                                         | otherwise -> case create (s `shiftR` 1) yss of
+                                                   (r, zs, ws) -> (join y l r, zs, ws)
 #if __GLASGOW_HASKELL__ >= 700
 {-# INLINABLE fromList #-}
 #endif