blocking-transactions 0.1.0.4 → 0.1.0.5
raw patch · 2 files changed
+1/−158 lines, 2 filesdep −arraydep −randomdep −stmPVP ok
version bump matches the API change (PVP)
Dependencies removed: array, random, stm
API changes (from Hackage documentation)
Files
- Examples/RandomAccounts.hs +0/−146
- blocking-transactions.cabal +1/−12
− Examples/RandomAccounts.hs
@@ -1,146 +0,0 @@-{-# LANGUAGE Arrows #-}-module Main- (main)- where--import System.IO-import Data.Array-import Control.Concurrent-import Control.Concurrent.STM-import Control.Monad-import Control.Applicative-import Control.Arrow-import qualified BlockingTransactions.BlockingTransactions as BT-import System.Environment-import System.Random---- A benchmark that creates a number (param_accounts) of bank accounts--- and then performs a large number (param_transactions) of transactions on a--- large number (param_threads) of threads, running in parallel. Transactions--- always move one dollar from a larger account to a smaller account.---- This benchmark is written (hopefull identically) using STM (conventional--- software transactional memory), BTM (blocking transactions monad),--- and BTA (blocking transactions arrow).---- Only the STM implementation is documented, since all three implementations--- should have the same form.--param_threads :: Int-param_threads = 100--param_accounts :: Int-param_accounts = 100--param_transactions :: Int-param_transactions = 1000--main :: IO ()-main =- do args <- getArgs- case args of- ["stm"] -> benchmarkSTM- ["btm"] -> benchmarkBTM- ["bta"] -> benchmarkBTA--benchmarkSTM :: IO ()-benchmarkSTM =- do -- a flag indicating when we can start- start <- newTVarIO False- -- variable indicating when we are finished- threads_remaining <- newTVarIO param_threads- -- populate the accounts- accounts <- liftM (listArray (1,param_accounts)) $- forM [1..param_accounts] $ \_ -> (newTVarIO =<<) $- getStdRandom $ randomR (1,param_transactions)- -- launch worker threads- forM_ [1..param_threads] $ \_ -> (>> return ()) $ forkIO $- do -- wait until we can start- atomically $- do can_start <- readTVar start- when (not can_start) retry- -- perform 1-dollar transactions between random accounts- forM_ [1..param_transactions] $ \_ ->- do ac1 <- getStdRandom $ randomR (1,param_accounts)- ac2 <- getStdRandom $ randomR (1,param_accounts)- atomically $- do v1 <- readTVar (accounts ! ac1)- v2 <- readTVar (accounts ! ac2)- when (v1 > v2) $- do writeTVar (accounts ! ac1) $ pred v1- writeTVar (accounts ! ac2) $ succ v2- -- indicate that we are finished- atomically $ writeTVar threads_remaining . pred =<<- readTVar threads_remaining- return ()- -- indicate that we can start (all threads are live)- atomically $ writeTVar start True- -- wait until we are finished- atomically $- do x <- readTVar threads_remaining- when (x /= 0) retry- -- print the answer- print =<< mapM (atomically . readTVar) (elems accounts)- return ()--benchmarkBTM :: IO ()-benchmarkBTM =- do start <- BT.newBVar False- threads_remaining <- BT.newBVar param_threads- accounts <- liftM (listArray (1,param_accounts)) $- forM [1..param_accounts] $ \_ -> (BT.newBVar =<<) $- getStdRandom $ randomR (1,param_transactions)- forM_ [1..param_threads] $ \_ -> (>> return ()) $ forkIO $- do BT.runBTM $- do can_start <- BT.readBVar start- BT.unless can_start BT.retry- forM_ [1..param_transactions] $ \_ ->- do ac1 <- getStdRandom $ randomR (1,param_accounts)- ac2 <- getStdRandom $ randomR (1,param_accounts)- BT.runBTM $- do v1 <- BT.readBVar (accounts ! ac1)- v2 <- BT.readBVar (accounts ! ac2)- BT.when ((>) <$> v1 <*> v2) $- do BT.writeBVar (accounts ! ac1) $ fmap pred v1- BT.writeBVar (accounts ! ac2) $ fmap succ v2- BT.runBTM $ BT.writeBVar threads_remaining . fmap pred =<<- BT.readBVar threads_remaining- return ()- BT.pokeBVar start True- BT.runBTM $- do x <- BT.readBVar threads_remaining- BT.when (fmap (/= 0) x) BT.retry- print =<< mapM (\v -> BT.runBTM $ BT.readBVar v) (elems accounts)- return ()--benchmarkBTA :: IO ()-benchmarkBTA =- do start <- BT.newBVar False- threads_remaining <- BT.newBVar param_threads- accounts <- liftM (listArray (1,param_accounts)) $- forM [1..param_accounts] $ \_ -> (BT.newBVar =<<) $- getStdRandom $ randomR (1,param_transactions)- forM_ [1..param_threads] $ \_ -> (>> return ()) $ forkIO $- do flip BT.runBTA () $ proc () ->- do can_start <- BT.fetchBVar start -< ()- BT.retryUnless -< can_start- forM_ [1..param_transactions] $ \_ ->- do ac1 <- getStdRandom $ randomR (1,param_accounts)- ac2 <- getStdRandom $ randomR (1,param_accounts)- flip BT.runBTA () $ proc () ->- do v1 <- BT.fetchBVar (accounts ! ac1) -< ()- v2 <- BT.fetchBVar (accounts ! ac2) -< ()- case () of- () | v1 > v2 ->- do BT.storeBVar (accounts ! ac1) -< pred v1- BT.storeBVar (accounts ! ac2) -< succ v2- () | otherwise -> returnA -< ()- flip BT.runBTA () $ BT.storeBVar threads_remaining <<< arr pred- <<< BT.fetchBVar threads_remaining- return ()- BT.pokeBVar start True- flip BT.runBTA () $- BT.retryWhen <<< arr (/= 0) <<< BT.fetchBVar threads_remaining- print =<< mapM (flip BT.runBTA () . BT.fetchBVar) (elems accounts)- return ()-
blocking-transactions.cabal view
@@ -3,7 +3,7 @@ -- The package version. See the Haskell package versioning policy -- (http://www.haskell.org/haskellwiki/Package_versioning_policy) for -- standards guiding when and how versions should be incremented.-Version: 0.1.0.4+Version: 0.1.0.5 Synopsis: Composable, blocking transactions. @@ -24,20 +24,9 @@ Build-type: Simple Cabal-version: >=1.2 -Flag Tests- Default: False- Library Exposed-modules: BlockingTransactions.BlockingTransactions Build-depends: base >=4&&<5, containers, parallel ghc-options: -O2--Executable _RandomAccounts- main-is: Examples/RandomAccounts.hs- Build-depends: base >=4&&<5, random, array, stm- ghc-options: -threaded -O2- ghc-prof-options: -prof -auto-all- if( !flag(Tests) )- buildable: False