ctrie 0.1.0.0 → 0.1.0.1
raw patch · 2 files changed
+24/−50 lines, 2 filesdep +atomic-primopsPVP ok
version bump matches the API change (PVP)
Dependencies added: atomic-primops
API changes (from Hackage documentation)
Files
- Control/Concurrent/Map.hs +21/−49
- ctrie.cabal +3/−1
Control/Concurrent/Map.hs view
@@ -18,21 +18,6 @@ -- ----------------------------------------------------------------------- --- [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 @@ -55,6 +40,7 @@ import Control.Applicative ((<$>)) import Control.Monad+import Data.Atomics import Data.Bits import Data.Hashable (Hashable) import qualified Data.Hashable as H@@ -62,7 +48,6 @@ 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@@ -115,9 +100,9 @@ h = hash k go0 = go 0 undefined root go lev parent inode = do- main <- readIORef inode- case main of- cn@(CNode bmp arr) -> do+ ticket <- readForCAS inode+ case peekTicket ticket of+ CNode bmp arr -> do let m = mask h lev i = sparseIndex bmp m n = popCount bmp@@ -125,30 +110,30 @@ then do let arr' = A.insert (SNode (S k v)) i n arr cn' = CNode (bmp .|. m) arr'- unlessM (compareAndSwap inode cn cn') go0+ unlessM (fst <$> casIORef inode ticket 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+ unlessM (fst <$> casIORef inode ticket 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+ unlessM (fst <$> casIORef inode ticket cn') go0 INode inode2 -> go (nextLevel lev) inode inode2 Tomb _ -> clean parent (prevLevel lev) >> go0 - col@(Collision arr) -> do+ Collision arr -> do let arr' = S k v : filter (\(S k2 _) -> k2 /= k) arr col' = Collision arr'- unlessM (compareAndSwap inode col col') go0+ unlessM (fst <$> casIORef inode ticket col') go0 {-# INLINABLE insert #-} @@ -174,9 +159,9 @@ h = hash k go0 = go 0 undefined root go lev parent inode = do- main <- readIORef inode- case main of- cn@(CNode bmp arr) -> do+ ticket <- readForCAS inode+ case peekTicket ticket of+ CNode bmp arr -> do let m = mask h lev i = sparseIndex bmp m if bmp .&. m == 0@@ -187,7 +172,7 @@ let arr' = A.delete i (popCount bmp) arr cn' = CNode (bmp `xor` m) arr' cn'' = contract lev cn'- unlessM (compareAndSwap inode cn cn'') go0+ unlessM (fst <$> casIORef inode ticket cn'') go0 whenM (isTomb <$> readIORef inode) $ cleanParent parent inode h (prevLevel lev) @@ -197,11 +182,11 @@ Tomb _ -> clean parent (prevLevel lev) >> go0 - col@(Collision arr) -> do+ 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+ unlessM (fst <$> casIORef inode ticket col') go0 {-# INLINABLE delete #-} @@ -241,18 +226,18 @@ clean :: INode k v -> Level -> IO () clean inode lev = do- main <- readIORef inode- case main of+ ticket <- readForCAS inode+ case peekTicket ticket of cn@(CNode _ _) -> do cn' <- compress lev cn- void $ compareAndSwap inode cn cn'+ void $ casIORef inode ticket 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+ ticket <- readForCAS parent+ case peekTicket ticket of cn@(CNode bmp arr) -> do let m = mask h lev i = sparseIndex bmp m@@ -261,7 +246,7 @@ INode inode2 | inode2 == inode -> whenM (isTomb <$> readIORef inode) $ do cn' <- compress lev cn- unlessM (compareAndSwap parent cn cn') $+ unlessM (fst <$> casIORef parent ticket cn') $ cleanParent parent inode h lev _ -> return () _ -> return ()@@ -316,19 +301,6 @@ {-# 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 ()
ctrie.cabal view
@@ -1,5 +1,5 @@ name: ctrie-version: 0.1.0.0+version: 0.1.0.1 synopsis: Non-blocking concurrent map description: A non-blocking concurrent map implementation based on @@ -8,6 +8,7 @@ license-file: LICENSE author: Michael Schröder maintainer: mcschroeder@gmail.com+homepage: https://github.com/mcschroeder/ctrie bug-reports: https://github.com/mcschroeder/ctrie/issues copyright: (c) 2013 Michael Schröder category: Concurrency, Data Structures@@ -19,6 +20,7 @@ other-modules: Control.Concurrent.Map.Array build-depends: base ==4.6.*+ , atomic-primops ==0.4.* , hashable ==1.2.* , primitive ==0.5.*