git.iko.soy/distributed-process
on master help sign in
Add a simple 'process ring' benchmark
02211baTim Watson
benchmarks/ProcessRing.hsnew file+104
compare with master
unifiedsplit
@@ -0,0 +1,104 @@
1+{- ProcessRing benchmarks.
2+
3+To run the benchmarks, select a value for the ring size (sz) and
4+the number of times to send a message around the ring
5+-}
6+import Control.Monad
7+import Control.Distributed.Process hiding (catch)
8+import Control.Distributed.Process.Node
9+import Network.Transport.TCP (createTransport, defaultTCPParameters)
10+import System.Environment
11+import System.Console.GetOpt
12+
13+data Options = Options
14+ { optRingSize :: Int
15+ , optIterations :: Int
16+ , optForward :: Bool
17+ , optParallel :: Bool
18+ } deriving Show
19+
20+initialProcess :: Options -> Process ()
21+initialProcess op =
22+ let ringSz = optRingSize op
23+ msgCnt = optIterations op
24+ fwd = optForward op
25+ msg = ("foobar", "baz")
26+ in do
27+ self <- getSelfPid
28+ ring <- makeRing fwd ringSz self
29+ forM_ [1..msgCnt] (\_ -> send ring msg)
30+ collect msgCnt
31+ where relay' pid = do
32+ msg <- expect :: Process (String, String)
33+ send pid msg
34+ relay' pid
35+
36+ forward' pid =
37+ receiveWait [ matchAny (\m -> forward m pid) ] >> forward' pid
38+
39+ makeRing :: Bool -> Int -> ProcessId -> Process ProcessId
40+ makeRing !f !n !pid
41+ | n == 0 = go f pid
42+ | otherwise = go f pid >>= makeRing f (n - 1)
43+
44+ go :: Bool -> ProcessId -> Process ProcessId
45+ go False next = spawnLocal $ relay' next
46+ go True next = spawnLocal $ forward' next
47+
48+ collect :: Int -> Process ()
49+ collect !n
50+ | n == 0 = return ()
51+ | otherwise = do
52+ receiveWait [
53+ matchIf (\(a, b) -> a == "foobar" && b == "baz")
54+ (\_ -> return ())
55+ , matchAny (\_ -> error "unexpected input!")
56+ ]
57+ collect (n - 1)
58+
59+defaultOptions :: Options
60+defaultOptions = Options
61+ { optRingSize = 10
62+ , optIterations = 100
63+ , optForward = False
64+ , optParallel = False
65+ }
66+
67+options :: [OptDescr (Options -> Options)]
68+options =
69+ [ Option ['s'] ["ring-size"] (OptArg optSz "SIZE") "# of processes in ring"
70+ , Option ['i'] ["iterations"] (OptArg optMsgCnt "ITER") "# of times to send"
71+ , Option ['f'] ["forward"]
72+ (NoArg (\opts -> opts { optForward = True }))
73+ "use `forward' instead of send - default = False"
74+ , Option ['p'] ["parallel"]
75+ (NoArg (\opts -> opts { optForward = True }))
76+ "send in parallel and consume sequentially - default = False"
77+ ]
78+
79+optMsgCnt :: Maybe String -> Options -> Options
80+optMsgCnt Nothing opts = opts
81+optMsgCnt (Just c) opts = opts { optIterations = ((read c) :: Int) }
82+
83+optSz :: Maybe String -> Options -> Options
84+optSz Nothing opts = opts
85+optSz (Just s) opts = opts { optRingSize = ((read s) :: Int) }
86+
87+parseArgv :: [String] -> IO (Options, [String])
88+parseArgv argv = do
89+ pn <- getProgName
90+ case getOpt Permute options argv of
91+ (o,n,[] ) -> return (foldl (flip id) defaultOptions o, n)
92+ (_,_,errs) -> ioError (userError (concat errs ++ usageInfo (header pn) options))
93+ where header pn' = "Usage: " ++ pn' ++ " [OPTION...]"
94+
95+main :: IO ()
96+main = do
97+ argv <- getArgs
98+ (opt, _) <- parseArgv argv
99+ putStrLn $ "options: " ++ (show opt)
100+ Right transport <- createTransport "127.0.0.1" "8090" defaultTCPParameters
101+ node <- newLocalNode transport initRemoteTable
102+ catch (runProcess node $ initialProcess opt)
103+ (\e -> putStrLn $ "ERROR: " ++ (show e))
104+
distributed-process.cabal+23
@@ -37,6 +37,10 @@ flag benchmarks
37 description: Build benchmarks
37 description: Build benchmarks
38 default: False
38 default: False
39
39
40+flag prof
41+ description: Compiling with profiling enabled
42+ default: False
43+
40Library
44Library
41 Build-Depends: base >= 4.4 && < 5,
45 Build-Depends: base >= 4.4 && < 5,
42 binary >= 0.5 && < 0.7,
46 binary >= 0.5 && < 0.7,
@@ -201,3 +205,22 @@ Executable distributed-process-spawns
201 Main-Is: benchmarks/Spawns.hs
205 Main-Is: benchmarks/Spawns.hs
202 ghc-options: -Wall
206 ghc-options: -Wall
203 Extensions: BangPatterns
207 Extensions: BangPatterns
208+
209+Executable distributed-process-ring
210+ if flag(benchmarks)
211+ Build-Depends: base >= 4.4 && < 5,
212+ distributed-process,
213+ network-transport-tcp >= 0.3 && < 0.4,
214+ bytestring >= 0.9 && < 0.11,
215+ binary >= 0.5 && < 0.7
216+ else
217+ buildable: False
218+ Main-Is: benchmarks/ProcessRing.hs
219+ if flag(prof)
220+ ghc-options: -Wall -threaded -fprof-auto -fno-prof-count-entries
221+ else
222+ ghc-options: -Wall -threaded -O2 -H256m -rtsopts -with-rtsopts=-N -fno-warn-unused-do-bind
223+ Extensions: BangPatterns,
224+ ScopedTypeVariables
225+
226+