ctrie 0.1.0.1 → 0.1.0.2
raw patch · 5 files changed
+137/−142 lines, 5 filesdep +stmdep ~atomic-primopsdep ~basedep ~criterion
Dependencies added: stm
Dependency ranges changed: atomic-primops, base, criterion
Files
- Control/Concurrent/Map.hs +3/−5
- benchmarks/Concurrent.hs +64/−86
- benchmarks/Sequential.hs +54/−43
- changelog.md +5/−0
- ctrie.cabal +11/−8
Control/Concurrent/Map.hs view
@@ -8,10 +8,8 @@ -- -- * Aleksander Prokopec, Phil Bagwell, Martin Odersky, -- \"/Cache-Aware Lock-Free Concurent Hash Tries/\"------ * Aleksander Prokopec, Nathan G. Bronson, Phil Bagwell,--- Martin Odersky \"/Concurrent Tries with Efficient Non-Blocking--- Snapshots/\"+-- * Aleksander Prokopec, Nathan G. Bronson, Phil Bagwell, Martin+-- Odersky \"/Concurrent Tries with Efficient Non-Blocking Snapshots/\" -- -- Operations have a worst-case complexity of /O(log n)/, with a base -- equal to the size of the native 'Word'.@@ -313,7 +311,7 @@ ----------------------------------------------------------------------- hashLength :: Int-hashLength = bitSize (undefined :: Word)+hashLength = finiteBitSize (undefined :: Word) bitsPerSubkey :: Int bitsPerSubkey = floor . logBase (2 :: Float) . fromIntegral $ hashLength
benchmarks/Concurrent.hs view
@@ -5,12 +5,12 @@ import Control.Applicative ((<$>)) import Control.Concurrent.Async import Control.Concurrent.MVar+import Control.Concurrent.STM import Control.DeepSeq import Control.Exception (evaluate) import Control.Monad import Control.Monad.IO.Class (liftIO) import Criterion.Main-import Criterion.Config import Data.Hashable import Data.List (foldl') import Data.Foldable (foldlM)@@ -18,105 +18,69 @@ import System.Random import System.Random.Shuffle import System.IO.Unsafe+import Text.Printf import qualified Control.Concurrent.Map as CM import qualified Data.Map as M import qualified Data.IntMap as IM import qualified Data.HashMap.Strict as HM +instance (NFData k, NFData v) => NFData (CM.Map k v) where+ rnf m = rnf $ unsafePerformIO $ CM.unsafeToList m+ main :: IO () main = do- let hmS = HM.fromList elemsS :: HM.HashMap String Int- hmS_mvar <- newMVar hmS- let hmS_ops241_8 = hmOps hmS_mvar elemsS 8 n (2,4,1)- let hmS_ops621_n10_8 = hmOps hmS_mvar elemsS 8 (n*10) (6,2,1)+ let o = 2^12+ let bench_ t o n io = env (mkElems t o n) $ \elems ->+ bench (printf "t=%d, o=%d, n=%d" t o n) $ whnfIO $ io elems - cmS <- CM.fromList elemsS :: IO (CM.Map String Int)- let cmS_ops241_8 = cmOps cmS elemsS 8 n (2,4,1)- let cmS_ops621_n10_8 = cmOps cmS elemsS 8 (n*10) (6,2,1)+ let bench_cm t o n = bench_ t o n $ \elems -> do+ m <- CM.empty+ runOps (\k -> CM.insert k k m) elems - putStrLn $ "n=" ++ show n+ bench_hm_mvar t o n = bench_ t o n $ \elems -> do+ m <- newMVar HM.empty+ runOps (\k -> hm_insert k k m) elems - defaultMainWith defaultConfig- (liftIO $ do- evaluate $ rnf hmS- evaluate $ sum $ map length hmS_ops241_8- evaluate $ sum $ map length hmS_ops621_n10_8- evaluate $ rnf $ unsafePerformIO $ CM.unsafeToList cmS- evaluate $ sum $ map length cmS_ops241_8- evaluate $ sum $ map length cmS_ops621_n10_8- return ()- )- [- bgroup "Data.HashMap (MVar)"- [ bgroup "String"- [ bench "8 threads, n, 2:4:1" $ runAll hmS_ops241_8- , bench "8 threads, 10n, 6:2:1" $ runAll hmS_ops621_n10_8+ bench_hm_tvar t o n = bench_ t o n $ \elems -> do+ m <- newTVarIO HM.empty+ runOps (\k -> hm_insert_tvar k k m) elems++ defaultMain+ [ bgroup "Insert"+ [ bgroup "Control.Concurrent.Map"+ [ bench_cm 100 o 1+ , bench_cm 100 o (o `div` 10)+ , bench_cm 100 o o+ , bench_cm 1000 o 1+ , bench_cm 1000 o (o `div` 10)+ , bench_cm 1000 o o ]- ]- ,- bgroup "Control.Concurrent.Map"- [ bgroup "String"- [ bench "8 threads, n, 2:4:1" $ runAll cmS_ops241_8- , bench "8 threads, 10n, 6:2:1" $ runAll cmS_ops621_n10_8+ , bgroup "Data.HashMap (TVar)"+ [ bench_hm_tvar 100 o 1+ , bench_hm_tvar 100 o (o `div` 10)+ , bench_hm_tvar 100 o o+ , bench_hm_tvar 1000 o 1+ , bench_hm_tvar 1000 o (o `div` 10)+ , bench_hm_tvar 1000 o o ]+ --, bgroup "Data.HashMap (MVar)"+ -- [ bench_hm_mvar 100 o 1+ -- , bench_hm_mvar 100 o (o `div` 10)+ -- , bench_hm_mvar 100 o o+ -- ] ] ]- where- n = 2^12- elemsS = zip keysS [1..n]- elemsI = zip keysI [1..n]- keysS = rndS 8 n- keysI = rndI (n+n) n --rndS :: Int -> Int -> [String]-rndS strlen num = take num $ split $ randomRs ('a', 'z') $ mkStdGen 1234- where- split cs = case splitAt strlen cs of (str, cs') -> str : split cs'--rndI :: Int -> Int -> [Int]-rndI upper num = take num $ randomRs (0, upper) $ mkStdGen 1234---runAll :: [[IO ()]] -> IO ()-runAll ops = do- as <- mapM (async . sequence_) ops- mapM_ wait as---mkOps :: (k -> m -> IO ()) -- lookup function- -> (k -> v -> m -> IO ()) -- insert function- -> (k -> m -> IO ()) -- delete function- -> m -> [(k,v)] -- the map & the elements from which to draw- -> Int -- the number of threads- -> Int -- the number of operations per thread- -> (Int, Int, Int) -- ratio of lookups : insertions : deletions- -> [[IO ()]]-mkOps lookup insert delete m elems nThreads nOps (rl,ri,rd) =- let tot = fromIntegral $ rl + ri + rd- numLookups = ceiling $ fromIntegral nOps * (fromIntegral rl / tot)- numInserts = ceiling $ fromIntegral nOps * (fromIntegral ri / tot)- numDeletes = ceiling $ fromIntegral nOps * (fromIntegral rd / tot)-- lookupElems = shuffle' (take nOps $ cycle elems) nOps (mkStdGen 1234)- insertElems = shuffle' (take nOps $ cycle elems) nOps (mkStdGen 5678)- deleteElems = shuffle' (take nOps $ cycle elems) nOps (mkStdGen 9012)-- ops0 = [lookup k m | (k,_) <- take numLookups lookupElems]- ++ [insert k v m | (k,v) <- take numInserts insertElems]- ++ [delete k m | (k,_) <- take numDeletes deleteElems]+mkElems :: Int -> Int -> Int -> IO [[Int]]+mkElems t o n = return $ [take o $ randomRs (0, n-1) (mkStdGen s) | s <- [1..t]] - ops = take nThreads- $ iterate (\ops -> shuffle' ops nOps (mkStdGen 1234))- $ take nOps ops0- in ops+runOps :: (k -> IO ()) -> [[k]] -> IO ()+runOps f elems = mapM_ wait =<< mapM (async . sequence_ . map f) elems ----------------------------------------------------------------------- -- Control.Concurrent.Map -cmOps = mkOps cm_lookup CM.insert CM.delete- cm_lookup :: (Eq k, Hashable k) => k -> CM.Map k v -> IO () cm_lookup k m = do let v = CM.lookup k m@@ -124,15 +88,11 @@ {-# SPECIALIZE cm_lookup :: String -> CM.Map String Int -> IO () #-} {-# SPECIALIZE cm_lookup :: Int -> CM.Map Int Int -> IO () #-} - -------------------------------------------------------------------------- Data.HashMap--hmOps = mkOps hm_lookup hm_insert hm_delete+-- Data.HashMap (MVar) hm_lookup :: (Eq k, Hashable k) => k -> MVar (HM.HashMap k v) -> IO () hm_lookup k mvar = do- --return undefined m <- takeMVar mvar putMVar mvar m let v = HM.lookup k m@@ -142,7 +102,6 @@ hm_insert :: (Eq k, Hashable k) => k -> v -> MVar (HM.HashMap k v) -> IO () hm_insert k v mvar = do- --return () m <- takeMVar mvar putMVar mvar $! HM.insert k v m {-# SPECIALIZE hm_insert :: String -> Int -> MVar (HM.HashMap String Int) -> IO () #-}@@ -150,10 +109,29 @@ hm_delete :: (Eq k, Hashable k) => k -> MVar (HM.HashMap k v) -> IO () hm_delete k mvar = do- --return () m <- takeMVar mvar putMVar mvar $! HM.delete k m {-# SPECIALIZE hm_delete :: String -> MVar (HM.HashMap String Int) -> IO () #-} {-# SPECIALIZE hm_delete :: Int -> MVar (HM.HashMap Int Int) -> IO () #-} +-----------------------------------------------------------------------+-- Data.HashMap (TVar)++hm_lookup_tvar :: (Eq k, Hashable k) => k -> TVar (HM.HashMap k v) -> IO ()+hm_lookup_tvar k tvar = do+ v <- atomically $ do m <- readTVar tvar+ return $ HM.lookup k m+ v `seq` return ()+{-# SPECIALIZE hm_lookup_tvar :: String -> TVar (HM.HashMap String Int) -> IO () #-}+{-# SPECIALIZE hm_lookup_tvar :: Int -> TVar (HM.HashMap Int Int) -> IO () #-}++hm_insert_tvar :: (Eq k, Hashable k) => k -> v -> TVar (HM.HashMap k v) -> IO ()+hm_insert_tvar k v tvar = atomically $ modifyTVar' tvar (HM.insert k v)+{-# SPECIALIZE hm_insert_tvar :: String -> Int -> TVar (HM.HashMap String Int) -> IO () #-}+{-# SPECIALIZE hm_insert_tvar :: Int -> Int -> TVar (HM.HashMap Int Int) -> IO () #-}++hm_delete_tvar :: (Eq k, Hashable k) => k -> TVar (HM.HashMap k v) -> IO ()+hm_delete_tvar k tvar = atomically $ modifyTVar' tvar (HM.delete k)+{-# SPECIALIZE hm_delete_tvar :: String -> TVar (HM.HashMap String Int) -> IO () #-}+{-# SPECIALIZE hm_delete_tvar :: Int -> TVar (HM.HashMap Int Int) -> IO () #-}
benchmarks/Sequential.hs view
@@ -5,7 +5,6 @@ import Control.Exception (evaluate) import Control.Monad.IO.Class (liftIO) import Criterion.Main-import Criterion.Config import Data.Hashable import Data.List (foldl') import Data.Foldable (foldlM)@@ -21,28 +20,57 @@ -- like with the tests, a lot of this is cribbed from unordered-containers +-- TODO: make Ctrie a proper NFData instance+instance (NFData k, NFData v) => NFData (CM.Map k v) where+ rnf m = rnf $ unsafePerformIO $ CM.unsafeToList m+ main :: IO () main = do- let mS = M.fromList elemsS :: M.Map String Int- mI = M.fromList elemsI :: M.Map Int Int- hmS = HM.fromList elemsS :: HM.HashMap String Int- hmI = HM.fromList elemsI :: HM.HashMap Int Int- imI = IM.fromList elemsI :: IM.IntMap Int- cmS <- CM.fromList elemsS :: IO (CM.Map String Int)- cmI <- CM.fromList elemsI :: IO (CM.Map Int Int)- defaultMainWith defaultConfig- (liftIO $ do- evaluate $ rnf mS- evaluate $ rnf mI- evaluate $ rnf hmS- evaluate $ rnf hmI- evaluate $ rnf imI- evaluate $ rnf $ unsafePerformIO $ CM.unsafeToList cmS- evaluate $ rnf $ unsafePerformIO $ CM.unsafeToList cmI- )- [- bgroup "Data.Map"+ let n = 2^12+ keysS = rndS 8 n+ keysI = rndI (n+n) n+ elemsS = zip keysS [1..n]+ elemsI = zip keysI [1..n]++ let mkConcMap = do+ cmS <- CM.fromList elemsS :: IO (CM.Map String Int)+ cmI <- CM.fromList elemsI :: IO (CM.Map Int Int)+ return (keysS, elemsS, cmS, keysI, elemsI, cmI)++ let mkMap = do+ let mS = M.fromList elemsS :: M.Map String Int+ mI = M.fromList elemsI :: M.Map Int Int+ return (keysS, elemsS, mS, keysI, elemsI, mI)++ let mkHashMap = do+ let hmS = HM.fromList elemsS :: HM.HashMap String Int+ hmI = HM.fromList elemsI :: HM.HashMap Int Int+ return (keysS, elemsS, hmS, keysI, elemsI, hmI)++ let mkIntMap = do+ let imI = IM.fromList elemsI :: IM.IntMap Int+ return (keysI, elemsI, imI)++ defaultMain [+ env mkConcMap $ \ ~(keysS, elemsS, cmS, keysI, elemsI, cmI) ->+ bgroup "Control.Concurrent.Map" [ bgroup "lookup"+ [ bench "String" $ whnfIO $ lookupCM keysS cmS+ , bench "Int" $ whnfIO $ lookupCM keysI $ cmI+ ]+ , bgroup "insert"+ [ bench "String" $ whnfIO $ insertCM elemsS =<< CM.empty+ , bench "Int" $ whnfIO $ insertCM elemsI =<< CM.empty+ ]+ , bgroup "delete"+ [ bench "String" $ whnfIO $ deleteCM keysS cmS+ , bench "Int" $ whnfIO $ deleteCM keysI cmI+ ]+ ]++ , env mkMap $ \ ~(keysS, elemsS, mS, keysI, elemsI, mI) ->+ bgroup "Data.Map"+ [ bgroup "lookup" [ bench "String" $ whnf (lookupM keysS) mS , bench "Int" $ whnf (lookupM keysI) mI ]@@ -56,7 +84,8 @@ ] ] - , bgroup "Data.HashMap"+ , env mkHashMap $ \ ~(keysS, elemsS, hmS, keysI, elemsI, hmI) ->+ bgroup "Data.HashMap" [ bgroup "lookup" [ bench "String" $ whnf (lookupHM keysS) hmS , bench "Int" $ whnf (lookupHM keysI) hmI@@ -71,7 +100,8 @@ ] ] - , bgroup "Data.IntMap"+ , env mkIntMap $ \ ~(keysI, elemsI, imI) ->+ bgroup "Data.IntMap" [ bgroup "lookup" [ bench "Int" $ whnf (lookupIM keysI) imI ] , bgroup "insert"@@ -79,28 +109,9 @@ , bgroup "delete" [ bench "Int" $ whnf (deleteIM keysI) imI ] ]-- , bgroup "Control.Concurrent.Map"- [ bgroup "lookup"- [ bench "String" $ lookupCM keysS cmS- , bench "Int" $ lookupCM keysI cmI- ]- , bgroup "insert"- [ bench "String" $ insertCM elemsS =<< CM.empty- , bench "Int" $ insertCM elemsI =<< CM.empty- ]- , bgroup "delete"- [ bench "String" $ deleteCM keysS cmS- , bench "Int" $ deleteCM keysI cmI- ]- ] ]- where- n = 2^12- elemsS = zip keysS [1..n]- elemsI = zip keysI [1..n]- keysS = rndS 8 n- keysI = rndI (n+n) n++ rndS :: Int -> Int -> [String] rndS strlen num = take num $ split $ randomRs ('a', 'z') $ mkStdGen 1234
+ changelog.md view
@@ -0,0 +1,5 @@+# Changelog for the [`ctrie` package](http://hackage.haskell.org/package/ctrie)++## 0.1.0.2 *Oct 2014*+ * Use newer versions of base and atomic-primops+ * Update benchmarks for criterion 1.0
ctrie.cabal view
@@ -1,8 +1,8 @@ name: ctrie-version: 0.1.0.1+version: 0.1.0.2 synopsis: Non-blocking concurrent map description:- A non-blocking concurrent map implementation based on + A non-blocking concurrent map implementation based on /lock-free concurrent hash tries/ (aka /Ctries/). license: MIT license-file: LICENSE@@ -15,12 +15,14 @@ build-type: Simple cabal-version: >=1.8 +extra-source-files: changelog.md+ library exposed-modules: Control.Concurrent.Map other-modules: Control.Concurrent.Map.Array build-depends:- base ==4.6.*- , atomic-primops ==0.4.*+ base >=4.7 && <4.8+ , atomic-primops ==0.6.* , hashable ==1.2.* , primitive ==0.5.* @@ -51,7 +53,7 @@ , random , transformers , deepseq- , criterion+ , criterion == 1.0.* , containers , unordered-containers , ctrie@@ -61,7 +63,7 @@ benchmark concurrent hs-source-dirs: benchmarks main-is: Concurrent.hs- type: exitcode-stdio-1.0 + type: exitcode-stdio-1.0 build-depends: base@@ -71,12 +73,13 @@ , random-shuffle , transformers , deepseq- , criterion+ , criterion == 1.0.* , containers , unordered-containers , ctrie+ , stm - ghc-options: -O2 -rtsopts -threaded+ ghc-options: -O2 -rtsopts -threaded -with-rtsopts=-N source-repository head type: git