packages feed

ttrie (empty) → 0.1

raw patch · 9 files changed

+861/−0 lines, 9 filesdep +asyncdep +atomic-primopsdep +basesetup-changed

Dependencies added: async, atomic-primops, base, bifunctors, containers, criterion-plus, deepseq, hashable, mwc-random, primitive, stm, stm-containers, stm-stats, text, transformers, ttrie, unordered-containers, vector

Files

+ LICENSE view
@@ -0,0 +1,22 @@+The MIT License (MIT)++Copyright (c) 2015 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.+
+ README.md view
@@ -0,0 +1,10 @@+A contention-free STM hash map for Haskell.++"Contention-free" means that the map will never cause spurious conflicts.+A transaction operating on the map will only ever have to retry if+another transaction is operating on the same key at the same time.++This is an implementation of the *transactional trie*,+which is basically a *lock-free concurrent hash trie* lifted into STM.+For a detailed discussion, including an evaluation of its performance,+see Chapter 4 of [my master's thesis](https://github.com/mcschroeder/thesis).
+ Setup.hs view
@@ -0,0 +1,2 @@+import Distribution.Simple+main = defaultMain
+ benchmarks/Bench.hs view
@@ -0,0 +1,200 @@+{-# LANGUAGE DeriveGeneric #-}+{-# LANGUAGE OverloadedStrings #-}+module Main where++import BenchGen+import Control.Applicative+import Control.Concurrent.Async+import Control.Concurrent.STM+import Control.Concurrent.STM.Stats+import Control.DeepSeq+import Control.Exception (evaluate)+import Control.Monad+import Control.Monad.IO.Class+import CriterionPlus+import qualified Data.Map as Map+import Data.Text (Text)+import qualified Data.Text as T+import GHC.Generics+import GHC.Stats+import System.Environment+import System.Mem+import System.Random.MWC+import System.Random.MWC.CondensedTable+import Text.Printf++import qualified Control.Concurrent.STM.Map as TTrie+import qualified STMContainers.Map as STMCont+import qualified Data.HashMap.Strict as HashMap++------------------------------------------------------------------------------++main :: IO ()+main = do+    (arg1:arg2:arg3:arg4:arg5:args) <- getArgs+    printf "threads = %s\n"         arg1+    printf "numTransactions = %s\n" arg2+    printf "sizes = %s\n"           arg3+    printf "numPrefill = %s\n"      arg4+    printf "ops = %s\n"             arg5+    let threads            = read arg1 :: [Int]+        numTransactions    = read arg2+        sizes              = mkTable $ read arg3+        numPrefill         = read arg4+        (ins,upd,look,del) = read arg5+        config = Config+            { operations = mkTable [ (Insert, ins + upd)+                                   , (Lookup, look)+                                   , (Delete, del)+                                   ]+            , keys = \op -> case op of+                Insert -> mkTable [(remember key, ins), (remember (reuse key), upd)]+                Lookup -> mkTable [(reuse key, 1)]+                Delete -> mkTable [(forget (reuse key), 1)]+            }++    (ks,txs) <- genTransactions numPrefill numTransactions sizes config+    withArgs args $ benchmark+                  $ standoff (T.pack arg5)+                  $ mapM_ (supergroup ks txs numTransactions)+                  $ threads++supergroup :: [Key] -> [Transaction] -> Int -> Int -> Standoff ()+supergroup ks txs numTransactions t =+    group (T.pack $ printf "%d/%d" t n) $ do+        runAll "unordered-containers" hashmapPrefill hashmapEval+        runAll "stm-containers"       stmcontPrefill stmcontEval+        runAll "ttrie"                ttriePrefill  ttrieEval+  where+    n = numTransactions `div` t+    ops = split n txs+    runAll name prefill eval = do+        runTime name prefill eval ks ops+        liftIO $ runRetries (printf "%d/%d/%s" t n name) prefill eval ks ops+        liftIO $ runAlloc prefill eval ks ops++split :: Int -> [a] -> [[a]]+split n [] = []+split n xs = let (ys,zs) = splitAt n xs in ys : split n zs++------------------------------------------------------------------------------++type EvalFunc c = Op -> Key -> c -> STM ()+type PrefillFunc c = [Key] -> IO c++runTime :: String -> PrefillFunc c -> EvalFunc c -> [Key] -> [[Transaction]] -> Standoff ()+runTime name prefill eval ks ops = subject (T.pack name) $ do+    pause+    c <- liftIO $ prefill ks+    continue+    liftIO $ run_ atomically ops eval c++runRetries :: String -> PrefillFunc c -> EvalFunc c -> [Key] -> [[Transaction]] -> IO ()+runRetries name prefill eval ks ops = do+    printf "commits: "+    c <- prefill ks+    let atomically' = trackSTMConf defaultTrackSTMConf+                        { tryThreshold = Nothing+                        , globalTheshold = Nothing+                        }+    run_ (atomically' name) ops eval c+    stats <- getSTMStats+    let Just (commits, retries) = Map.lookup name stats+    printf "%d\nretries: %d\n" commits retries++runAlloc :: PrefillFunc c -> EvalFunc c -> [Key] -> [[Transaction]] -> IO ()+runAlloc prefill eval ks ops = do+    printf "allocated bytes: "+    c <- prefill ks+    performGC+    before <- getGCStats+    run_ atomically ops eval c+    performGC+    after <- getGCStats+    let bytes = bytesAllocated after - bytesAllocated before+    printf "%d\n" bytes++run_ :: (STM () -> IO ()) -> [[Transaction]] -> EvalFunc c -> c -> IO ()+run_ atom ops f c = void $ mapConcurrently (mapM_ txEval) ops+  where txEval = atom . mapM_ (\(op,k) -> f op k c)++------------------------------------------------------------------------------++type Key = Text+type Transaction = [(Op,Key)]++data Op = Lookup | Insert | Delete+    deriving (Eq, Show, Generic)++instance NFData Op++key :: Generator IO k Key+key = do+    n <- liftGen $ genFromTable length+    T.pack <$> replicateM n (liftGen $ genFromTable alphabet)+  where+    length = mkTable $ zip [7..20] (repeat 1)+    alphabet = mkTable $ zip ['a'..'z'] (repeat 1)++genTransactions :: Int -> Int -> CondensedTableV Int -> Config IO Op Key -> IO ([Key],[Transaction])+genTransactions numPrefill numTransactions sizes config = do+    gen <- create+    runGenerator gen $ do+        liftIO $ printf "Generating %d random keys to prefill...\n" numPrefill+        ks <- replicateM numPrefill (remember key)+        liftIO $ printf "Generating %d random transactions...\n" numTransactions+        txs <- replicateM numTransactions $ do+            size <- liftGen $ genFromTable sizes+            generateOperations config size+        return (ks,txs)++------------------------------------------------------------------------------+-- Evaluation and Prefill functions++instance (NFData k, NFData v) => NFData (TTrie.Map k v)++ttriePrefill :: PrefillFunc (TTrie.Map Key ())+ttriePrefill ks = do+  m <- atomically $ TTrie.empty+  forM_ ks $ \k -> atomically $ TTrie.insert k () m+  evaluate (rnf m)+  return m++ttrieEval :: EvalFunc (TTrie.Map Key ())+ttrieEval Lookup k = void . TTrie.lookup k+ttrieEval Insert k = TTrie.insert k ()+ttrieEval Delete k = TTrie.delete k++instance (NFData k, NFData v) => NFData (STMCont.Map k v)++stmcontPrefill :: PrefillFunc (STMCont.Map Key ())+stmcontPrefill ks = do+  m <- atomically $ STMCont.new+  forM_ ks $ \k -> atomically $ STMCont.insert () k m+  evaluate (rnf m)+  return m++stmcontEval :: EvalFunc (STMCont.Map Key ())+stmcontEval Lookup k = void . STMCont.lookup k+stmcontEval Insert k = STMCont.insert () k+stmcontEval Delete k = STMCont.delete k++instance (NFData a) => NFData (TVar a)++hashmapPrefill :: PrefillFunc (TVar (HashMap.HashMap Key (TVar ())))+hashmapPrefill ks = do+  elems <- forM ks (\k -> newTVarIO () >>= \v -> return (k,v))+  m <- newTVarIO $ HashMap.fromList elems+  evaluate (rnf m)+  return m++hashmapEval :: EvalFunc (TVar (HashMap.HashMap Key (TVar ())))+hashmapEval Lookup k m = do+  v <- HashMap.lookup k <$> readTVar m+  case v of+    Just v -> void $ readTVar v+    Nothing -> return ()+hashmapEval Insert k m = do+  v <- newTVar ()+  modifyTVar' m (HashMap.insert k v)+hashmapEval Delete k m = modifyTVar' m (HashMap.delete k)
+ benchmarks/BenchGen.hs view
@@ -0,0 +1,72 @@+{-# LANGUAGE GeneralizedNewtypeDeriving #-}++module BenchGen where++import Control.Applicative+import Control.Monad+import Control.Monad.IO.Class+import Control.Monad.Primitive+import Control.Monad.Trans.Class+import Control.Monad.Trans.State.Strict+import Data.Bifunctor+import Data.Set (Set)+import qualified Data.Set as Set+import qualified Data.Vector as V+import System.Random.MWC+import System.Random.MWC.CondensedTable++------------------------------------------------------------------------------++newtype Generator m k a = Generator { unG :: StateT (Gen (PrimState m), Set k) m a }+  deriving (Functor, Applicative, Monad)++instance MonadIO m => MonadIO (Generator m k) where+    liftIO = Generator . liftIO++runGenerator :: PrimMonad m => Gen (PrimState m) -> Generator m k a -> m a+runGenerator gen (Generator m) = evalStateT m (gen, Set.empty)++liftGen :: PrimMonad m => (Gen (PrimState m) -> m a) -> Generator m k a+liftGen f = Generator $ lift . f =<< gets fst++reuse :: (PrimMonad m, Ord k) => Generator m k k -> Generator m k k+reuse keygen = Generator $ do+    (gen,ks) <- get+    if Set.null ks+        then unG keygen+        else do+            i <- lift $ uniformR (0, Set.size ks - 1) gen+            return $ Set.elemAt i ks++remember :: (PrimMonad m, Ord k) => Generator m k k -> Generator m k k+remember keygen = Generator $ do+    k <- unG keygen+    modify (second $ Set.insert k)+    return k++forget :: (PrimMonad m, Ord k) => Generator m k k -> Generator m k k+forget keygen = Generator $ do+    k <- unG keygen+    modify (second $ Set.delete k)+    return k++------------------------------------------------------------------------------++data Config m op k = Config { operations :: CondensedTableV op+                            , keys :: op -> CondensedTableV (Generator m k k)+                            }++generateOperations :: (PrimMonad m, Ord k)+                   => Config m op k+                   -> Int+                   -> Generator m k [(op,k)]+generateOperations config n =+    replicateM n $ do+        op <- liftGen $ genFromTable (operations config)+        k <- join $ liftGen $ genFromTable $ (keys config) op+        return (op,k)++------------------------------------------------------------------------------++mkTable :: [(a,Double)] -> CondensedTableV a+mkTable = tableFromWeights . V.fromList
+ benchmarks/run.sh view
@@ -0,0 +1,30 @@+#!/bin/bash++main() {+    THREADS="[1,2,4,6,8,10,12,14,16]"+    TX_SIZE="[(1,1),(2,1),(3,1),(4,1),(5,1)]"+    NUM_TX="200000"+    NUM_PREFILL="1000000"++    mkdir -p "results/1"+    bench $THREADS $NUM_TX "[(1,1)]" 0       "(1,0,0,0)" "results/1/insert"+    bench $THREADS $NUM_TX "[(1,1)]" $NUM_TX "(0,1,0,0)" "results/1/update"+    bench $THREADS $NUM_TX "[(1,1)]" $NUM_TX "(0,0,1,0)" "results/1/lookup"+    bench $THREADS $NUM_TX "[(1,1)]" $NUM_TX "(0,0,0,1)" "results/1/delete"++    mkdir -p "results/5"+    bench $THREADS $NUM_TX $TX_SIZE 0            "(70,10,10,10)" "results/update/5/insert"+    bench $THREADS $NUM_TX $TX_SIZE $NUM_PREFILL "(10,70,10,10)" "results/update/5/update"+    bench $THREADS $NUM_TX $TX_SIZE $NUM_PREFILL "(10,10,70,10)" "results/update/5/lookup"+    bench $THREADS $NUM_TX $TX_SIZE $NUM_PREFILL "(10,10,10,70)" "results/update/5/delete"    +    bench $THREADS $NUM_TX $TX_SIZE $NUM_PREFILL "(25,25,25,25)" "results/update/5/balanced-prefill"++#    sudo shutdown -h now+}++bench() {+    unbuffer cabal bench bench --benchmark-options="$1 $2 $3 $4 $5 +RTS -T" | tee "$6.txt"+#    curl -F $6.txt=@$6.txt https://XXXXXXXXXXXXXXX@neocities.org/api/upload+}++main "$@"
+ src/Control/Concurrent/STM/Map.hs view
@@ -0,0 +1,282 @@+{-# LANGUAGE PatternGuards #-}+{-# OPTIONS_GHC -funbox-strict-fields #-}++-----------------------------------------------------------------------+-- | A contention-free STM hash map.+-- \"Contention-free\" means that the map will never cause spurious conflicts.+-- A transaction operating on the map will only ever have to retry if+-- another transaction is operating on the same key at the same time.+-----------------------------------------------------------------------++module Control.Concurrent.STM.Map+    ( Map++      -- * Construction+    , empty++      -- * Modification+    , insert+    , delete+    , unsafeDelete++      -- * Query+    , lookup+    , phantomLookup+    ) where++import Control.Applicative ((<$>))+import Control.Concurrent.STM+import Control.Monad+import Data.Atomics+import Data.IORef+import Data.Maybe+import GHC.Conc.Sync (unsafeIOToSTM)+import Prelude hiding (lookup)++import Data.SparseArray++-----------------------------------------------------------------------++-- | A map from keys @k@ to values @v@.+newtype Map k v = Map (INode k v)++type INode k v = IORef (Node k v)++data Node k v = Array !(SparseArray (Branch k v))+              | List  ![Leaf k v]+              | Tomb  !(Leaf k v)++data Branch k v = I !(INode k v)+                | L !(Leaf k v)++data Leaf k v = Leaf !k !(TVar (Maybe v))++-----------------------------------------------------------------------++-- | /O(1)/. Construct an empty map.+empty :: STM (Map k v)+empty = unsafeIOToSTM $ Map <$> newIORef (Array emptyArray)+{-# INLINE empty #-}++-- | /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 -> STM ()+insert k v m = do var <- getTVar k m+                  writeTVar var (Just v)+{-# INLINABLE insert #-}++-- | /O(log n)/. Return the value associated with the given key, or 'Nothing'.+--+-- __Note__: This might increase the map's memory consumption+-- by putting the key into the map.+-- If that is not acceptable, use 'phantomLookup'.+lookup :: (Eq k, Hashable k) => k -> Map k v -> STM (Maybe v)+lookup k m = do var <- getTVar k m+                readTVar var+{-# INLINABLE lookup #-}++-- | /O(log n)/. Remove the value associated with a given key from the map,+-- if present.+--+-- __Note__: This does not actually remove the key from the map.+-- In fact, it might actually increase the map's memory consumption+-- by putting the key into the map.+-- To completely delete an entry, including its key, use 'unsafeDelete'.+delete :: (Eq k, Hashable k) => k -> Map k v -> STM ()+delete k m = do var <- getTVar k m+                writeTVar var Nothing+{-# INLINABLE delete #-}++-----------------------------------------------------------------------++getTVar :: (Eq k, Hashable k) => k -> Map k v -> STM (TVar (Maybe v))+getTVar k (Map root) = go root 0 undefined+  where+    h = hash k++    go inode level parent = do+        ticket <- unsafeIOToSTM $ readForCAS inode+        case peekTicket ticket of+            Array a -> case arrayLookup level h a of+                Just (I inode2) -> go inode2 (down level) inode+                Just (L leaf2@(Leaf k2 var))+                    | k == k2   -> return var+                    | otherwise -> cas inode ticket (growTrie level a (hash k2) leaf2)+                Nothing         -> cas inode ticket (insertLeaf level a)+            List xs -> case listLookup k xs of+                Just var        -> return var+                Nothing         -> cas inode ticket (return . List . (:xs))+            Tomb _  -> unsafeIOToSTM (clean parent (up level)) >> go root 0 undefined++    cas inode ticket f = do+        var <- newTVar Nothing+        node <- f (Leaf k var)+        (ok,_) <- unsafeIOToSTM $ casIORef inode ticket node+        if ok then return var+              else go root 0 undefined++    insertLeaf level a leaf = do+        let a' = arrayInsert level h (L leaf) a+        return (Array a')++    growTrie level a h2 leaf2 leaf1 = do+        inode2 <- unsafeIOToSTM $ combineLeaves (down level) h leaf1 h2 leaf2+        let a' = arrayUpdate level h (I inode2) a+        return (Array a')++    combineLeaves level h1 leaf1 h2 leaf2+        | level >= lastLevel = newIORef (List [leaf1, leaf2])+        | otherwise =+            case mkPair level h (L leaf1) h2 (L leaf2) of+                Just pair -> newIORef (Array pair)+                Nothing -> do+                    inode <- combineLeaves (down level) h1 leaf1 h2 leaf2+                    let a = mkSingleton level h (I inode)+                    newIORef (Array a)++{-# INLINE getTVar #-}+++-- | /O(log n)/. Return the value associated with the given key, or 'Nothing'.+--+-- In contrast to 'lookup', this will never increase the map's memory consumption.+-- However, it might allow /phantom reads/ to occur.+-- Consider the following situation:+--+-- > f = atomically $ do v1 <- phantomLookup k m+-- >                     v2 <- phantomLookup k m+-- >                     return (v1 == v2)+--+-- Under certain circumstances @f@ might actually return @False@, in particular+-- if the first @phantomLookup@ happens on an empty map+-- and some other transaction inserts a value for @k@ before the second call+-- to @phantomLookup@.+phantomLookup :: (Eq k, Hashable k) => k -> Map k v -> STM (Maybe v)+phantomLookup k (Map root) = go root 0 undefined+  where+    h = hash k+    go inode level parent = do+        node <- unsafeIOToSTM $ readIORef inode+        case node of+            Array a -> case arrayLookup level h a of+                Just (I inode2) -> go inode2 (down level) inode+                Just (L (Leaf k2 var))+                    | k == k2   -> readTVar var+                    | otherwise -> return Nothing+                Nothing         -> return Nothing+            List xs -> case listLookup k xs of+                Just var -> readTVar var+                Nothing  -> return Nothing+            Tomb _  -> unsafeIOToSTM (clean parent (up level)) >> go root 0 undefined++{-# INLINABLE phantomLookup #-}+++-- | /O(log n)/. This will completely remove a given key+-- and its associated value from the map, if present.+-- This is not an atomic operation, however. __Use with caution!__+unsafeDelete :: (Eq k, Hashable k) => k -> Map k v -> IO ()+unsafeDelete k m@(Map root) = do+    ok <- go root 0 undefined+    unless ok (unsafeDelete k m)+  where+    h = hash k+    go inode level parent = do+        ticket <- readForCAS inode+        case peekTicket ticket of+            Array a -> do+                ok <- case arrayLookup level h a of+                    Just (I inode2) -> go inode2 (down level) inode+                    Just (L (Leaf k2 _))+                        | k == k2   -> casArrayDelete inode ticket level a+                        | otherwise -> return True+                    Nothing         -> return True+                when ok (compressIfPossible level inode parent)+                return ok+            List xs -> casListDelete inode ticket xs+            Tomb _  -> clean parent (up level) >> return False++    compressIfPossible level inode parent = do+        n <- readIORef inode+        case n of+            Tomb _ -> cleanParent parent inode h (up level)+            _      -> return ()++    casArrayDelete inode ticket level a = do+        let a' = arrayDelete level h a+            n  = contract level (Array a')+        (ok,_) <- casIORef inode ticket n+        return ok++    casListDelete inode ticket xs = do+        let xs' = listDelete k xs+            n | [l] <- xs' = Tomb l+              | otherwise  = List xs'+        (ok,_) <- casIORef inode ticket n+        return ok++{-# INLINABLE unsafeDelete #-}++-----------------------------------------------------------------------++clean :: INode k v -> Level -> IO ()+clean inode level = do+    ticket <- readForCAS inode+    case peekTicket ticket of+        n@(Array _) -> do+            n' <- compress level n+            void $ casIORef inode ticket n'+        _ -> return ()+{-# INLINE clean #-}++cleanParent :: INode k v -> INode k v -> Hash -> Level -> IO ()+cleanParent parent inode h level = do+    ticket <- readForCAS parent+    case peekTicket ticket of+        n@(Array a) -> case arrayLookup level h a of+            Just (I inode2) | inode2 == inode -> do+                n2 <- readIORef inode+                case n2 of+                    Tomb _ -> do+                        n' <- compress level n+                        (ok,_) <- casIORef parent ticket n'+                        unless ok $ cleanParent parent inode h level+                    _ -> return ()+            _ -> return ()+        _ -> return ()++compress :: Level -> Node k v -> IO (Node k v)+compress level (Array a) = contract level . Array <$> arrayMapM resurrect a+compress _     n         = return n+{-# INLINE compress #-}++resurrect :: Branch k v -> IO (Branch k v)+resurrect b@(I inode) = do n <- readIORef inode+                           case n of+                               Tomb leaf -> return (L leaf)+                               _         -> return b+resurrect b           = return b+{-# INLINE resurrect #-}++contract :: Level -> Node k v -> Node k v+contract level (Array a) | level > 0+                         , Just (L leaf) <- arrayToMaybe a+                         = Tomb leaf+contract _     n         = n+{-# INLINE contract #-}++-----------------------------------------------------------------------++listLookup :: Eq k => k -> [Leaf k v] -> Maybe (TVar (Maybe v))+listLookup k1 = go+  where+    go []                             = Nothing+    go (Leaf k2 var : xs) | k1 == k2  = Just var+                          | otherwise = go xs++listDelete :: Eq k => k -> [Leaf k v] -> [Leaf k v]+listDelete k1 = go+  where+    go [] = []+    go (x@(Leaf k2 _):xs) | k1 == k2  = xs+                          | otherwise = x : go xs
+ src/Data/SparseArray.hs view
@@ -0,0 +1,192 @@+{-# OPTIONS_GHC -funbox-strict-fields #-}++module Data.SparseArray+    ( SparseArray+    , Hashable, Hash, hash+    , Level, down, up, lastLevel+    , emptyArray, mkSingleton, mkPair+    , arrayLookup, arrayInsert, arrayUpdate, arrayDelete+    , arrayMapM, arrayToMaybe+    ) where++import Control.Monad.ST+import Data.Bits+import Data.Hashable (Hashable)+import qualified Data.Hashable as H+import Data.Primitive.Array+import Data.Word+import Prelude hiding (lookup, mapM)++-----------------------------------------------------------------------++data SparseArray a = SparseArray !Bitmap !(Array a)++type Bitmap = Word+type Hash   = Word+type Level  = Int++-----------------------------------------------------------------------++emptyArray :: SparseArray a+emptyArray = SparseArray 0 arr+  where+    arr = runST $ do+        marr <- newArray 0 undefined+        unsafeFreezeArray marr++{-# INLINE emptyArray #-}++mkSingleton :: Level -> Hash -> a -> SparseArray a+mkSingleton level h a = SparseArray bmp arr+  where+    i   = index level h+    bmp = unsafeShiftL 1 i+    arr = runST $ do+        marr <- newArray 1 a+        unsafeFreezeArray marr++{-# INLINE mkSingleton #-}++mkPair :: Level -> Hash -> a -> Hash -> a -> Maybe (SparseArray a)+mkPair level h1 a1 h2 a2 =+    case compare i1 i2 of+        LT -> Just $ SparseArray bmp (pair a1 a2)+        GT -> Just $ SparseArray bmp (pair a2 a1)+        EQ -> Nothing+  where+    i1  = index level h1+    i2  = index level h2+    bmp = (unsafeShiftL 1 i1) .|. (unsafeShiftL 1 i2)+    pair x y = runST $ do+        marr <- newArray 2 undefined+        writeArray marr 0 x+        writeArray marr 1 y+        unsafeFreezeArray marr++{-# INLINE mkPair #-}++arrayLookup :: Level -> Hash -> SparseArray a -> Maybe a+arrayLookup level h (SparseArray bmp arr)+    | bmp .&. m == 0 = Nothing+    | otherwise      = Just (indexArray arr i)+  where+    m = mask level h+    i = sparseIndex bmp m++{-# INLINE arrayLookup #-}++arrayInsert :: Level -> Hash -> a -> SparseArray a -> SparseArray a+arrayInsert level h a (SparseArray bmp arr) = SparseArray bmp' arr'+  where+    n    = popCount bmp+    m    = mask level h+    i    = sparseIndex bmp m+    bmp' = bmp .|. m+    arr' = runST $ do+        marr <- newArray (n+1) undefined+        copyArray marr 0 arr 0 i+        writeArray marr i a+        copyArray marr (i+1) arr i (n-i)+        unsafeFreezeArray marr++{-# INLINE arrayInsert #-}++arrayUpdate :: Level -> Hash -> a -> SparseArray a -> SparseArray a+arrayUpdate level h a (SparseArray bmp arr) = SparseArray bmp arr'+  where+    n = popCount bmp+    m = mask level h+    i = sparseIndex bmp m+    arr' = runST $ do+        marr <- newArray n undefined+        copyArray marr 0 arr 0 n+        writeArray marr i a+        unsafeFreezeArray marr++{-# INLINE arrayUpdate #-}++arrayDelete :: Level -> Hash -> SparseArray a -> SparseArray a+arrayDelete level h (SparseArray bmp arr) = SparseArray bmp' arr'+  where+    n    = popCount bmp+    m    = mask level h+    i    = sparseIndex bmp m+    bmp' = bmp `xor` m+    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 arrayDelete #-}++arrayMapM :: (a -> IO a) -> SparseArray a -> IO (SparseArray a)+arrayMapM f = \(SparseArray bmp arr) -> do+    let n = popCount bmp+    marr <- newArray n undefined+    go n arr marr 0+    arr' <- unsafeFreezeArray marr+    return (SparseArray bmp arr')+  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 arrayMapM #-}++arrayToMaybe :: SparseArray a -> Maybe a+arrayToMaybe (SparseArray bmp arr) =+    case popCount bmp of+        1 -> Just $ indexArray arr 0+        _ -> Nothing++{-# INLINE arrayToMaybe #-}++-----------------------------------------------------------------------++hash :: Hashable a => a -> Hash+hash = fromIntegral . H.hash+{-# INLINE hash #-}++hashLength :: Int+hashLength = finiteBitSize (undefined :: Word)+{-# INLINE hashLength #-}++bitsPerSubkey :: Int+bitsPerSubkey = floor . logBase (2 :: Float) . fromIntegral $ hashLength+{-# INLINE bitsPerSubkey #-}++subkeyMask :: Bitmap+subkeyMask = 1 `unsafeShiftL` bitsPerSubkey - 1+{-# INLINE subkeyMask #-}++down :: Level -> Level+down = (+) bitsPerSubkey+{-# INLINE down #-}++up :: Level -> Level+up = subtract bitsPerSubkey+{-# INLINE up #-}++lastLevel :: Level+lastLevel = hashLength+{-# INLINE lastLevel #-}++index :: Level -> Hash -> Int+index level h = fromIntegral $ (h `unsafeShiftR` level) .&. subkeyMask+{-# INLINE index #-}++-- when or-ed with a bitmap, determines if the hash is present+-- in the array at the given level of the trie+mask :: Level -> Hash -> Bitmap+mask level h = 1 `unsafeShiftL` index level h+{-# INLINE mask #-}++-- position in the array+sparseIndex :: Bitmap -> Bitmap -> Int+sparseIndex bmp m = popCount ((m - 1) .&. bmp)+{-# INLINE sparseIndex #-}+
+ ttrie.cabal view
@@ -0,0 +1,51 @@+name:                ttrie+version:             0.1+synopsis:            Contention-free STM hash map+description:+  A contention-free STM hash map.+  \"Contention-free\" means that the map will never cause spurious conflicts.+  A transaction operating on the map will only ever have to retry if+  another transaction is operating on the same key at the same time.+  .+  This is an implementation of the /transactional trie/,+  which is basically a /lock-free concurrent hash trie/ lifted into STM.+  For a detailed discussion, including an evaluation of its performance,+  see Chapter 4 of <https://github.com/mcschroeder/thesis my master's thesis>.+homepage:            http://github.com/mcschroeder/ttrie+bug-reports:         http://github.com/mcschroeder/ttrie/issues+license:             MIT+license-file:        LICENSE+author:              Michael Schröder+maintainer:          mc.schroeder@gmail.com+copyright:           (c) 2014-2015 Michael Schröder+category:            Concurrency+build-type:          Simple+extra-source-files:  README.md, benchmarks/run.sh+cabal-version:       >=1.10++source-repository head+  type: git+  location: https://github.com/mcschroeder/ttrie.git++library+  hs-source-dirs:      src+  exposed-modules:     Control.Concurrent.STM.Map+  other-modules:       Data.SparseArray+  default-language:    Haskell2010+  ghc-options:         -Wall+  build-depends:       base >=4.7 && <4.8+                     , atomic-primops >=0.6+                     , hashable >=1.2+                     , primitive >=0.5+                     , stm >=2++benchmark bench+  hs-source-dirs:      benchmarks+  main-is:             Bench.hs+  other-modules:       BenchGen+  type:                exitcode-stdio-1.0+  default-language:    Haskell2010+  ghc-options:         -O2 -threaded -with-rtsopts=-N+  build-depends:+    base, async, bifunctors, containers, criterion-plus, deepseq, mwc-random, primitive, stm, stm-containers, stm-stats, text, transformers, ttrie, unordered-containers, vector+