Rewrite Data.IntMap to be faster and use less memory

containers-tests/benchmarks/IntMap.hs

@@ -13,9 +13,12 @@ import Prelude hiding (lookup)
 main = do
     let m = M.fromAscList elems :: M.IntMap Int
     evaluate $ rnf [m]
+    evaluate $ rnf missKeys
     defaultMain
-        [ bench "lookup" $ whnf (lookup keys) m
-        , bench "insert" $ whnf (ins elems) M.empty
+        [ bench "size" $ whnf M.size m
+        , bench "lookup hit"  $ whnf (lookup keys) m
+        , bench "lookup miss" $ whnf (lookup missKeys) m
+        , bench "insert empty" $ whnf (ins elems) M.empty
         , bench "insertWith empty" $ whnf (insWith elems) M.empty
         , bench "insertWith update" $ whnf (insWith elems) m
         , bench "insertWith' empty" $ whnf (insWith' elems) M.empty
@@ -28,13 +31,18 @@ main = do
         , bench "insertLookupWithKey update" $ whnf (insLookupWithKey elems) m
         , bench "map" $ whnf (M.map (+ 1)) m
         , bench "mapWithKey" $ whnf (M.mapWithKey (+)) m
-        , bench "foldlWithKey" $ whnf (ins elems) m
+        , bench "foldlWithKey" $ whnf (M.foldlWithKey consPairL []) m
         , bench "foldlWithKey'" $ whnf (M.foldlWithKey' sum 0) m
-        , bench "foldrWithKey" $ whnf (M.foldrWithKey consPair []) m
-        , bench "delete" $ whnf (del keys) m
-        , bench "update" $ whnf (upd keys) m
-        , bench "updateLookupWithKey" $ whnf (upd' keys) m
-        , bench "alter"  $ whnf (alt keys) m
+        , bench "foldrWithKey" $ whnf (M.foldrWithKey consPairR []) m
+        , bench "foldrWithKey'" $ whnf (M.foldrWithKey' sum 0) m
+        , bench "delete hit"  $ whnf (del keys) m
+        , bench "delete miss" $ whnf (del missKeys) m
+        , bench "update hit"  $ whnf (upd keys) m
+        , bench "update miss" $ whnf (upd missKeys) m
+        , bench "updateLookupWithKey hit"  $ whnf (upd' keys) m
+        , bench "updateLookupWithKey miss" $ whnf (upd' missKeys) m
+        , bench "alter hit"   $ whnf (alt keys) m
+        , bench "alter miss"  $ whnf (alt missKeys) m
         , bench "mapMaybe" $ whnf (M.mapMaybe maybeDel) m
         , bench "mapMaybeWithKey" $ whnf (M.mapMaybeWithKey (const maybeDel)) m
         , bench "fromList" $ whnf M.fromList elems
@@ -45,10 +53,12 @@ main = do
         ]
   where
     elems = zip keys values
-    keys = [1..2^12]
-    values = [1..2^12]
+    keys = [1,3..2^13]
+    missKeys = [0,2..2^13]
+    values = [1,3..2^13]
     sum k v1 v2 = k + v1 + v2
-    consPair k v xs = (k, v) : xs
+    consPairL xs k v = (k, v) : xs
+    consPairR k v xs = (k, v) : xs
 
 add3 :: Int -> Int -> Int -> Int
 add3 x y z = x + y + z

containers-tests/benchmarks/LookupGE/IntMap.hs

@@ -34,9 +34,7 @@ main = do
           , \(n,fun) -> bench (n++" !far")     $ nf (fge2 fun odds)  m_large
           ]
     funs1 = [ ("GE split", M.lookupGE1)
-            , ("GE Craig", M.lookupGE2)
-            , ("GE Twan", M.lookupGE3)
-            , ("GE Milan", M.lookupGE4) ]
+            , ("GE direct", M.lookupGE2) ]
 
 fge :: (Int -> M.IntMap Int -> Maybe (Int,Int)) -> [Int] -> M.IntMap Int -> (Int,Int)
 fge fun xs m = foldl' (\n k -> fromMaybe n (fun k m)) (0,0) xs

containers-tests/benchmarks/LookupGE/LookupGE_IntMap.hs

@@ -10,63 +10,8 @@ lookupGE1 k m =
         (_,Just v,_)  -> Just (k,v)
         (_,Nothing,r) -> findMinMaybe r
 
-lookupGE2 :: Key -> IntMap a -> Maybe (Key,a)
-lookupGE2 k t = case t of
-    Bin _ m l r | m < 0 -> if k >= 0
-      then go l
-      else case go r of
-        Nothing -> Just $ findMin l
-        justx -> justx
-    _ -> go t
-  where
-    go (Bin p m l r)
-      | nomatch k p m = if k < p
-        then Just $ findMin l
-        else Nothing
-      | zero k m = case go l of
-        Nothing -> Just $ findMin r
-        justx -> justx
-      | otherwise = go r
-    go (Tip ky y)
-      | k > ky = Nothing
-      | otherwise = Just (ky, y)
-    go Nil = Nothing
 
-lookupGE3 :: Key -> IntMap a -> Maybe (Key,a)
-lookupGE3 k t = k `seq` case t of
-    Bin _ m l r | m < 0 -> if k >= 0
-      then go Nothing l
-      else go (Just (findMin l)) r
-    _ -> go Nothing t
-  where
-    go def (Bin p m l r)
-      | nomatch k p m = if k < p then Just $ findMin l else def
-      | zero k m  = go (Just $ findMin r) l
-      | otherwise = go def r
-    go def (Tip ky y)
-      | k > ky    = def
-      | otherwise = Just (ky, y)
-    go def Nil  = def
-
-lookupGE4 :: Key -> IntMap a -> Maybe (Key,a)
-lookupGE4 k t = k `seq` case t of
-    Bin _ m l r | m < 0 -> if k >= 0 then go Nil l
-                                     else go l r
-    _ -> go Nil t
-  where
-    go def (Bin p m l r)
-      | nomatch k p m = if k < p then fMin l else fMin def
-      | zero k m  = go r l
-      | otherwise = go def r
-    go def (Tip ky y)
-      | k > ky    = fMin def
-      | otherwise = Just (ky, y)
-    go def Nil  = fMin def
-
-    fMin :: IntMap a -> Maybe (Key, a)
-    fMin Nil = Nothing
-    fMin (Tip ky y) = Just (ky, y)
-    fMin (Bin _ _ l _) = fMin l
+lookupGE2 = lookupGE
 
 -------------------------------------------------------------------------------
 -- Utilities
@@ -85,10 +30,5 @@ findMinMaybe m
 
 prop_lookupGE12 :: Int -> [Int] -> Bool
 prop_lookupGE12 x xs = case fromList $ zip xs xs of m -> lookupGE1 x m == lookupGE2 x m
-
-prop_lookupGE13 :: Int -> [Int] -> Bool
-prop_lookupGE13 x xs = case fromList $ zip xs xs of m -> lookupGE1 x m == lookupGE3 x m
-
-prop_lookupGE14 :: Int -> [Int] -> Bool
-prop_lookupGE14 x xs = case fromList $ zip xs xs of m -> lookupGE1 x m == lookupGE4 x m
 #endif
+

containers-tests/benchmarks/SetOperations/SetOperations-IntMap.hs

@@ -3,4 +3,12 @@ module Main where
 import Data.IntMap as C
 import SetOperations
 
-main = benchmark (\xs -> fromList [(x, x) | x <- xs]) True [("union", C.union), ("difference", C.difference), ("intersection", C.intersection)]
+main = benchmark (\xs -> fromList [(x, x) | x <- xs]) True
+    [ ("union", C.union)
+    , ("unionWith", C.unionWith (+))
+    , ("difference", C.difference)
+    , ("differenceWith (keep)", C.differenceWith (\a b -> Just (a + b)))
+    , ("differenceWith (delete)", C.differenceWith (\_ _ -> Nothing))
+    , ("intersection", C.intersection)
+    , ("intersectionWith", C.intersectionWith (+))
+    ]

containers-tests/benchmarks/bench-cmp.pl

@@ -10,15 +10,49 @@
 my $l2 = <$f2>;
 $l1 eq $l2 or die "CSV files do not correspond -- $l1 and $l2";
 
+my $min = 1e50;
+my $mult = 1.0;
+my $max = 0.0;
+my $count = 0;
+
 while (defined($l1 = <$f1>)) {
   $l2 = <$f2>;
 
   my @parts1 = split /,/, $l1;
   my @parts2 = split /,/, $l2;
 
   $parts1[0] eq $parts2[0] or die "CSV files do not correspond -- $parts1[0] and $parts2[0]";
-  printf "%s;%+7.2f%%;%.2e\n", $parts1[0], 100 * $parts2[1] / $parts1[1] - 100, $parts1[1];
+
+  my $factor;
+  if ($parts1[1] == 0) {
+      if ($parts2[1] == 0) {
+          $factor = 1;
+      } else {
+          $factor = 'inf';
+      }
+  } else {
+      $factor = $parts2[1] / $parts1[1];
+  }
+  $count = $count + 1;
+  $mult = $mult * $factor;
+  if ($factor > $max) {
+      $max = $factor;
+  }
+  if ($factor < $min) {
+      $min = $factor;
+  }
+
+  if ($factor == 'inf') {
+    printf "%s;%.2e;%.2e\n", $parts1[0], $parts2[1], $parts1[1];
+  } else {
+    printf "%s;%+7.2f%%;%.2e\n", $parts1[0], 100 * $factor - 100, $parts1[1];
+  }
 }
 
+printf ";\n";
+printf "Minimum;%+7.2f%%\n", ($min - 1.0)*100;
+printf "Average;%+7.2f%%\n", (($mult ** (1.0 / $count)) - 1.0) * 100;
+printf "Maximum;%+7.2f%%\n", ($max - 1.0) * 100;
+
 close $f2;
 close $f1;

containers-tests/containers-tests.cabal

@@ -55,10 +55,10 @@ library
     Data.IntMap.Internal
     Data.IntMap.Internal.Debug
     Data.IntMap.Lazy
+    Data.IntMap.Merge.Internal
     Data.IntMap.Merge.Lazy
     Data.IntMap.Merge.Strict
     Data.IntMap.Strict
-    Data.IntMap.Strict.Internal
     Data.IntSet
     Data.IntSet.Internal
     Data.Map
@@ -90,6 +90,7 @@ library
       Data.IntMap.Internal.DeprecatedDebug
       Data.Map.Internal.DeprecatedShowTree
       Utils.Containers.Internal.TypeError
+      Utils.Containers.Internal.IsList
 
   if impl(ghc >= 8.6)
     ghc-options: -Werror
@@ -319,14 +320,13 @@ test-suite intmap-lazy-properties
   hs-source-dirs:   tests
   main-is:          intmap-properties.hs
   type:             exitcode-stdio-1.0
-  other-modules:    IntMapValidity
   build-depends:    containers-tests
   build-depends:
       array    >=0.4.0.0
     , base     >=4.6     && <5
     , deepseq  >=1.2     && <1.5
 
-  ghc-options:      -O2
+  ghc-options:      -O1
   other-extensions:
     BangPatterns
     CPP
@@ -343,14 +343,13 @@ test-suite intmap-strict-properties
   main-is:          intmap-properties.hs
   type:             exitcode-stdio-1.0
   cpp-options:      -DSTRICT
-  other-modules:    IntMapValidity
   build-depends:    containers-tests
   build-depends:
       array    >=0.4.0.0
     , base     >=4.6     && <5
     , deepseq  >=1.2     && <1.5
 
-  ghc-options:      -O2
+  ghc-options:      -O1
   other-extensions:
     BangPatterns
     CPP