stm-containers 0.1.1 → 0.1.2
raw patch · 4 files changed
+280/−29 lines, 4 filesdep ~basedep ~containersdep ~free
Dependency ranges changed: base, containers, free
Files
- executables/ConcurrentInsertionBench.hs +33/−25
- executables/ConcurrentTransactionsBench.hs +208/−0
- library/STMContainers/HAMT.hs +1/−1
- stm-containers.cabal +38/−3
executables/ConcurrentInsertionBench.hs view
@@ -8,31 +8,33 @@ import qualified Control.Concurrent.Async as Async import qualified System.Random.MWC.Monad as MWC import qualified Focus+import qualified Data.Char as Char+import qualified Data.Text as Text type UCMap k v = TVar (UC.HashMap k (TVar v)) --- * Actions +-- * Transactions ------------------------- -data ActionF k v n where- Insert :: k -> v -> n -> ActionF k v n+data TransactionF k v n where+ Insert :: v -> k -> n -> TransactionF k v n deriving (Functor) -type Action k v = Free (ActionF k v)+type Transaction k v = Free (TransactionF k v) -- * Interpreters ------------------------- type Interpreter m = - forall k v r. (Hashable k, Eq k) => m k v -> Action k v r -> STM r+ forall k v r. (Hashable k, Eq k) => m k v -> Transaction k v r -> STM r ucInterpreter :: Interpreter UCMap ucInterpreter m = iterM $ \case- Insert k v n -> do+ Insert v k n -> do mv <- readTVar m vt <- newTVar v writeTVar m $! UC.insert k vt mv@@ -41,33 +43,33 @@ specializedSCInterpreter :: Interpreter SC.Map specializedSCInterpreter m = iterM $ \case- Insert k v n -> SC.insert v k m >> n+ Insert v k n -> SC.insert v k m >> n focusSCInterpreter :: Interpreter SC.Map focusSCInterpreter m = iterM $ \case- Insert k v n -> SC.focus (Focus.insertM v) k m >> n+ Insert v k n -> SC.focus (Focus.insertM v) k m >> n -- * Session and runners ------------------------- -- | A list of transactions per thread.-type Session k v = [[Action k v ()]]+type Session k v = [[Transaction k v ()]] type SessionRunner = forall k v. (Hashable k, Eq k) => Session k v -> IO () scSessionRunner :: Interpreter SC.Map -> SessionRunner-scSessionRunner interpreter threadActions = do+scSessionRunner interpreter threadTransactions = do m <- atomically $ SC.new- void $ flip Async.mapConcurrently threadActions $ \actions -> do+ void $ flip Async.mapConcurrently threadTransactions $ \actions -> do forM_ actions $ atomically . interpreter m ucSessionRunner :: SessionRunner-ucSessionRunner threadActions = do+ucSessionRunner threadTransactions = do m <- newTVarIO UC.empty- void $ flip Async.mapConcurrently threadActions $ \actions -> do+ void $ flip Async.mapConcurrently threadTransactions $ \actions -> do forM_ actions $ atomically . ucInterpreter m @@ -76,13 +78,19 @@ type Generator a = MWC.Rand IO a -transactionGenerator :: Generator (Action Float Int ())-transactionGenerator =- Free <$> (Insert <$> k <*> v <*> n)+transactionGenerator :: Generator (Transaction Text.Text () ())+transactionGenerator = do+ k <- keyGenerator+ return $ Free $ Insert () k (Pure ())++keyGenerator :: Generator Text.Text+keyGenerator = do+ l <- length+ s <- replicateM l char+ return $! Text.pack s where- k = MWC.uniform- v = MWC.uniform- n = MWC.uniform >>= bool (return (Pure ())) transactionGenerator+ length = MWC.uniformR (7, 20)+ char = Char.chr <$> MWC.uniformR (Char.ord 'a', Char.ord 'z') -- * Utils@@ -99,11 +107,11 @@ ------------------------- main = do- allActions <- MWC.runWithCreate $ replicateM actionsNum transactionGenerator+ allTransactions <- MWC.runWithCreate $ replicateM actionsNum transactionGenerator defaultMain $! flip map threadsNums $! \threadsNum -> let sliceSize = actionsNum `div` threadsNum- threadActions = slices sliceSize allActions+ threadTransactions = slices sliceSize allTransactions in bgroup (shows threadsNum . showString "/" . shows sliceSize $ "")@@ -111,13 +119,13 @@ bgroup "STM Containers" [ bench "Focus-based" $ - scSessionRunner focusSCInterpreter threadActions,+ scSessionRunner focusSCInterpreter threadTransactions, bench "Specialized" $ - scSessionRunner specializedSCInterpreter threadActions+ scSessionRunner specializedSCInterpreter threadTransactions ], bench "Unordered Containers" $- ucSessionRunner threadActions+ ucSessionRunner threadTransactions ] where actionsNum = 100000- threadsNums = [1, 2, 4, 8, 16, 32]+ threadsNums = [1, 2, 4, 6, 8, 12, 16, 32]
+ executables/ConcurrentTransactionsBench.hs view
@@ -0,0 +1,208 @@++import STMContainers.Prelude+import STMContainers.Transformers+import Criterion.Main+import Control.Monad.Free+import Control.Monad.Free.TH+import qualified Data.HashMap.Strict as UC+import qualified STMContainers.Map as SC+import qualified Control.Concurrent.Async as Async+import qualified System.Random.MWC.Monad as MWC+import qualified Focus+import qualified Data.Char as Char+import qualified Data.Text as Text+import qualified Data.Set as Set+++-- * Custom data structures+-------------------------++type UCMap k v = TVar (UC.HashMap k (TVar v))+++-- * Transactions +-------------------------++data TransactionF k v n where+ Insert :: v -> k -> n -> TransactionF k v n+ Delete :: k -> n -> TransactionF k v n+ Lookup :: k -> n -> TransactionF k v n+ deriving (Functor, Show)++type Transaction k v = Free (TransactionF k v)++-- * Interpreters+-------------------------++type Interpreter m = + forall k v r. (Hashable k, Eq k) => m k v -> Transaction k v r -> STM r++ucInterpreter :: Interpreter UCMap+ucInterpreter m = + iterM $ \case+ Insert v k c -> + do+ mv <- readTVar m+ vt <- newTVar v+ writeTVar m $! UC.insert k vt mv+ c+ Delete k c -> + readTVar m >>= writeTVar m . UC.delete k >> c+ Lookup k c -> + readTVar m >>= mapM readTVar . UC.lookup k >> c++specializedSCInterpreter :: Interpreter SC.Map+specializedSCInterpreter m =+ iterM $ \case+ Insert v k c -> SC.insert v k m >> c+ Delete k c -> SC.delete k m >> c+ Lookup k c -> SC.lookup k m >> c++focusSCInterpreter :: Interpreter SC.Map+focusSCInterpreter m =+ iterM $ \case+ Insert v k c -> SC.focus (Focus.insertM v) k m >> c+ Delete k c -> SC.focus Focus.deleteM k m >> c+ Lookup k c -> SC.focus Focus.lookupM k m >> c+++-- * Session and runners+-------------------------++-- | A list of transactions per thread.+type Session k v = [[Transaction k v ()]]++type SessionRunner = + forall k v. (Hashable k, Eq k) => Session k v -> IO ()++scSessionRunner :: Interpreter SC.Map -> SessionRunner+scSessionRunner interpreter threadTransactions = do+ m <- atomically $ SC.new+ void $ flip Async.mapConcurrently threadTransactions $ \actions -> do+ forM_ actions $ atomically . interpreter m++ucSessionRunner :: SessionRunner+ucSessionRunner threadTransactions = do+ m <- newTVarIO UC.empty+ void $ flip Async.mapConcurrently threadTransactions $ \actions -> do+ forM_ actions $ atomically . ucInterpreter m+++-- * Generators+-------------------------++type Generator a = MWC.Rand IO a++-- |+-- Generate a list of transactions with a context of shared keys.+transactionsGroupGenerator :: Int -> Generator [Transaction Text.Text () ()]+transactionsGroupGenerator n =+ (flip evalStateT) Set.empty $ replicateM n transaction+ where+ transaction = do+ s <- size+ fmap sequence_ $ replicateM s action+ where+ size = + lift $ join $ weightedElementGenerator $+ [+ (1 , MWC.uniformR (8, 14)),+ (5 , MWC.uniformR (2, 7)),+ (10 , return 1)+ ]+ action =+ join $ lift $ weightedElementGenerator $+ [+ (1, delete),+ (5, insert),+ (20, lookup)+ ]+ where+ insert = do+ k <- key 10 1+ modify $ Set.insert k+ return $ liftF (Insert () k ())+ delete = do+ k <- key 1 10+ modify $ Set.delete k+ return $ liftF (Delete k ())+ lookup = do+ k <- key 1 5+ return $ liftF (Lookup k ())+ key unknownWeight knownWeight =+ join $ lift $ weightedElementGenerator $ + [+ (unknownWeight, unknown), + (knownWeight, known)+ ]+ where+ unknown = lift $ keyGenerator+ known = do+ allKeys <- get+ maybe unknown return =<< lift (setElementGenerator allKeys)+ +keyGenerator :: Generator Text.Text+keyGenerator = do+ l <- length+ s <- replicateM l char+ return $! Text.pack s+ where+ length = MWC.uniformR (7, 20)+ char = Char.chr <$> MWC.uniformR (Char.ord 'a', Char.ord 'z')++setElementGenerator :: Set.Set a -> Generator (Maybe a)+setElementGenerator set = do+ case Set.size set of+ 0 -> return Nothing+ size -> Just . (flip Set.elemAt) set <$> MWC.uniformR (0, pred size)++elementGenerator :: [a] -> Generator a+elementGenerator = \case+ [] -> $bug "Empty list"+ l -> (!!) l <$> MWC.uniformR (0, (pred . length) l)++weightedElementGenerator :: [(Int, a)] -> Generator a+weightedElementGenerator = \case+ [] -> + $bug "Empty list"+ l -> + (flip pick) l <$> MWC.uniformR (1, total)+ where+ total = (sum . map fst) l+ pick n = \case+ (n', e) : t ->+ if n' >= n+ then e + else pick (n - n') t++-- * Utils+-------------------------++slices :: Int -> [a] -> [[a]]+slices size l =+ case splitAt size l of+ ([], _) -> []+ (a, b) -> a : slices size b+++-- * Main+-------------------------++main = do+ -- Pregenerate the transactions:+ transactionsGroups <- + MWC.runWithCreate $ replicateM (maximum threadsNums) $+ transactionsGroupGenerator (actionsNum `div` (maximum threadsNums))++ -- Run the benchmark:+ defaultMain $! flip map threadsNums $ \threadsNum -> + let+ session = + map concat $! + slices (length transactionsGroups `div` threadsNum) transactionsGroups+ in+ bench (shows threadsNum . showString "/" . shows (actionsNum `div` threadsNum) $ "") $+ scSessionRunner specializedSCInterpreter session+ where+ threadsNums = [1, 2, 4, 6, 8, 12, 16, 32, 64, 128]+ actionsNum = 200000
library/STMContainers/HAMT.hs view
@@ -27,4 +27,4 @@ {-# INLINE null #-} null :: HAMT e -> STM Bool-null v = $notImplemented+null = Nodes.null
stm-containers.cabal view
@@ -1,7 +1,7 @@ name: stm-containers version:- 0.1.1+ 0.1.2 synopsis: Containers for STM description:@@ -171,15 +171,50 @@ criterion == 0.8.*, mwc-random == 0.13.*, mwc-random-monad == 0.7.*,- focus > 0.1.0 && < 0.2, -- data:- stm-containers,+ text < 1.2,+ focus > 0.1.0 && < 0.2, unordered-containers == 0.2.*,+ hashable < 1.3,+ stm-containers, -- debugging: loch-th == 0.2.*, placeholders == 0.1.*, -- general: free >= 4.5 && < 4.10, async == 2.0.*,+ base >= 4.5 && < 5+++benchmark concurrent-transactions-bench+ type: + exitcode-stdio-1.0+ hs-source-dirs:+ executables+ main-is:+ ConcurrentTransactionsBench.hs+ ghc-options:+ -O2 -threaded "-with-rtsopts=-N"+ default-extensions:+ Arrows, BangPatterns, ConstraintKinds, DataKinds, DefaultSignatures, DeriveDataTypeable, DeriveFunctor, DeriveGeneric, EmptyDataDecls, FlexibleContexts, FlexibleInstances, FunctionalDependencies, GADTs, GeneralizedNewtypeDeriving, ImpredicativeTypes, LambdaCase, LiberalTypeSynonyms, MagicHash, MultiParamTypeClasses, MultiWayIf, NoImplicitPrelude, NoMonomorphismRestriction, OverloadedStrings, PatternGuards, ParallelListComp, QuasiQuotes, RankNTypes, RecordWildCards, ScopedTypeVariables, StandaloneDeriving, TemplateHaskell, TupleSections, TypeFamilies, TypeOperators, UnboxedTuples+ default-language:+ Haskell2010+ build-depends:+ criterion == 0.8.*,+ mwc-random == 0.13.*,+ mwc-random-monad == 0.7.*,+ -- data:+ containers >= 0.5.2 && < 0.6,+ text < 1.2,+ focus > 0.1.0 && < 0.2,+ unordered-containers == 0.2.*, hashable < 1.3,+ stm-containers,+ -- debugging:+ loch-th == 0.2.*,+ placeholders == 0.1.*,+ -- general:+ mtl == 2.*,+ free >= 4.5 && < 4.10,+ async == 2.0.*, base >= 4.5 && < 5