From f437af161457394e1a67d8a400ec04d69924ffd2 Mon Sep 17 00:00:00 2001 From: Matt Renaud Date: Sat, 23 Dec 2017 11:07:16 -0800 Subject: [PATCH 01/17] Initial implementation of alterF RULES. --- Data/IntMap/Internal.hs | 21 +++++++++++++++++++++ 1 file changed, 21 insertions(+) diff --git a/Data/IntMap/Internal.hs b/Data/IntMap/Internal.hs index c0b757038..9088d1154 100644 --- a/Data/IntMap/Internal.hs +++ b/Data/IntMap/Internal.hs @@ -289,6 +289,9 @@ import Data.Functor.Identity (Identity (..)) import Control.Applicative (liftA2) #else import Control.Applicative (Applicative(pure, (<*>)), (<$>), liftA2) +#if MIN_VERSION_base(4,9,0) +import Control.Applicative (Const(..)) +#endif import Data.Monoid (Monoid(..)) import Data.Traversable (Traversable(traverse)) import Data.Word (Word) @@ -980,6 +983,24 @@ alterF f k m = (<$> f mv) $ \fres -> Nothing -> maybe m (const (delete k m)) mv Just v' -> insert k v' m where mv = lookup k m +-- TODO(m-renaud): Figure out if this should be marked INLINE or NOINLINE. +-- It needs to be one or the other or else the specialization rule may not fire. +{-# NOINLINE [1] alterF #-} +{-# RULES +"Identity specialize alterF" forall (f :: Maybe a -> Identity (Maybe a)) k m. + alterF f k m = + Identity $ alter (runIdentity . f) k m + #-} + +#if MIN_VERSION_base(4,9,0) +-- TODO(m-renaud): Figure out where to import Const from from pre-base-4.9 or +-- how to conditionally include pragrams (the #if around this doesn't work :/). +-- {-# RULES +-- "Const specialize alterF" forall (f :: Maybe a -> Const x (Maybe a)) k m. +-- alterF f k m = +-- Const $ alter (getConst . f) k m +-- #-} +#endif {-------------------------------------------------------------------- Union From 091a82d380bfc82311a57913e83ef78eff43a02a Mon Sep 17 00:00:00 2001 From: Matt Renaud Date: Sat, 23 Dec 2017 23:04:29 -0800 Subject: [PATCH 02/17] Add unit tests for alterF inline RULES. --- Data/IntMap/Internal.hs | 16 ++++++------ tests/intmap-properties.hs | 51 ++++++++++++++++++++++++++++++++++++++ 2 files changed, 58 insertions(+), 9 deletions(-) diff --git a/Data/IntMap/Internal.hs b/Data/IntMap/Internal.hs index 9088d1154..56ec06361 100644 --- a/Data/IntMap/Internal.hs +++ b/Data/IntMap/Internal.hs @@ -986,20 +986,18 @@ alterF f k m = (<$> f mv) $ \fres -> -- TODO(m-renaud): Figure out if this should be marked INLINE or NOINLINE. -- It needs to be one or the other or else the specialization rule may not fire. {-# NOINLINE [1] alterF #-} +#if MIN_VERSION_base(4,8,0) {-# RULES "Identity specialize alterF" forall (f :: Maybe a -> Identity (Maybe a)) k m. - alterF f k m = - Identity $ alter (runIdentity . f) k m + alterF f k m = Identity $ alter (runIdentity . f) k m #-} +#endif #if MIN_VERSION_base(4,9,0) --- TODO(m-renaud): Figure out where to import Const from from pre-base-4.9 or --- how to conditionally include pragrams (the #if around this doesn't work :/). --- {-# RULES --- "Const specialize alterF" forall (f :: Maybe a -> Const x (Maybe a)) k m. --- alterF f k m = --- Const $ alter (getConst . f) k m --- #-} +{-# RULES +"Const specialize alterF" forall (f :: Maybe a -> Const x (Maybe a)) k m. + alterF f k m = Const $ alter (getConst . f) k m + #-} #endif {-------------------------------------------------------------------- diff --git a/tests/intmap-properties.hs b/tests/intmap-properties.hs index 3875ec6f0..56c4fe49a 100644 --- a/tests/intmap-properties.hs +++ b/tests/intmap-properties.hs @@ -7,6 +7,12 @@ import Data.IntMap.Lazy as Data.IntMap hiding (showTree) #endif import Data.IntMap.Internal.Debug (showTree) +#if MIN_VERSION_base(4,9,0) +import Control.Applicative (Const(..)) +#endif +#if MIN_VERSION_base(4,8,0) +import Data.Functor.Identity (Identity (..)) +#endif import Data.Monoid import Data.Maybe hiding (mapMaybe) import qualified Data.Maybe as Maybe (mapMaybe) @@ -56,6 +62,7 @@ main = defaultMain , testCase "updateWithKey" test_updateWithKey , testCase "updateLookupWithKey" test_updateLookupWithKey , testCase "alter" test_alter + , testCase "alterF" test_alterF , testCase "union" test_union , testCase "mappend" test_mappend , testCase "unionWith" test_unionWith @@ -399,9 +406,53 @@ test_alter = do alter g 7 (fromList [(5,"a"), (3,"b")]) @?= fromList [(3, "b"), (5, "a"), (7, "c")] alter g 5 (fromList [(5,"a"), (3,"b")]) @?= fromList [(3, "b"), (5, "c")] where + f, g :: Maybe String -> Maybe String f _ = Nothing g _ = Just "c" +test_alterF :: Assertion +test_alterF = do + let m = fromList [(5,"a"), (3,"b")] + -- List applicative + alterF fList 7 m @?= [fromList [(3, "b"), (5, "a")]] + alterF fList 5 m @?= [singleton 3 "b"] + alterF gList 7 m @?= [fromList [(3, "b"), (5, "a"), (7, "c")]] + alterF gList 5 m @?= [fromList [(3, "b"), (5, "c")]] +#if MIN_VERSION_base(4,8,0) + -- Identity applicative + alterF fIdentity 7 m @?= Identity (fromList [(3, "b"), (5, "a")]) + alterF fIdentity 5 m @?= Identity (singleton 3 "b") + alterF gIdentity 7 m @?= Identity (fromList [(3, "b"), (5, "a"), (7, "c")]) + alterF gIdentity 5 m @?= Identity (fromList [(3, "b"), (5, "c")]) +#endif +#if MIN_VERSION_base(4,9,0) + -- Const applicative + alterF fConst 7 m @?= Const False + alterF fConst 5 m @?= Const False + alterF gConst 7 m @?= Const True + alterF gConst 5 m @?= Const True +#endif + where + f, g :: Applicative f => Maybe String -> f (Maybe String) + f _ = pure Nothing + g _ = pure $ Just "c" + + fList, gList :: Maybe String -> [Maybe String] + fList = f + gList = g + +#if MIN_VERSION_base(4,8,0) + fIdentity, gIdentity :: Maybe String -> Identity (Maybe String) + fIdentity = f + gIdentity = g +#endif + +#if MIN_VERSION_base(4,9,0) + fConst, gConst :: Maybe String -> Const Bool (Maybe String) + fConst _ = Const False + gConst _ = Const True +#endif + ---------------------------------------------------------------- -- Combine From b70c8a1506ebda1bdc9c02fce14429d69d92c660 Mon Sep 17 00:00:00 2001 From: Matt Renaud Date: Fri, 29 Dec 2017 14:11:37 -0800 Subject: [PATCH 03/17] Fix imports in IntMap/Internal.hs --- Data/IntMap/Internal.hs | 11 ++++++----- 1 file changed, 6 insertions(+), 5 deletions(-) diff --git a/Data/IntMap/Internal.hs b/Data/IntMap/Internal.hs index 56ec06361..e8032c217 100644 --- a/Data/IntMap/Internal.hs +++ b/Data/IntMap/Internal.hs @@ -286,12 +286,13 @@ module Data.IntMap.Internal ( #if MIN_VERSION_base(4,8,0) import Data.Functor.Identity (Identity (..)) -import Control.Applicative (liftA2) -#else -import Control.Applicative (Applicative(pure, (<*>)), (<$>), liftA2) +import Control.Applicative (liftA2 #if MIN_VERSION_base(4,9,0) -import Control.Applicative (Const(..)) + , Const(..) #endif + ) +#else +import Control.Applicative (Applicative(pure, (<*>)), (<$>), liftA2) import Data.Monoid (Monoid(..)) import Data.Traversable (Traversable(traverse)) import Data.Word (Word) @@ -996,7 +997,7 @@ alterF f k m = (<$> f mv) $ \fres -> #if MIN_VERSION_base(4,9,0) {-# RULES "Const specialize alterF" forall (f :: Maybe a -> Const x (Maybe a)) k m. - alterF f k m = Const $ alter (getConst . f) k m + alterF f k m = Const . getConst . f $ lookup k m #-} #endif From 75961b5cb6b8e40aedc86c2d77e9436e708dae12 Mon Sep 17 00:00:00 2001 From: Matt Renaud Date: Fri, 29 Dec 2017 14:12:03 -0800 Subject: [PATCH 04/17] Add property test for alterF rules. These ensure that the rewritten rules perform the same as the non-rewritten counterparts. --- tests/intmap-properties.hs | 53 ++++++++++++++++++++++++++++++++++++++ 1 file changed, 53 insertions(+) diff --git a/tests/intmap-properties.hs b/tests/intmap-properties.hs index 56c4fe49a..b98fdb551 100644 --- a/tests/intmap-properties.hs +++ b/tests/intmap-properties.hs @@ -150,6 +150,12 @@ main = defaultMain , testProperty "toAscList+toDescList" prop_ascDescList , testProperty "fromList" prop_fromList , testProperty "alter" prop_alter +#if MIN_VERSION_base(4,8,0) + , testProperty "alterF_Identity" prop_alterF_IdentityRules +#endif +#if MIN_VERSION_base(4,9,0) + , testProperty "alterF_Const" prop_alterF_ConstRules +#endif , testProperty "index" prop_index , testProperty "index_lookup" prop_index_lookup , testProperty "null" prop_null @@ -453,6 +459,7 @@ test_alterF = do gConst _ = Const True #endif + ---------------------------------------------------------------- -- Combine @@ -973,6 +980,52 @@ prop_alter t k = case lookup k t of f Nothing = Just () f (Just ()) = Nothing +#if MIN_VERSION_base(4,8,0) +-- Verify that the rewrite rules for Identity give the same result as the +-- non-rewritten version. We use our own TestIdentity functor to compare +-- against. + +data TestIdentity a = TestIdentity { runTestIdentity :: a } + +instance Functor TestIdentity where + fmap f (TestIdentity a) = TestIdentity (f a) + +prop_alterF_IdentityRules :: UMap -> Int -> Bool +prop_alterF_IdentityRules t k = + runIdentity tIdentity == runTestIdentity tTestIdentity + where + tIdentity = alterF fIdentity k t + fIdentity Nothing = Identity (Just ()) + fIdentity (Just ()) = Identity Nothing + + tTestIdentity = alterF fTest k t + fTest Nothing = TestIdentity (Just ()) + fTest (Just ()) = TestIdentity (Nothing) +#endif + +#if MIN_VERSION_base(4,9,0) +-- Verify that the rewrite rules for Const give the same result +-- as the non-rewritten version. We use a custom TestConst that +-- will not fire the rewrite rules to compare against. + +data TestConst a b = TestConst { getTestConst :: a } + +instance Functor (TestConst a) where + fmap _ (TestConst a) = TestConst a + +prop_alterF_ConstRules :: UMap -> Int -> Bool +prop_alterF_ConstRules t k = + getConst tConst == getTestConst tTestConst + where + tConst = alterF fConst k t + fConst Nothing = Const False + fConst (Just ()) = Const True + + tTestConst = alterF fTest k t + fTest Nothing = TestConst False + fTest (Just ()) = TestConst True +#endif + ------------------------------------------------------------------------ -- Compare against the list model (after nub on keys) From c1bedde5460368dbbb416e97545a5943509a92a3 Mon Sep 17 00:00:00 2001 From: Matt Renaud Date: Fri, 29 Dec 2017 14:42:23 -0800 Subject: [PATCH 05/17] Add benchmarks for alterF rewrite rules. MIME-Version: 1.0 Content-Type: text/plain; charset=UTF-8 Content-Transfer-Encoding: 8bit Benchmark results: benchmarking alter time 698.5 μs (676.3 μs .. 726.1 μs) 0.994 R² (0.991 R² .. 0.999 R²) mean 674.8 μs (668.6 μs .. 686.6 μs) std dev 28.63 μs (14.53 μs .. 45.31 μs) variance introduced by outliers: 34% (moderately inflated) benchmarking alterF time 969.5 μs (962.1 μs .. 977.3 μs) 1.000 R² (0.999 R² .. 1.000 R²) mean 956.7 μs (952.8 μs .. 961.1 μs) std dev 13.98 μs (11.21 μs .. 17.72 μs) benchmarking alterFIdentity time 660.7 μs (654.5 μs .. 673.4 μs) 0.994 R² (0.990 R² .. 0.997 R²) mean 674.1 μs (660.4 μs .. 691.3 μs) std dev 49.44 μs (38.40 μs .. 57.64 μs) variance introduced by outliers: 61% (severely inflated) benchmarking alterFConst time 14.98 μs (13.94 μs .. 16.02 μs) 0.976 R² (0.972 R² .. 0.990 R²) mean 15.12 μs (14.57 μs .. 15.84 μs) std dev 2.104 μs (1.813 μs .. 2.236 μs) variance introduced by outliers: 92% (severely inflated) --- benchmarks/IntMap.hs | 30 ++++++++++++++++++++++++++++++ 1 file changed, 30 insertions(+) diff --git a/benchmarks/IntMap.hs b/benchmarks/IntMap.hs index 8fabda4bc..19fea9e15 100644 --- a/benchmarks/IntMap.hs +++ b/benchmarks/IntMap.hs @@ -1,9 +1,16 @@ {-# LANGUAGE BangPatterns #-} +{-# LANGUAGE CPP #-} module Main where +#if MIN_VERSION_base(4,9,0) +import Control.Applicative (Const(..)) +#endif import Control.DeepSeq (rnf) import Control.Exception (evaluate) import Criterion.Main (bench, defaultMain, whnf) +#if MIN_VERSION_base(4,8,0) +import Data.Functor.Identity (Identity (..)) +#endif import Data.List (foldl') import qualified Data.IntMap as M import qualified Data.IntMap.Strict as MS @@ -35,6 +42,13 @@ main = do , bench "update" $ whnf (upd keys) m , bench "updateLookupWithKey" $ whnf (upd' keys) m , bench "alter" $ whnf (alt keys) m + , bench "alterF" $ whnf (altFList keys) m +#if MIN_VERSION_base(4,8,0) + , bench "alterFIdentity" $ whnf (altFIdentity keys) m +#endif +#if MIN_VERSION_base(4,9,0) + , bench "alterFConst" $ whnf (altFConst keys) m +#endif , bench "mapMaybe" $ whnf (M.mapMaybe maybeDel) m , bench "mapMaybeWithKey" $ whnf (M.mapMaybeWithKey (const maybeDel)) m , bench "fromList" $ whnf M.fromList elems @@ -90,6 +104,22 @@ upd' xs m = foldl' (\m k -> snd $ M.updateLookupWithKey (\_ a -> Just a) k m) m alt :: [Int] -> M.IntMap Int -> M.IntMap Int alt xs m = foldl' (\m k -> M.alter id k m) m xs +altFList :: [Int] -> M.IntMap Int -> M.IntMap Int +altFList xs m = foldl' (\m k -> head $ M.alterF (pure . id) k m) m xs + +#if MIN_VERSION_base(4,8,0) +altFIdentity :: [Int] -> M.IntMap Int -> M.IntMap Int +altFIdentity xs m = foldl' (\m k -> runIdentity $ M.alterF (pure . id) k m) m xs +#endif + +#if MIN_VERSION_base(4,9,0) +altFConst :: [Int] -> M.IntMap Int -> M.IntMap Int +altFConst xs m = + foldl' (\m k -> getConst $ M.alterF (const (Const m) . id) k m) m xs +#endif + + + maybeDel :: Int -> Maybe Int maybeDel n | n `mod` 3 == 0 = Nothing | otherwise = Just n From 85dafee474908d8cd6e6f27347e87238d9336693 Mon Sep 17 00:00:00 2001 From: Matt Renaud Date: Fri, 29 Dec 2017 16:29:25 -0800 Subject: [PATCH 06/17] Remove uses of Applicative and pure. This causes errors on older versions of GHC. https://travis-ci.org/haskell/containers/jobs/323051426 --- tests/intmap-properties.hs | 12 ++++-------- 1 file changed, 4 insertions(+), 8 deletions(-) diff --git a/tests/intmap-properties.hs b/tests/intmap-properties.hs index b98fdb551..1d45d038b 100644 --- a/tests/intmap-properties.hs +++ b/tests/intmap-properties.hs @@ -439,18 +439,14 @@ test_alterF = do alterF gConst 5 m @?= Const True #endif where - f, g :: Applicative f => Maybe String -> f (Maybe String) - f _ = pure Nothing - g _ = pure $ Just "c" - fList, gList :: Maybe String -> [Maybe String] - fList = f - gList = g + fList _ = [Nothing] + gList _ = [Just "c"] #if MIN_VERSION_base(4,8,0) fIdentity, gIdentity :: Maybe String -> Identity (Maybe String) - fIdentity = f - gIdentity = g + fIdentity _ = Identity Nothing + gIdentity _ = Identity (Just "c") #endif #if MIN_VERSION_base(4,9,0) From f3f7a27207bc95b7c130f63dc0a65f984613068a Mon Sep 17 00:00:00 2001 From: Matt Renaud Date: Sat, 30 Dec 2017 09:02:49 -0800 Subject: [PATCH 07/17] Use coerce and newtype for TestIdentity and TestConst. --- Data/IntMap/Internal.hs | 11 ++++++----- tests/intmap-properties.hs | 4 ++-- 2 files changed, 8 insertions(+), 7 deletions(-) diff --git a/Data/IntMap/Internal.hs b/Data/IntMap/Internal.hs index e8032c217..a11a8a154 100644 --- a/Data/IntMap/Internal.hs +++ b/Data/IntMap/Internal.hs @@ -286,11 +286,11 @@ module Data.IntMap.Internal ( #if MIN_VERSION_base(4,8,0) import Data.Functor.Identity (Identity (..)) -import Control.Applicative (liftA2 #if MIN_VERSION_base(4,9,0) - , Const(..) +import Control.Applicative (liftA2, Const(..)) +#else +import Control.Applicative (liftA2) #endif - ) #else import Control.Applicative (Applicative(pure, (<*>)), (<$>), liftA2) import Data.Monoid (Monoid(..)) @@ -298,6 +298,7 @@ import Data.Traversable (Traversable(traverse)) import Data.Word (Word) #endif #if MIN_VERSION_base(4,9,0) +import Data.Coerce (coerce) import Data.Semigroup (Semigroup((<>), stimes), stimesIdempotentMonoid) import Data.Functor.Classes #endif @@ -990,14 +991,14 @@ alterF f k m = (<$> f mv) $ \fres -> #if MIN_VERSION_base(4,8,0) {-# RULES "Identity specialize alterF" forall (f :: Maybe a -> Identity (Maybe a)) k m. - alterF f k m = Identity $ alter (runIdentity . f) k m + alterF f k m = Identity $ alter (coerce f) k m #-} #endif #if MIN_VERSION_base(4,9,0) {-# RULES "Const specialize alterF" forall (f :: Maybe a -> Const x (Maybe a)) k m. - alterF f k m = Const . getConst . f $ lookup k m + alterF f k m = coerce . f $ lookup k m #-} #endif diff --git a/tests/intmap-properties.hs b/tests/intmap-properties.hs index 1d45d038b..526895649 100644 --- a/tests/intmap-properties.hs +++ b/tests/intmap-properties.hs @@ -981,7 +981,7 @@ prop_alter t k = case lookup k t of -- non-rewritten version. We use our own TestIdentity functor to compare -- against. -data TestIdentity a = TestIdentity { runTestIdentity :: a } +newtype TestIdentity a = TestIdentity { runTestIdentity :: a } instance Functor TestIdentity where fmap f (TestIdentity a) = TestIdentity (f a) @@ -1004,7 +1004,7 @@ prop_alterF_IdentityRules t k = -- as the non-rewritten version. We use a custom TestConst that -- will not fire the rewrite rules to compare against. -data TestConst a b = TestConst { getTestConst :: a } +newtype TestConst a b = TestConst { getTestConst :: a } instance Functor (TestConst a) where fmap _ (TestConst a) = TestConst a From 4ffbc19a7d4c2119d663299c058319eb45eba90e Mon Sep 17 00:00:00 2001 From: Matt Renaud Date: Sat, 30 Dec 2017 14:32:12 -0800 Subject: [PATCH 08/17] Used Const . getConst in alterF rewrite. --- Data/IntMap/Internal.hs | 4 +++- 1 file changed, 3 insertions(+), 1 deletion(-) diff --git a/Data/IntMap/Internal.hs b/Data/IntMap/Internal.hs index a11a8a154..3a389dbed 100644 --- a/Data/IntMap/Internal.hs +++ b/Data/IntMap/Internal.hs @@ -998,7 +998,9 @@ alterF f k m = (<$> f mv) $ \fres -> #if MIN_VERSION_base(4,9,0) {-# RULES "Const specialize alterF" forall (f :: Maybe a -> Const x (Maybe a)) k m. - alterF f k m = coerce . f $ lookup k m + -- 'Const . getConst' is needed because the phantom type differs between + -- the return type of 'f' and 'alterF'. + alterF f k m = Const . getConst . f $ lookup k m #-} #endif From 2ea64a835eaa99d1fef96c9aae94b33b772cc314 Mon Sep 17 00:00:00 2001 From: Matt Renaud Date: Sun, 31 Dec 2017 11:23:35 -0800 Subject: [PATCH 09/17] Remove INLINE or NOINLINE todo. --- Data/IntMap/Internal.hs | 2 -- 1 file changed, 2 deletions(-) diff --git a/Data/IntMap/Internal.hs b/Data/IntMap/Internal.hs index 3a389dbed..268b35334 100644 --- a/Data/IntMap/Internal.hs +++ b/Data/IntMap/Internal.hs @@ -985,8 +985,6 @@ alterF f k m = (<$> f mv) $ \fres -> Nothing -> maybe m (const (delete k m)) mv Just v' -> insert k v' m where mv = lookup k m --- TODO(m-renaud): Figure out if this should be marked INLINE or NOINLINE. --- It needs to be one or the other or else the specialization rule may not fire. {-# NOINLINE [1] alterF #-} #if MIN_VERSION_base(4,8,0) {-# RULES From cfc37300092cd73df43645c4536ed07c9a17b767 Mon Sep 17 00:00:00 2001 From: Matt Renaud Date: Wed, 3 Jan 2018 18:06:57 -0800 Subject: [PATCH 10/17] Use coerce to define TestIdentity functor instance. --- tests/intmap-properties.hs | 2 +- 1 file changed, 1 insertion(+), 1 deletion(-) diff --git a/tests/intmap-properties.hs b/tests/intmap-properties.hs index 526895649..b4f85d95e 100644 --- a/tests/intmap-properties.hs +++ b/tests/intmap-properties.hs @@ -984,7 +984,7 @@ prop_alter t k = case lookup k t of newtype TestIdentity a = TestIdentity { runTestIdentity :: a } instance Functor TestIdentity where - fmap f (TestIdentity a) = TestIdentity (f a) + fmap = coerce prop_alterF_IdentityRules :: UMap -> Int -> Bool prop_alterF_IdentityRules t k = From 08e1b1f2e6627b90d021966ff179545d7c94a596 Mon Sep 17 00:00:00 2001 From: Matt Renaud Date: Mon, 8 Jan 2018 10:02:57 -0800 Subject: [PATCH 11/17] Organize benchmarks into NoRewrite and Rewrite. MIME-Version: 1.0 Content-Type: text/plain; charset=UTF-8 Content-Transfer-Encoding: 8bit Results: benchmarking alterF_IdentityNoRewrite time 1.177 ms (1.171 ms .. 1.184 ms) 1.000 R² (0.999 R² .. 1.000 R²) mean 1.162 ms (1.156 ms .. 1.169 ms) std dev 20.18 μs (16.39 μs .. 26.88 μs) benchmarking alterF_IdentityRewrite time 818.9 μs (814.4 μs .. 823.2 μs) 1.000 R² (0.999 R² .. 1.000 R²) mean 808.8 μs (804.7 μs .. 815.8 μs) std dev 17.13 μs (10.29 μs .. 26.35 μs) variance introduced by outliers: 11% (moderately inflated) benchmarking alterF_ConstNoRewrite time 63.80 μs (62.22 μs .. 65.81 μs) 0.996 R² (0.993 R² .. 1.000 R²) mean 62.13 μs (61.61 μs .. 63.07 μs) std dev 2.440 μs (1.271 μs .. 4.050 μs) variance introduced by outliers: 42% (moderately inflated) benchmarking alterF_ConstRewrite time 17.24 μs (16.35 μs .. 18.38 μs) 0.979 R² (0.974 R² .. 0.990 R²) mean 17.92 μs (17.18 μs .. 18.71 μs) std dev 2.446 μs (2.125 μs .. 2.578 μs) variance introduced by outliers: 92% (severely inflated) --- Data/IntMap/Internal.hs | 1 - benchmarks/IntMap.hs | 29 +++++++++++++++++++++++------ tests/intmap-properties.hs | 1 + 3 files changed, 24 insertions(+), 7 deletions(-) diff --git a/Data/IntMap/Internal.hs b/Data/IntMap/Internal.hs index 268b35334..f7dbda614 100644 --- a/Data/IntMap/Internal.hs +++ b/Data/IntMap/Internal.hs @@ -298,7 +298,6 @@ import Data.Traversable (Traversable(traverse)) import Data.Word (Word) #endif #if MIN_VERSION_base(4,9,0) -import Data.Coerce (coerce) import Data.Semigroup (Semigroup((<>), stimes), stimesIdempotentMonoid) import Data.Functor.Classes #endif diff --git a/benchmarks/IntMap.hs b/benchmarks/IntMap.hs index 19fea9e15..77b96f561 100644 --- a/benchmarks/IntMap.hs +++ b/benchmarks/IntMap.hs @@ -9,6 +9,7 @@ import Control.DeepSeq (rnf) import Control.Exception (evaluate) import Criterion.Main (bench, defaultMain, whnf) #if MIN_VERSION_base(4,8,0) +import Data.Coerce (coerce) import Data.Functor.Identity (Identity (..)) #endif import Data.List (foldl') @@ -42,12 +43,13 @@ main = do , bench "update" $ whnf (upd keys) m , bench "updateLookupWithKey" $ whnf (upd' keys) m , bench "alter" $ whnf (alt keys) m - , bench "alterF" $ whnf (altFList keys) m #if MIN_VERSION_base(4,8,0) - , bench "alterFIdentity" $ whnf (altFIdentity keys) m + , bench "alterF_IdentityNoRewrite" $ whnf (altFTestIdentity keys) m + , bench "alterF_IdentityRewrite" $ whnf (altFIdentity keys) m #endif #if MIN_VERSION_base(4,9,0) - , bench "alterFConst" $ whnf (altFConst keys) m + , bench "alterF_ConstNoRewrite" $ whnf (altFTestConst keys) m + , bench "alterF_ConstRewrite" $ whnf (altFConst keys) m #endif , bench "mapMaybe" $ whnf (M.mapMaybe maybeDel) m , bench "mapMaybeWithKey" $ whnf (M.mapMaybeWithKey (const maybeDel)) m @@ -104,15 +106,30 @@ upd' xs m = foldl' (\m k -> snd $ M.updateLookupWithKey (\_ a -> Just a) k m) m alt :: [Int] -> M.IntMap Int -> M.IntMap Int alt xs m = foldl' (\m k -> M.alter id k m) m xs -altFList :: [Int] -> M.IntMap Int -> M.IntMap Int -altFList xs m = foldl' (\m k -> head $ M.alterF (pure . id) k m) m xs - #if MIN_VERSION_base(4,8,0) +newtype TestIdentity a = TestIdentity { runTestIdentity :: a } + +instance Functor TestIdentity where + fmap = coerce + +altFTestIdentity :: [Int] -> M.IntMap Int -> M.IntMap Int +altFTestIdentity xs m = + foldl' (\m k -> runTestIdentity $ M.alterF (TestIdentity . id) k m) m xs + altFIdentity :: [Int] -> M.IntMap Int -> M.IntMap Int altFIdentity xs m = foldl' (\m k -> runIdentity $ M.alterF (pure . id) k m) m xs #endif #if MIN_VERSION_base(4,9,0) +newtype TestConst a b = TestConst { getTestConst :: a } + +instance Functor (TestConst a) where + fmap _ (TestConst a) = TestConst a + +altFTestConst :: [Int] -> M.IntMap Int -> M.IntMap Int +altFTestConst xs m = + foldl' (\m k -> getTestConst $ M.alterF (const (TestConst m) . id) k m) m xs + altFConst :: [Int] -> M.IntMap Int -> M.IntMap Int altFConst xs m = foldl' (\m k -> getConst $ M.alterF (const (Const m) . id) k m) m xs diff --git a/tests/intmap-properties.hs b/tests/intmap-properties.hs index b4f85d95e..575edda35 100644 --- a/tests/intmap-properties.hs +++ b/tests/intmap-properties.hs @@ -11,6 +11,7 @@ import Data.IntMap.Internal.Debug (showTree) import Control.Applicative (Const(..)) #endif #if MIN_VERSION_base(4,8,0) +import Data.Coerce (coerce) import Data.Functor.Identity (Identity (..)) #endif import Data.Monoid From 25640749f35e9afa8cb1cb048ca95b7dd5b5ce63 Mon Sep 17 00:00:00 2001 From: Matt Renaud Date: Mon, 8 Jan 2018 10:49:21 -0800 Subject: [PATCH 12/17] Make alterF to INLINEABLE. MIME-Version: 1.0 Content-Type: text/plain; charset=UTF-8 Content-Transfer-Encoding: 8bit This improves the Const benchmark for the non-rewritten case: Before ====== benchmarking alterF_IdentityNoRewrite time 1.177 ms (1.171 ms .. 1.184 ms) 1.000 R² (0.999 R² .. 1.000 R²) mean 1.162 ms (1.156 ms .. 1.169 ms) std dev 20.18 μs (16.39 μs .. 26.88 μs) benchmarking alterF_IdentityRewrite time 818.9 μs (814.4 μs .. 823.2 μs) 1.000 R² (0.999 R² .. 1.000 R²) mean 808.8 μs (804.7 μs .. 815.8 μs) std dev 17.13 μs (10.29 μs .. 26.35 μs) variance introduced by outliers: 11% (moderately inflated) benchmarking alterF_ConstNoRewrite time 63.80 μs (62.22 μs .. 65.81 μs) 0.996 R² (0.993 R² .. 1.000 R²) mean 62.13 μs (61.61 μs .. 63.07 μs) std dev 2.440 μs (1.271 μs .. 4.050 μs) variance introduced by outliers: 42% (moderately inflated) benchmarking alterF_ConstRewrite time 17.24 μs (16.35 μs .. 18.38 μs) 0.979 R² (0.974 R² .. 0.990 R²) mean 17.92 μs (17.18 μs .. 18.71 μs) std dev 2.446 μs (2.125 μs .. 2.578 μs) variance introduced by outliers: 92% (severely inflated) After ===== benchmarking alterF_IdentityNoRewrite time 1.134 ms (1.116 ms .. 1.151 ms) 0.998 R² (0.997 R² .. 0.999 R²) mean 1.100 ms (1.092 ms .. 1.112 ms) std dev 31.57 μs (25.08 μs .. 46.04 μs) variance introduced by outliers: 17% (moderately inflated) benchmarking alterF_IdentityRewrite time 849.4 μs (844.1 μs .. 853.8 μs) 1.000 R² (0.999 R² .. 1.000 R²) mean 836.1 μs (831.8 μs .. 841.5 μs) std dev 15.55 μs (11.92 μs .. 24.54 μs) benchmarking alterF_ConstNoRewrite time 21.12 μs (20.26 μs .. 21.66 μs) 0.992 R² (0.983 R² .. 0.999 R²) mean 20.71 μs (19.90 μs .. 21.08 μs) std dev 1.685 μs (953.0 ns .. 2.410 μs) variance introduced by outliers: 79% (severely inflated) benchmarking alterF_ConstRewrite time 17.04 μs (16.48 μs .. 18.07 μs) 0.977 R² (0.969 R² .. 0.987 R²) mean 18.76 μs (17.82 μs .. 19.84 μs) std dev 3.275 μs (2.764 μs .. 3.809 μs) variance introduced by outliers: 95% (severely inflated) [ci skip] --- Data/IntMap/Internal.hs | 2 +- 1 file changed, 1 insertion(+), 1 deletion(-) diff --git a/Data/IntMap/Internal.hs b/Data/IntMap/Internal.hs index f7dbda614..a5125f9fd 100644 --- a/Data/IntMap/Internal.hs +++ b/Data/IntMap/Internal.hs @@ -984,7 +984,7 @@ alterF f k m = (<$> f mv) $ \fres -> Nothing -> maybe m (const (delete k m)) mv Just v' -> insert k v' m where mv = lookup k m -{-# NOINLINE [1] alterF #-} +{-# INLINEABLE [1] alterF #-} #if MIN_VERSION_base(4,8,0) {-# RULES "Identity specialize alterF" forall (f :: Maybe a -> Identity (Maybe a)) k m. From d400df52f2992b062c9901af8b662ddd78ee1f54 Mon Sep 17 00:00:00 2001 From: Matt Renaud Date: Mon, 8 Jan 2018 11:02:01 -0800 Subject: [PATCH 13/17] make prop_alterF_IdentityRules a property. This also checks that the two results are 'valid'. --- stack.yaml | 4 ++-- tests/intmap-properties.hs | 10 ++++++---- 2 files changed, 8 insertions(+), 6 deletions(-) diff --git a/stack.yaml b/stack.yaml index 2c736a2f7..81d8bf1c7 100644 --- a/stack.yaml +++ b/stack.yaml @@ -3,8 +3,8 @@ packages: - '.' ### Uncoment the resolver you want to use and re-run `stack build/test/bench`. -# resolver: lts-10.0 -resolver: lts-9.20 +resolver: lts-10.0 +# resolver: lts-9.20 ### ChasingBottoms is only in Stackage snapshots lts-7.24 and below. extra-deps: diff --git a/tests/intmap-properties.hs b/tests/intmap-properties.hs index 1770f571f..d75abf68b 100644 --- a/tests/intmap-properties.hs +++ b/tests/intmap-properties.hs @@ -1028,15 +1028,17 @@ newtype TestIdentity a = TestIdentity { runTestIdentity :: a } instance Functor TestIdentity where fmap = coerce -prop_alterF_IdentityRules :: UMap -> Int -> Bool +prop_alterF_IdentityRules :: UMap -> Int -> Property prop_alterF_IdentityRules t k = - runIdentity tIdentity == runTestIdentity tTestIdentity + valid tIdentity .&&. + valid tTestIdentity .&&. + tIdentity == tTestIdentity where - tIdentity = alterF fIdentity k t + tIdentity = runIdentity $ alterF fIdentity k t fIdentity Nothing = Identity (Just ()) fIdentity (Just ()) = Identity Nothing - tTestIdentity = alterF fTest k t + tTestIdentity = runTestIdentity $ alterF fTest k t fTest Nothing = TestIdentity (Just ()) fTest (Just ()) = TestIdentity (Nothing) #endif From fd5d2dc84f543d5cfdda30c8c2c716865f2337aa Mon Sep 17 00:00:00 2001 From: Matt Renaud Date: Mon, 8 Jan 2018 11:03:24 -0800 Subject: [PATCH 14/17] Undo unintentional change to stack.yaml. [ci skip] --- stack.yaml | 4 ++-- 1 file changed, 2 insertions(+), 2 deletions(-) diff --git a/stack.yaml b/stack.yaml index 81d8bf1c7..2c736a2f7 100644 --- a/stack.yaml +++ b/stack.yaml @@ -3,8 +3,8 @@ packages: - '.' ### Uncoment the resolver you want to use and re-run `stack build/test/bench`. -resolver: lts-10.0 -# resolver: lts-9.20 +# resolver: lts-10.0 +resolver: lts-9.20 ### ChasingBottoms is only in Stackage snapshots lts-7.24 and below. extra-deps: From e19a5567b93a71fb6cb2bda54a52d9bbe6d08e22 Mon Sep 17 00:00:00 2001 From: Matt Renaud Date: Mon, 8 Jan 2018 11:38:48 -0800 Subject: [PATCH 15/17] INLINABLE, not INLINEABLE. Both spellings work but the docs use "INLINABLE". [ci skip] --- Data/IntMap/Internal.hs | 2 +- 1 file changed, 1 insertion(+), 1 deletion(-) diff --git a/Data/IntMap/Internal.hs b/Data/IntMap/Internal.hs index 972d21a54..721f0e642 100644 --- a/Data/IntMap/Internal.hs +++ b/Data/IntMap/Internal.hs @@ -995,7 +995,7 @@ alterF f k m = (<$> f mv) $ \fres -> Nothing -> maybe m (const (delete k m)) mv Just v' -> insert k v' m where mv = lookup k m -{-# INLINEABLE [1] alterF #-} +{-# INLINABLE [1] alterF #-} #if MIN_VERSION_base(4,8,0) {-# RULES "Identity specialize alterF" forall (f :: Maybe a -> Identity (Maybe a)) k m. From 8fd1b25a36b88b36416221eac1b896e3a67cb48a Mon Sep 17 00:00:00 2001 From: Matt Renaud Date: Mon, 8 Jan 2018 16:13:17 -0800 Subject: [PATCH 16/17] Remove Const rewrite RULES for alterF. --- Data/IntMap/Internal.hs | 13 ------------- benchmarks/IntMap.hs | 12 +----------- tests/intmap-properties.hs | 26 -------------------------- 3 files changed, 1 insertion(+), 50 deletions(-) diff --git a/Data/IntMap/Internal.hs b/Data/IntMap/Internal.hs index 721f0e642..4132545ca 100644 --- a/Data/IntMap/Internal.hs +++ b/Data/IntMap/Internal.hs @@ -288,11 +288,7 @@ module Data.IntMap.Internal ( #if MIN_VERSION_base(4,8,0) import Data.Functor.Identity (Identity (..)) -#if MIN_VERSION_base(4,9,0) -import Control.Applicative (liftA2, Const(..)) -#else import Control.Applicative (liftA2) -#endif #else import Control.Applicative (Applicative(pure, (<*>)), (<$>), liftA2) import Data.Monoid (Monoid(..)) @@ -1003,15 +999,6 @@ alterF f k m = (<$> f mv) $ \fres -> #-} #endif -#if MIN_VERSION_base(4,9,0) -{-# RULES -"Const specialize alterF" forall (f :: Maybe a -> Const x (Maybe a)) k m. - -- 'Const . getConst' is needed because the phantom type differs between - -- the return type of 'f' and 'alterF'. - alterF f k m = Const . getConst . f $ lookup k m - #-} -#endif - {-------------------------------------------------------------------- Union --------------------------------------------------------------------} diff --git a/benchmarks/IntMap.hs b/benchmarks/IntMap.hs index 77b96f561..ec7253f11 100644 --- a/benchmarks/IntMap.hs +++ b/benchmarks/IntMap.hs @@ -48,8 +48,7 @@ main = do , bench "alterF_IdentityRewrite" $ whnf (altFIdentity keys) m #endif #if MIN_VERSION_base(4,9,0) - , bench "alterF_ConstNoRewrite" $ whnf (altFTestConst keys) m - , bench "alterF_ConstRewrite" $ whnf (altFConst keys) m + , bench "alterF_Const" $ whnf (altFConst keys) m #endif , bench "mapMaybe" $ whnf (M.mapMaybe maybeDel) m , bench "mapMaybeWithKey" $ whnf (M.mapMaybeWithKey (const maybeDel)) m @@ -121,15 +120,6 @@ altFIdentity xs m = foldl' (\m k -> runIdentity $ M.alterF (pure . id) k m) m xs #endif #if MIN_VERSION_base(4,9,0) -newtype TestConst a b = TestConst { getTestConst :: a } - -instance Functor (TestConst a) where - fmap _ (TestConst a) = TestConst a - -altFTestConst :: [Int] -> M.IntMap Int -> M.IntMap Int -altFTestConst xs m = - foldl' (\m k -> getTestConst $ M.alterF (const (TestConst m) . id) k m) m xs - altFConst :: [Int] -> M.IntMap Int -> M.IntMap Int altFConst xs m = foldl' (\m k -> getConst $ M.alterF (const (Const m) . id) k m) m xs diff --git a/tests/intmap-properties.hs b/tests/intmap-properties.hs index d75abf68b..4463e43b8 100644 --- a/tests/intmap-properties.hs +++ b/tests/intmap-properties.hs @@ -156,9 +156,6 @@ main = defaultMain , testProperty "alter" prop_alter #if MIN_VERSION_base(4,8,0) , testProperty "alterF_Identity" prop_alterF_IdentityRules -#endif -#if MIN_VERSION_base(4,9,0) - , testProperty "alterF_Const" prop_alterF_ConstRules #endif , testProperty "index" prop_index , testProperty "index_lookup" prop_index_lookup @@ -1043,29 +1040,6 @@ prop_alterF_IdentityRules t k = fTest (Just ()) = TestIdentity (Nothing) #endif -#if MIN_VERSION_base(4,9,0) --- Verify that the rewrite rules for Const give the same result --- as the non-rewritten version. We use a custom TestConst that --- will not fire the rewrite rules to compare against. - -newtype TestConst a b = TestConst { getTestConst :: a } - -instance Functor (TestConst a) where - fmap _ (TestConst a) = TestConst a - -prop_alterF_ConstRules :: UMap -> Int -> Bool -prop_alterF_ConstRules t k = - getConst tConst == getTestConst tTestConst - where - tConst = alterF fConst k t - fConst Nothing = Const False - fConst (Just ()) = Const True - - tTestConst = alterF fTest k t - fTest Nothing = TestConst False - fTest (Just ()) = TestConst True -#endif - ------------------------------------------------------------------------ -- Compare against the list model (after nub on keys) From 164ef90f0ecd903808f4f4be635cb53675c0632f Mon Sep 17 00:00:00 2001 From: Matt Renaud Date: Tue, 9 Jan 2018 07:16:50 -0800 Subject: [PATCH 17/17] Add more granular benchmarks. MIME-Version: 1.0 Content-Type: text/plain; charset=UTF-8 Content-Transfer-Encoding: 8bit These benchmarks tell a different story from the previous benchmarks. Specifically, the rewritten alterF for Identity appears to perform better in casses when the element being altered is present, but worse when the element is absent. Specifically: better for: "benchmarking alterF delete present" "benchmarking alterF alter insert" "benchmarking alterF alter update" "benchmarking alterF alter delete" worse for: "benchmarking alterF delete absent" "benchmarking alterF alter absent" Benchmark Results: benchmarking alterF lookup absent time 123.7 μs (123.4 μs .. 124.0 μs) 1.000 R² (1.000 R² .. 1.000 R²) mean 123.2 μs (122.8 μs .. 124.0 μs) std dev 1.702 μs (961.3 ns .. 2.891 μs) benchmarking alterF lookup present time 126.9 μs (125.4 μs .. 129.2 μs) 0.999 R² (0.998 R² .. 1.000 R²) mean 127.0 μs (126.4 μs .. 128.3 μs) std dev 2.608 μs (1.219 μs .. 4.415 μs) variance introduced by outliers: 15% (moderately inflated) benchmarking alterF no rules lookup absent time 123.1 μs (122.7 μs .. 123.6 μs) 1.000 R² (1.000 R² .. 1.000 R²) mean 122.7 μs (122.3 μs .. 123.4 μs) std dev 1.738 μs (1.162 μs .. 2.847 μs) benchmarking alterF no rules lookup present time 125.5 μs (125.0 μs .. 126.1 μs) 1.000 R² (1.000 R² .. 1.000 R²) mean 125.3 μs (124.8 μs .. 126.3 μs) std dev 2.381 μs (1.366 μs .. 4.219 μs) variance introduced by outliers: 13% (moderately inflated) benchmarking alterF insert absent time 286.4 μs (283.2 μs .. 291.0 μs) 0.996 R² (0.992 R² .. 0.999 R²) mean 285.4 μs (281.3 μs .. 292.4 μs) std dev 16.74 μs (10.04 μs .. 23.84 μs) variance introduced by outliers: 55% (severely inflated) benchmarking alterF insert present time 268.8 μs (266.0 μs .. 273.2 μs) 0.999 R² (0.997 R² .. 1.000 R²) mean 266.6 μs (264.5 μs .. 272.0 μs) std dev 10.35 μs (3.766 μs .. 21.79 μs) variance introduced by outliers: 35% (moderately inflated) benchmarking alterF no rules insert absent time 278.2 μs (275.3 μs .. 282.1 μs) 0.999 R² (0.999 R² .. 1.000 R²) mean 274.2 μs (273.0 μs .. 276.4 μs) std dev 4.920 μs (3.263 μs .. 7.465 μs) variance introduced by outliers: 11% (moderately inflated) benchmarking alterF no rules insert present time 263.8 μs (262.9 μs .. 264.9 μs) 1.000 R² (1.000 R² .. 1.000 R²) mean 261.2 μs (260.4 μs .. 262.3 μs) std dev 3.298 μs (2.541 μs .. 4.858 μs) benchmarking alterF delete absent time 229.7 μs (228.4 μs .. 232.3 μs) 0.995 R² (0.986 R² .. 0.999 R²) mean 234.9 μs (230.4 μs .. 244.7 μs) std dev 21.96 μs (11.47 μs .. 39.15 μs) variance introduced by outliers: 77% (severely inflated) benchmarking alterF delete present time 263.6 μs (263.0 μs .. 264.4 μs) 0.999 R² (0.998 R² .. 1.000 R²) mean 264.2 μs (261.9 μs .. 268.9 μs) std dev 10.23 μs (2.598 μs .. 17.63 μs) variance introduced by outliers: 35% (moderately inflated) benchmarking alterF no rules delete absent time 121.0 μs (120.6 μs .. 121.4 μs) 1.000 R² (1.000 R² .. 1.000 R²) mean 120.6 μs (120.1 μs .. 122.3 μs) std dev 2.556 μs (872.5 ns .. 5.536 μs) variance introduced by outliers: 15% (moderately inflated) benchmarking alterF no rules delete present time 375.4 μs (373.4 μs .. 377.8 μs) 0.998 R² (0.995 R² .. 1.000 R²) mean 377.0 μs (372.5 μs .. 394.4 μs) std dev 24.73 μs (3.491 μs .. 49.28 μs) variance introduced by outliers: 60% (severely inflated) benchmarking alterF alter absent time 241.9 μs (235.2 μs .. 251.3 μs) 0.994 R² (0.990 R² .. 1.000 R²) mean 237.5 μs (234.9 μs .. 242.1 μs) std dev 10.98 μs (5.881 μs .. 16.30 μs) variance introduced by outliers: 44% (moderately inflated) benchmarking alterF alter insert time 265.0 μs (263.4 μs .. 267.1 μs) 0.997 R² (0.994 R² .. 0.999 R²) mean 274.0 μs (267.5 μs .. 283.6 μs) std dev 25.20 μs (18.18 μs .. 33.32 μs) variance introduced by outliers: 76% (severely inflated) benchmarking alterF alter update time 260.8 μs (253.6 μs .. 270.1 μs) 0.996 R² (0.992 R² .. 1.000 R²) mean 254.8 μs (252.4 μs .. 258.6 μs) std dev 9.796 μs (5.279 μs .. 15.32 μs) variance introduced by outliers: 35% (moderately inflated) benchmarking alterF alter delete time 263.9 μs (262.8 μs .. 265.6 μs) 1.000 R² (0.999 R² .. 1.000 R²) mean 262.8 μs (261.7 μs .. 265.0 μs) std dev 4.963 μs (2.882 μs .. 8.375 μs) variance introduced by outliers: 12% (moderately inflated) benchmarking alterF no rules alter absent time 142.6 μs (137.4 μs .. 148.4 μs) 0.991 R² (0.988 R² .. 0.996 R²) mean 137.5 μs (135.2 μs .. 141.0 μs) std dev 9.531 μs (6.703 μs .. 12.40 μs) variance introduced by outliers: 67% (severely inflated) benchmarking alterF no rules alter insert time 293.5 μs (291.7 μs .. 295.5 μs) 1.000 R² (1.000 R² .. 1.000 R²) mean 291.1 μs (289.8 μs .. 293.1 μs) std dev 5.100 μs (3.695 μs .. 7.448 μs) benchmarking alterF no rules alter update time 409.7 μs (407.8 μs .. 412.1 μs) 1.000 R² (1.000 R² .. 1.000 R²) mean 406.3 μs (404.4 μs .. 408.4 μs) std dev 6.193 μs (5.148 μs .. 7.883 μs) benchmarking alterF no rules alter delete time 388.3 μs (386.0 μs .. 391.0 μs) 1.000 R² (0.999 R² .. 1.000 R²) mean 386.6 μs (384.5 μs .. 396.3 μs) std dev 12.23 μs (3.727 μs .. 26.30 μs) variance introduced by outliers: 25% (moderately inflated) --- benchmarks/IntMap.hs | 79 +++++++++++++++++++++++++++++++++----------- 1 file changed, 59 insertions(+), 20 deletions(-) diff --git a/benchmarks/IntMap.hs b/benchmarks/IntMap.hs index ec7253f11..43f7e0372 100644 --- a/benchmarks/IntMap.hs +++ b/benchmarks/IntMap.hs @@ -20,6 +20,8 @@ import Prelude hiding (lookup) main = do let m = M.fromAscList elems :: M.IntMap Int + m_even = M.fromAscList elems_even :: M.IntMap Int + m_odd = M.fromAscList elems_odd :: M.IntMap Int evaluate $ rnf [m] defaultMain [ bench "lookup" $ whnf (lookup keys) m @@ -43,13 +45,26 @@ main = do , bench "update" $ whnf (upd keys) m , bench "updateLookupWithKey" $ whnf (upd' keys) m , bench "alter" $ whnf (alt keys) m -#if MIN_VERSION_base(4,8,0) - , bench "alterF_IdentityNoRewrite" $ whnf (altFTestIdentity keys) m - , bench "alterF_IdentityRewrite" $ whnf (altFIdentity keys) m -#endif -#if MIN_VERSION_base(4,9,0) - , bench "alterF_Const" $ whnf (altFConst keys) m -#endif + , bench "alterF lookup absent" $ whnf (atLookup evens) m_odd + , bench "alterF lookup present" $ whnf (atLookup evens) m_even + , bench "alterF no rules lookup absent" $ whnf (atLookupNoRules evens) m_odd + , bench "alterF no rules lookup present" $ whnf (atLookupNoRules evens) m_even + , bench "alterF insert absent" $ whnf (atIns elems_even) m_odd + , bench "alterF insert present" $ whnf (atIns elems_even) m_even + , bench "alterF no rules insert absent" $ whnf (atInsNoRules elems_even) m_odd + , bench "alterF no rules insert present" $ whnf (atInsNoRules elems_even) m_even + , bench "alterF delete absent" $ whnf (atDel evens) m_odd + , bench "alterF delete present" $ whnf (atDel evens) m + , bench "alterF no rules delete absent" $ whnf (atDelNoRules evens) m_odd + , bench "alterF no rules delete present" $ whnf (atDelNoRules evens) m + , bench "alterF alter absent" $ whnf (atAlt id evens) m_odd + , bench "alterF alter insert" $ whnf (atAlt (const (Just 1)) evens) m_odd + , bench "alterF alter update" $ whnf (atAlt id evens) m_even + , bench "alterF alter delete" $ whnf (atAlt (const Nothing) evens) m + , bench "alterF no rules alter absent" $ whnf (atAltNoRules id evens) m_odd + , bench "alterF no rules alter insert" $ whnf (atAltNoRules (const (Just 1)) evens) m_odd + , bench "alterF no rules alter update" $ whnf (atAltNoRules id evens) m_even + , bench "alterF no rules alter delete" $ whnf (atAltNoRules (const Nothing) evens) m , bench "mapMaybe" $ whnf (M.mapMaybe maybeDel) m , bench "mapMaybeWithKey" $ whnf (M.mapMaybeWithKey (const maybeDel)) m , bench "fromList" $ whnf M.fromList elems @@ -58,7 +73,11 @@ main = do ] where elems = zip keys values + elems_even = zip evens evens + elems_odd = zip odds odds keys = [1..2^12] + evens = [2,4..2^12] + odds = [1,3..2^12] values = [1..2^12] sum k v1 v2 = k + v1 + v2 consPair k v xs = (k, v) : xs @@ -105,27 +124,47 @@ upd' xs m = foldl' (\m k -> snd $ M.updateLookupWithKey (\_ a -> Just a) k m) m alt :: [Int] -> M.IntMap Int -> M.IntMap Int alt xs m = foldl' (\m k -> M.alter id k m) m xs -#if MIN_VERSION_base(4,8,0) newtype TestIdentity a = TestIdentity { runTestIdentity :: a } instance Functor TestIdentity where - fmap = coerce +#if MIN_VERSION_base(4,8,0) + fmap = coerce +#else + fmap f (Ident a) = Ident (f a) +#endif -altFTestIdentity :: [Int] -> M.IntMap Int -> M.IntMap Int -altFTestIdentity xs m = - foldl' (\m k -> runTestIdentity $ M.alterF (TestIdentity . id) k m) m xs +newtype TestConst a b = TestConst { getTestConst :: a } +instance Functor (TestConst a) where + fmap _ (TestConst a) = TestConst a -altFIdentity :: [Int] -> M.IntMap Int -> M.IntMap Int -altFIdentity xs m = foldl' (\m k -> runIdentity $ M.alterF (pure . id) k m) m xs -#endif +atLookup :: [Int] -> M.IntMap Int -> Int +atLookup xs m = foldl' (\n k -> fromMaybe n (getConst (M.alterF Const k m))) 0 xs -#if MIN_VERSION_base(4,9,0) -altFConst :: [Int] -> M.IntMap Int -> M.IntMap Int -altFConst xs m = - foldl' (\m k -> getConst $ M.alterF (const (Const m) . id) k m) m xs -#endif +atLookupNoRules :: [Int] -> M.IntMap Int -> Int +atLookupNoRules xs m = + foldl' (\n k -> fromMaybe n (getTestConst (M.alterF TestConst k m))) 0 xs + +atIns :: [(Int, Int)] -> M.IntMap Int -> M.IntMap Int +atIns xs m = + foldl' (\m (k, v) -> runIdentity (M.alterF (\_ -> Identity (Just v)) k m)) m xs + +atInsNoRules :: [(Int, Int)] -> M.IntMap Int -> M.IntMap Int +atInsNoRules xs m = + foldl' (\m (k, v) -> runTestIdentity (M.alterF (\_ -> TestIdentity (Just v)) k m)) m xs + +atDel :: [Int] -> M.IntMap Int -> M.IntMap Int +atDel xs m = foldl' (\m k -> runIdentity (M.alterF (\_ -> Identity Nothing) k m)) m xs + +atDelNoRules :: [Int] -> M.IntMap Int -> M.IntMap Int +atDelNoRules xs m = + foldl' (\m k -> runTestIdentity (M.alterF (\_ -> TestIdentity Nothing) k m)) m xs +atAlt :: (Maybe Int -> Maybe Int) -> [Int] -> M.IntMap Int -> M.IntMap Int +atAlt f xs m = foldl' (\m k -> runIdentity (M.alterF (Identity . f) k m)) m xs +atAltNoRules :: (Maybe Int -> Maybe Int) -> [Int] -> M.IntMap Int -> M.IntMap Int +atAltNoRules f xs m = + foldl' (\m k -> runTestIdentity (M.alterF (TestIdentity . f) k m)) m xs maybeDel :: Int -> Maybe Int maybeDel n | n `mod` 3 == 0 = Nothing