ctrie (empty) → 0.1.0.0
raw patch · 8 files changed
+1024/−0 lines, 8 filesdep +QuickCheckdep +asyncdep +basesetup-changed
Dependencies added: QuickCheck, async, base, containers, criterion, ctrie, deepseq, hashable, primitive, random, random-shuffle, test-framework, test-framework-quickcheck2, transformers, unordered-containers
Files
- Control/Concurrent/Map.hs +389/−0
- Control/Concurrent/Map/Array.hs +109/−0
- LICENSE +21/−0
- Setup.hs +2/−0
- benchmarks/Concurrent.hs +159/−0
- benchmarks/Sequential.hs +178/−0
- ctrie.cabal +81/−0
- tests/MapProperties.hs +85/−0
+ Control/Concurrent/Map.hs view
@@ -0,0 +1,389 @@+{-# LANGUAGE BangPatterns, PatternGuards, MagicHash #-}+{-# OPTIONS_GHC -funbox-strict-fields #-}+-----------------------------------------------------------------------+-- | A non-blocking concurrent map from hashable keys to values.+--+-- The implementation is based on /lock-free concurrent hash tries/+-- (aka /Ctries/) as described by:+--+-- * 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/\"+--+-- Operations have a worst-case complexity of /O(log n)/, with a base+-- equal to the size of the native 'Word'.+--+-----------------------------------------------------------------------++-- [Note: CAS and pointer equality]+-- ~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~+-- For the atomic compare-and-swap, we need to be able to compare two+-- CNode objects. We can't do an actual '==' comparison, as that would+-- entail traversing the whole subtree. We could add a 'Unique' to the+-- CNode and compare on that, but we don't want the overhead.+--+-- The only remaining option is pointer equality. The "proper" way would+-- be to use 'StableName' (although we'd need 'unsafePerformIO' to use it+-- inside 'atomicModifyIORef') but GHC's 'reallyUnsafePtrEquality#' is+-- more than twice as fast and, despite the scary name, seems to be+-- perfectly safe to use (unordered-containers uses it, for example).+--+-- If portability is a concern, we can always #ifdef the relevant section.++module Control.Concurrent.Map+ ( Map++ -- * Construction+ , empty++ -- * Modification+ , insert+ , delete++ -- * Query+ , lookup++ -- * Lists+ , fromList+ , unsafeToList++ --, printMap+ ) where++import Control.Applicative ((<$>))+import Control.Monad+import Data.Bits+import Data.Hashable (Hashable)+import qualified Data.Hashable as H+import Data.IORef+import qualified Data.List as List+import Data.Maybe+import Data.Word+import GHC.Exts ((==#), reallyUnsafePtrEquality#)+import Prelude hiding (lookup)++import qualified Control.Concurrent.Map.Array as A++-----------------------------------------------------------------------++-- | A map from keys @k@ to values @v@.+newtype Map k v = Map (INode k v)++type INode k v = IORef (MainNode k v)++data MainNode k v = CNode !Bitmap !(A.Array (Branch k v))+ | Tomb !(SNode k v)+ | Collision ![SNode k v]++data Branch k v = INode !(INode k v)+ | SNode !(SNode k v)++data SNode k v = S !k v+ deriving (Eq, Show)++isTomb :: MainNode k v -> Bool+isTomb (Tomb _) = True+isTomb _ = False++type Bitmap = Word+type Hash = Word+type Level = Int++hash :: Hashable a => a -> Hash+hash = fromIntegral . H.hash+++-----------------------------------------------------------------------+-- * Construction++-- | /O(1)/. Construct an empty map.+empty :: IO (Map k v)+empty = Map <$> newIORef (CNode 0 A.empty)+++-----------------------------------------------------------------------+-- * Modification++-- | /O(log n)/. Associate the given value with the given key.+-- If the key is already present in the map, the old value is replaced.+insert :: (Eq k, Hashable k) => k -> v -> Map k v -> IO ()+insert k v (Map root) = go0+ where+ h = hash k+ go0 = go 0 undefined root+ go lev parent inode = do+ main <- readIORef inode+ case main of+ cn@(CNode bmp arr) -> do+ let m = mask h lev+ i = sparseIndex bmp m+ n = popCount bmp+ if bmp .&. m == 0+ then do+ let arr' = A.insert (SNode (S k v)) i n arr+ cn' = CNode (bmp .|. m) arr'+ unlessM (compareAndSwap inode cn cn') go0++ else case A.index arr i of+ SNode (S k2 v2)+ | k == k2 -> do+ let arr' = A.update (SNode (S k v)) i n arr+ cn' = CNode bmp arr'+ unlessM (compareAndSwap inode cn cn') go0++ | otherwise -> do+ let h2 = hash k2+ inode2 <- newINode h k v h2 k2 v2 (nextLevel lev)+ let arr' = A.update (INode inode2) i n arr+ cn' = CNode bmp arr'+ unlessM (compareAndSwap inode cn cn') go0++ INode inode2 -> go (nextLevel lev) inode inode2++ Tomb _ -> clean parent (prevLevel lev) >> go0++ col@(Collision arr) -> do+ let arr' = S k v : filter (\(S k2 _) -> k2 /= k) arr+ col' = Collision arr'+ unlessM (compareAndSwap inode col col') go0++{-# INLINABLE insert #-}++newINode :: Hash -> k -> v -> Hash -> k -> v -> Int -> IO (INode k v)+newINode h1 k1 v1 h2 k2 v2 lev+ | lev >= hashLength = newIORef $ Collision [S k1 v1, S k2 v2]+ | otherwise = do+ let i1 = index h1 lev+ i2 = index h2 lev+ bmp = (unsafeShiftL 1 i1) .|. (unsafeShiftL 1 i2)+ case compare i1 i2 of+ LT -> newIORef $ CNode bmp $ A.pair (SNode (S k1 v1)) (SNode (S k2 v2))+ GT -> newIORef $ CNode bmp $ A.pair (SNode (S k2 v2)) (SNode (S k1 v1))+ EQ -> do inode' <- newINode h1 k1 v1 h2 k2 v2 (nextLevel lev)+ newIORef $ CNode bmp $ A.singleton (INode inode')+++-- | /O(log n)/. Remove the given key and its associated value from the map,+-- if present.+delete :: (Eq k, Hashable k) => k -> Map k v -> IO ()+delete k (Map root) = go0+ where+ h = hash k+ go0 = go 0 undefined root+ go lev parent inode = do+ main <- readIORef inode+ case main of+ cn@(CNode bmp arr) -> do+ let m = mask h lev+ i = sparseIndex bmp m+ if bmp .&. m == 0+ then return () -- not found+ else case A.index arr i of+ SNode (S k2 _)+ | k == k2 -> do+ let arr' = A.delete i (popCount bmp) arr+ cn' = CNode (bmp `xor` m) arr'+ cn'' = contract lev cn'+ unlessM (compareAndSwap inode cn cn'') go0+ whenM (isTomb <$> readIORef inode) $+ cleanParent parent inode h (prevLevel lev)++ | otherwise -> return () -- not found++ INode inode2 -> go (nextLevel lev) inode inode2++ Tomb _ -> clean parent (prevLevel lev) >> go0++ col@(Collision arr) -> do+ let arr' = filter (\(S k2 _) -> k2 /= k) $ arr+ col' | [s] <- arr' = Tomb s+ | otherwise = Collision arr'+ unlessM (compareAndSwap inode col col') go0++{-# INLINABLE delete #-}++-----------------------------------------------------------------------+-- * Query++-- | /O(log n)/. Return the value associated with the given key, or 'Nothing'.+lookup :: (Eq k, Hashable k) => k -> Map k v -> IO (Maybe v)+lookup k (Map root) = go0+ where+ h = hash k+ go0 = go 0 undefined root+ go lev parent inode = do+ main <- readIORef inode+ case main of+ CNode bmp arr -> do+ let m = mask h lev+ i = sparseIndex bmp m+ if bmp .&. m == 0+ then return Nothing+ else case A.index arr i of+ INode inode2 -> go (nextLevel lev) inode inode2+ SNode (S k2 v) | k == k2 -> return (Just v)+ | otherwise -> return Nothing++ Tomb _ -> clean parent (prevLevel lev) >> go0++ Collision xs -> do+ case List.find (\(S k2 _) -> k2 == k) xs of+ Just (S _ v) -> return (Just v)+ _ -> return Nothing++{-# INLINABLE lookup #-}++-----------------------------------------------------------------------+-- * Internal compression operations++clean :: INode k v -> Level -> IO ()+clean inode lev = do+ main <- readIORef inode+ case main of+ cn@(CNode _ _) -> do+ cn' <- compress lev cn+ void $ compareAndSwap inode cn cn'+ _ -> return ()+{-# INLINE clean #-}++cleanParent :: INode k v -> INode k v -> Hash -> Level -> IO ()+cleanParent parent inode h lev = do+ pmain <- readIORef parent+ case pmain of+ cn@(CNode bmp arr) -> do+ let m = mask h lev+ i = sparseIndex bmp m+ unless (bmp .&. m == 0) $+ case A.index arr i of+ INode inode2 | inode2 == inode ->+ whenM (isTomb <$> readIORef inode) $ do+ cn' <- compress lev cn+ unlessM (compareAndSwap parent cn cn') $+ cleanParent parent inode h lev+ _ -> return ()+ _ -> return ()++compress :: Level -> MainNode k v -> IO (MainNode k v)+compress lev (CNode bmp arr) =+ contract lev <$> CNode bmp <$> A.mapM resurrect (popCount bmp) arr+compress _ x = return x+{-# INLINE compress #-}++resurrect :: Branch k v -> IO (Branch k v)+resurrect b@(INode inode) = do+ main <- readIORef inode+ case main of+ Tomb s -> return (SNode s)+ _ -> return b+resurrect b = return b+{-# INLINE resurrect #-}++contract :: Level -> MainNode k v -> MainNode k v+contract lev (CNode bmp arr) | lev > 0+ , popCount bmp == 1+ , SNode s <- A.head arr+ = Tomb s+contract _ x = x+{-# INLINE contract #-}++-----------------------------------------------------------------------+-- * Lists++-- | /O(n * log n)/. Construct a map from a list of key/value pairs.+fromList :: (Eq k, Hashable k) => [(k,v)] -> IO (Map k v)+fromList xs = empty >>= \m -> mapM_ (\(k,v) -> insert k v m) xs >> return m+{-# INLINABLE fromList #-}++-- | /O(n)/. Unsafely convert the map to a list of key/value pairs.+--+-- WARNING: 'unsafeToList' makes no atomicity guarantees. Concurrent+-- changes to the map will lead to inconsistent results.+unsafeToList :: Map k v -> IO [(k,v)]+unsafeToList (Map root) = go root+ where+ go inode = do+ main <- readIORef inode+ case main of+ CNode bmp arr -> A.foldM' go2 [] (popCount bmp) arr+ Tomb (S k v) -> return [(k,v)]+ Collision xs -> return $ map (\(S k v) -> (k,v)) xs++ go2 xs (INode inode) = go inode >>= \ys -> return (ys ++ xs)+ go2 xs (SNode (S k v)) = return $ (k,v) : xs+{-# INLINABLE unsafeToList #-}++-----------------------------------------------------------------------++-- see [Note: CAS and pointer equality]+compareAndSwap :: IORef a -> a -> a -> IO Bool+compareAndSwap ref old new =+ atomicModifyIORef' ref (\cur -> if cur `ptrEq` old+ then (new, True)+ else (cur, False))+{-# INLINE compareAndSwap #-}++ptrEq :: a -> a -> Bool+ptrEq !x !y = reallyUnsafePtrEquality# x y ==# 1#+{-# INLINE ptrEq #-}+++whenM :: Monad m => m Bool -> m () -> m ()+whenM p s = p >>= \t -> if t then s else return ()+{-# INLINE whenM #-}++unlessM :: Monad m => m Bool -> m () -> m ()+unlessM p s = p >>= \t -> if t then return () else s+{-# INLINE unlessM #-}++-----------------------------------------------------------------------++hashLength :: Int+hashLength = bitSize (undefined :: Word)++bitsPerSubkey :: Int+bitsPerSubkey = floor . logBase (2 :: Float) . fromIntegral $ hashLength++subkeyMask :: Bitmap+subkeyMask = 1 `unsafeShiftL` bitsPerSubkey - 1++index :: Hash -> Level -> Int+index h lev = fromIntegral $ (h `unsafeShiftR` lev) .&. subkeyMask+{-# INLINE index #-}++-- when or-ed with a CNode bitmap, determines if the hash is present+-- in the array at the given level of the trie+mask :: Hash -> Level -> Bitmap+mask h lev = 1 `unsafeShiftL` index h lev+{-# INLINE mask #-}++-- position in the CNode array+sparseIndex :: Bitmap -> Bitmap -> Int+sparseIndex bmp m = popCount ((m - 1) .&. bmp)+{-# INLINE sparseIndex #-}++nextLevel :: Level -> Level+nextLevel = (+) bitsPerSubkey+{-# INLINE nextLevel #-}++prevLevel :: Level -> Level+prevLevel = subtract bitsPerSubkey+{-# INLINE prevLevel #-}++-----------------------------------------------------------------------++-- TODO+--printMap :: (Show k, Show v) => Map k v -> IO ()+--printMap (Map root) = goI root+-- where+-- goI inode = putStr "(I " >> readIORef inode >>= goM >> putStr ")\n"+-- goM (CNode bmp arr) = do+-- putStr $ "(C " ++ (show bmp) ++ " ["+-- A.mapM_ (\b -> goB b >> putStr ", ") (popCount bmp) arr+-- putStr $ "] )"+-- goM (Tomb (S k v)) = putStr $ "(T " ++ (show k) ++ " " ++ (show v) ++ ")"+-- goM (Collision xs) = putStr $ "(Collision " ++ show xs ++ ")"+-- goB (INode i) = putStr "\n" >> goI i+-- goB (SNode (S k v)) = putStr $ "(" ++ (show k) ++ "," ++ (show v) ++ ")"
+ Control/Concurrent/Map/Array.hs view
@@ -0,0 +1,109 @@+{-# LANGUAGE BangPatterns #-}++-- | Convenient interface for 'Data.Primitive.Array'.+module Control.Concurrent.Map.Array+ ( Array+ , empty, singleton, pair+ , head, index+ , insert, update, delete+ , mapM, mapM_, foldM'+ ) where++import Control.Monad.Primitive+import Control.Monad.ST+import Data.Primitive.Array+import Prelude hiding (head, mapM, mapM_)++-----------------------------------------------------------------------++empty :: Array a+empty = runST $ unsafeFreezeArray =<< newArray 0 undefined+{-# INLINE empty #-}++singleton :: a -> Array a+singleton x = runST $ do+ marr <- newArray 1 x+ unsafeFreezeArray marr+{-# INLINE singleton #-}++pair :: a -> a -> Array a+pair x y = runST $ do+ marr <- newArray 2 undefined+ writeArray marr 0 x+ writeArray marr 1 y+ unsafeFreezeArray marr+{-# INLINE pair #-}++-----------------------------------------------------------------------++head :: Array a -> a+head = flip indexArray 0+{-# INLINE head #-}++index :: Array a -> Int -> a+index = indexArray+{-# INLINE index #-}++-----------------------------------------------------------------------++insert :: a -> Int -> Int -> Array a -> Array a+insert x i n arr = runST $ do+ marr <- newArray (n+1) undefined+ copyArray marr 0 arr 0 i+ writeArray marr i x+ copyArray marr (i+1) arr i (n-i)+ unsafeFreezeArray marr+{-# INLINE insert #-}++update :: a -> Int -> Int -> Array a -> Array a+update x i n arr = runST $ do+ marr <- newArray n undefined+ copyArray marr 0 arr 0 n+ writeArray marr i x+ unsafeFreezeArray marr+{-# INLINE update #-}++delete :: Int -> Int -> Array a -> Array a+delete i n arr = runST $ do+ marr <- newArray (n-1) undefined+ copyArray marr 0 arr 0 i+ copyArray marr i arr (i+1) (n-(i+1))+ unsafeFreezeArray marr+{-# INLINE delete #-}++-----------------------------------------------------------------------++mapM :: PrimMonad m => (a -> m b) -> Int -> Array a -> m (Array b)+mapM f = \n arr -> do+ marr <- newArray n undefined+ go n arr marr 0+ unsafeFreezeArray marr+ where+ go n arr marr i+ | i >= n = return ()+ | otherwise = do+ x <- indexArrayM arr i+ writeArray marr i =<< f x+ go n arr marr (i+1)+{-# INLINE mapM #-}++mapM_ :: PrimMonad m => (a -> m b) -> Int -> Array a -> m ()+mapM_ f = \n arr -> go n arr 0+ where+ go n arr i+ | i >= n = return ()+ | otherwise = do+ x <- indexArrayM arr i+ _ <- f x+ go n arr (i+1)+{-# INLINE mapM_ #-}++foldM' :: PrimMonad m => (b -> a -> m b) -> b -> Int -> Array a -> m b+foldM' f z0 = \n arr -> go n arr 0 z0+ where+ go n arr i !z+ | i >= n = return z+ | otherwise = do+ x <- indexArrayM arr i+ go n arr (i+1) =<< f z x+{-# INLINE foldM' #-}
+ LICENSE view
@@ -0,0 +1,21 @@++The MIT License (MIT)++Copyright (c) 2013 Michael Schröder++Permission is hereby granted, free of charge, to any person obtaining a copy of+this software and associated documentation files (the "Software"), to deal in+the Software without restriction, including without limitation the rights to+use, copy, modify, merge, publish, distribute, sublicense, and/or sell copies of+the Software, and to permit persons to whom the Software is furnished to do so,+subject to the following conditions:++The above copyright notice and this permission notice shall be included in all+copies or substantial portions of the Software.++THE SOFTWARE IS PROVIDED "AS IS", WITHOUT WARRANTY OF ANY KIND, EXPRESS OR+IMPLIED, INCLUDING BUT NOT LIMITED TO THE WARRANTIES OF MERCHANTABILITY, FITNESS+FOR A PARTICULAR PURPOSE AND NONINFRINGEMENT. IN NO EVENT SHALL THE AUTHORS OR+COPYRIGHT HOLDERS BE LIABLE FOR ANY CLAIM, DAMAGES OR OTHER LIABILITY, WHETHER+IN AN ACTION OF CONTRACT, TORT OR OTHERWISE, ARISING FROM, OUT OF OR IN+CONNECTION WITH THE SOFTWARE OR THE USE OR OTHER DEALINGS IN THE SOFTWARE.
+ Setup.hs view
@@ -0,0 +1,2 @@+import Distribution.Simple+main = defaultMain
+ benchmarks/Concurrent.hs view
@@ -0,0 +1,159 @@+{-# LANGUAGE BangPatterns #-}++module Main where++import Control.Applicative ((<$>))+import Control.Concurrent.Async+import Control.Concurrent.MVar+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)+import Data.Maybe+import System.Random+import System.Random.Shuffle+import System.IO.Unsafe++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++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)++ 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)++ putStrLn $ "n=" ++ show n++ 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+ ]+ ]+ ,+ 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+ ]+ ]+ ]+ 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]++ ops = take nThreads+ $ iterate (\ops -> shuffle' ops nOps (mkStdGen 1234))+ $ take nOps ops0+ in ops++-----------------------------------------------------------------------+-- 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+ v `seq` return ()+{-# 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++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+ v `seq` return ()+{-# SPECIALIZE hm_lookup :: String -> MVar (HM.HashMap String Int) -> IO () #-}+{-# SPECIALIZE hm_lookup :: Int -> MVar (HM.HashMap Int Int) -> IO () #-}++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 () #-}+{-# SPECIALIZE hm_insert :: Int -> Int -> MVar (HM.HashMap Int Int) -> IO () #-}++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 () #-}++
+ benchmarks/Sequential.hs view
@@ -0,0 +1,178 @@+module Main where++import Control.Applicative ((<$>))+import Control.DeepSeq+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)+import Data.Maybe+import System.Random+import System.IO.Unsafe++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+++-- like with the tests, a lot of this is cribbed from unordered-containers++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"+ [ bgroup "lookup"+ [ bench "String" $ whnf (lookupM keysS) mS+ , bench "Int" $ whnf (lookupM keysI) mI+ ]+ , bgroup "insert"+ [ bench "String" $ whnf (insertM elemsS) M.empty+ , bench "Int" $ whnf (insertM elemsI) M.empty+ ]+ , bgroup "delete"+ [ bench "String" $ whnf (deleteM keysS) mS+ , bench "Int" $ whnf (deleteM keysI) mI+ ]+ ]++ , bgroup "Data.HashMap"+ [ bgroup "lookup"+ [ bench "String" $ whnf (lookupHM keysS) hmS+ , bench "Int" $ whnf (lookupHM keysI) hmI+ ]+ , bgroup "insert"+ [ bench "String" $ whnf (insertHM elemsS) HM.empty+ , bench "Int" $ whnf (insertHM elemsI) HM.empty+ ]+ , bgroup "delete"+ [ bench "String" $ whnf (deleteHM keysS) hmS+ , bench "Int" $ whnf (deleteHM keysI) hmI+ ]+ ]++ , bgroup "Data.IntMap"+ [ bgroup "lookup"+ [ bench "Int" $ whnf (lookupIM keysI) imI ]+ , bgroup "insert"+ [ bench "Int" $ whnf (insertIM elemsI) IM.empty ]+ , 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+ 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++-----------------------------------------------------------------------+-- Control.Concurrent.Map++lookupCM :: (Eq k, Hashable k) => [k] -> CM.Map k Int -> IO Int+lookupCM xs m = foldlM (\z k -> fromMaybe z <$> (CM.lookup k m)) 0 xs+{-# SPECIALIZE lookupCM :: [String] -> CM.Map String Int -> IO Int #-}+{-# SPECIALIZE lookupCM :: [Int] -> CM.Map Int Int -> IO Int #-}++insertCM :: (Eq k, Hashable k) => [(k, Int)] -> CM.Map k Int -> IO ()+insertCM xs m = mapM_ (\(k,v) -> CM.insert k v m) xs+{-# SPECIALIZE insertCM :: [(Int, Int)] -> CM.Map Int Int -> IO () #-}+{-# SPECIALIZE insertCM :: [(String, Int)] -> CM.Map String Int -> IO () #-}++deleteCM :: (Eq k, Hashable k) => [k] -> CM.Map k Int -> IO ()+deleteCM xs m = mapM_ (\k -> CM.delete k m) xs+{-# SPECIALIZE deleteCM :: [Int] -> CM.Map Int Int -> IO () #-}+{-# SPECIALIZE deleteCM :: [String] -> CM.Map String Int -> IO () #-}++-----------------------------------------------------------------------+-- Data.Map++lookupM :: Ord k => [k] -> M.Map k Int -> Int+lookupM xs m = foldl' (\z k -> fromMaybe z (M.lookup k m)) 0 xs+{-# SPECIALIZE lookupM :: [String] -> M.Map String Int -> Int #-}+{-# SPECIALIZE lookupM :: [Int] -> M.Map Int Int -> Int #-}++insertM :: Ord k => [(k, Int)] -> M.Map k Int -> M.Map k Int+insertM xs m0 = foldl' (\m (k, v) -> M.insert k v m) m0 xs+{-# SPECIALIZE insertM :: [(String, Int)] -> M.Map String Int -> M.Map String Int #-}+{-# SPECIALIZE insertM :: [(Int, Int)] -> M.Map Int Int -> M.Map Int Int #-}++deleteM :: Ord k => [k] -> M.Map k Int -> M.Map k Int+deleteM xs m0 = foldl' (\m k -> M.delete k m) m0 xs+{-# SPECIALIZE deleteM :: [String] -> M.Map String Int -> M.Map String Int #-}+{-# SPECIALIZE deleteM :: [Int] -> M.Map Int Int -> M.Map Int Int #-}++-----------------------------------------------------------------------+-- Data.HashMap++lookupHM :: (Eq k, Hashable k) => [k] -> HM.HashMap k Int -> Int+lookupHM xs m = foldl' (\z k -> fromMaybe z (HM.lookup k m)) 0 xs+{-# SPECIALIZE lookupHM :: [String] -> HM.HashMap String Int -> Int #-}+{-# SPECIALIZE lookupHM :: [Int] -> HM.HashMap Int Int -> Int #-}++insertHM :: (Eq k, Hashable k) => [(k, Int)] -> HM.HashMap k Int -> HM.HashMap k Int+insertHM xs m0 = foldl' (\m (k, v) -> HM.insert k v m) m0 xs+{-# SPECIALIZE insertHM :: [(Int, Int)] -> HM.HashMap Int Int -> HM.HashMap Int Int #-}+{-# SPECIALIZE insertHM :: [(String, Int)] -> HM.HashMap String Int -> HM.HashMap String Int #-}++deleteHM :: (Eq k, Hashable k) => [k] -> HM.HashMap k Int -> HM.HashMap k Int+deleteHM xs m0 = foldl' (\m k -> HM.delete k m) m0 xs+{-# SPECIALIZE deleteHM :: [Int] -> HM.HashMap Int Int -> HM.HashMap Int Int #-}+{-# SPECIALIZE deleteHM :: [String] -> HM.HashMap String Int -> HM.HashMap String Int #-}+++-----------------------------------------------------------------------+-- Data.IntMap++lookupIM :: [Int] -> IM.IntMap Int -> Int+lookupIM xs m = foldl' (\z k -> fromMaybe z (IM.lookup k m)) 0 xs++insertIM :: [(Int, Int)] -> IM.IntMap Int -> IM.IntMap Int+insertIM xs m0 = foldl' (\m (k, v) -> IM.insert k v m) m0 xs++deleteIM :: [Int] -> IM.IntMap Int -> IM.IntMap Int+deleteIM xs m0 = foldl' (\m k -> IM.delete k m) m0 xs
+ ctrie.cabal view
@@ -0,0 +1,81 @@+name: ctrie+version: 0.1.0.0+synopsis: Non-blocking concurrent map+description:+ A non-blocking concurrent map implementation based on + /lock-free concurrent hash tries/ (aka /Ctries/).+license: MIT+license-file: LICENSE+author: Michael Schröder+maintainer: mcschroeder@gmail.com+bug-reports: https://github.com/mcschroeder/ctrie/issues+copyright: (c) 2013 Michael Schröder+category: Concurrency, Data Structures+build-type: Simple+cabal-version: >=1.8++library+ exposed-modules: Control.Concurrent.Map+ other-modules: Control.Concurrent.Map.Array+ build-depends:+ base ==4.6.*+ , hashable ==1.2.*+ , primitive ==0.5.*++ ghc-options: -Wall++test-suite map-properties+ hs-source-dirs: tests+ main-is: MapProperties.hs+ type: exitcode-stdio-1.0++ build-depends:+ base+ , QuickCheck ==2.5.*+ , test-framework ==0.8.*+ , test-framework-quickcheck2 ==0.3.*+ , containers ==0.5.*+ , hashable ==1.2.*+ , ctrie++benchmark sequential+ hs-source-dirs: benchmarks+ main-is: Sequential.hs+ type: exitcode-stdio-1.0++ build-depends:+ base+ , hashable+ , random+ , transformers+ , deepseq+ , criterion+ , containers+ , unordered-containers+ , ctrie++ ghc-options: -O2 -rtsopts++benchmark concurrent+ hs-source-dirs: benchmarks+ main-is: Concurrent.hs+ type: exitcode-stdio-1.0 ++ build-depends:+ base+ , async+ , hashable+ , random+ , random-shuffle+ , transformers+ , deepseq+ , criterion+ , containers+ , unordered-containers+ , ctrie++ ghc-options: -O2 -rtsopts -threaded++source-repository head+ type: git+ location: https://github.com/mcschroeder/ctrie.git
+ tests/MapProperties.hs view
@@ -0,0 +1,85 @@+{-# LANGUAGE GeneralizedNewtypeDeriving #-}++module Main where++import Control.Applicative+import Control.Monad+import Data.Hashable+import Data.Function (on)+import qualified Data.Map as M+import qualified Data.List as L+import qualified Control.Concurrent.Map as CM+import Test.QuickCheck+import Test.QuickCheck.Monadic+import Test.Framework (defaultMain, testGroup)+import Test.Framework.Providers.QuickCheck2 (testProperty)++-- most of this based on the unordered-containers tests++-----------------------------------------------------------------------++main = defaultMain [ testGroup "basic interface"+ [ testProperty "lookup" pLookup+ , testProperty "insert" pInsert+ , testProperty "delete" pDelete+ ]+ , testGroup "conversions"+ [ testProperty "fromList" pFromList+ , testProperty "unsafeToList" pUnsafeToList+ ]+ ]++-----------------------------------------------------------------------++type Model k v = M.Map k v++eq :: (Eq a, Eq k, Hashable k, Ord k)+ => (Model k v -> a) -> (CM.Map k v -> IO a) -> [(k, v)] -> Property+eq f g xs = monadicIO $ do+ let a = f (M.fromList xs)+ b <- run $ g =<< CM.fromList xs+ assert $ a == b++eq_ :: (Eq k, Eq v, Hashable k, Ord k)+ => (Model k v -> Model k v) -> (CM.Map k v -> IO ()) -> [(k, v)] -> Property+eq_ f g xs = monadicIO $ do+ let a = M.toAscList $ f $ M.fromList xs+ m <- run $ CM.fromList xs+ run $ g m+ b <- run $ unsafeToAscList m+ assert $ a == b++unsafeToAscList :: Ord k => CM.Map k v -> IO [(k, v)]+unsafeToAscList m = do+ xs <- CM.unsafeToList m+ return $ L.sortBy (compare `on` fst) xs++-----------------------------------------------------------------------++-- key type that generates more hash collisions++newtype Key = K { unK :: Int }+ deriving (Arbitrary, Eq, Ord)++instance Show Key where+ show = show . unK++instance Hashable Key where+ hashWithSalt salt k = hashWithSalt salt (unK k) `mod` 20++-----------------------------------------------------------------------++pLookup :: Key -> [(Key,Int)] -> Property+pLookup k = M.lookup k `eq` CM.lookup k++pInsert :: Key -> Int -> [(Key,Int)] -> Property+pInsert k v = M.insert k v `eq_` CM.insert k v++pDelete :: Key -> [(Key,Int)] -> Property+pDelete k = M.delete k `eq_` CM.delete k++pFromList :: [(Key,Int)] -> Property+pFromList = id `eq_` (\_ -> return ())++pUnsafeToList :: [(Key,Int)] -> Property+pUnsafeToList = M.toAscList `eq` unsafeToAscList