Skip to content

Commit c77c172

Browse files
author
Tim Watson
committed
Merge branch 'ring-benchmarks' into development
2 parents 06b3290 + f2ec0d8 commit c77c172

File tree

3 files changed

+189
-0
lines changed

3 files changed

+189
-0
lines changed

‎benchmarks/ProcessRing.hs

Lines changed: 104 additions & 0 deletions
Original file line numberDiff line numberDiff line change
@@ -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+

‎benchmarks/erlang/ring.erl

Lines changed: 62 additions & 0 deletions
Original file line numberDiff line numberDiff line change
@@ -0,0 +1,62 @@
1+
%% can be run via escript if desired...
2+
-module(ring).
3+
4+
-export([main/1]).
5+
6+
-record(opts, {
7+
ring_size = 1 :: non_neg_integer(),
8+
iterations = 1 :: non_neg_integer()
9+
}).
10+
11+
main(Argv) when is_list(Argv) ->
12+
Opts = parse_args(Argv),
13+
{Time, ok} = timer:tc(fun() -> run(Opts) end),
14+
io:format("elapsed (wallclock) time: ~pms~n", [Time / 1000]).
15+
16+
run(#opts{ ring_size=RingSize, iterations=SendCount }) ->
17+
Self = self(),
18+
Msg = {"foobar", "baz"},
19+
Pid = make_ring(RingSize, Self),
20+
[Pid ! Msg || _ <- lists:seq(1, SendCount)],
21+
collect(SendCount).
22+
23+
collect(0) ->
24+
ok;
25+
collect(N) ->
26+
receive
27+
{"foobar", "baz"} -> collect(N - 1);
28+
Other -> exit({unexpected_message, Other})
29+
end.
30+
31+
-spec(make_ring(integer(), pid()) -> pid()).
32+
make_ring(0, NextPid) ->
33+
go(NextPid);
34+
make_ring(NumProcs, NextPid) ->
35+
make_ring(NumProcs - 1, go(NextPid)).
36+
37+
-spec(go(pid()) -> pid()).
38+
go(NextPid) ->
39+
spawn(fun() -> relay(NextPid) end).
40+
41+
-spec(relay(pid()) -> no_return()).
42+
relay(NextPid) ->
43+
receive
44+
{_, _}=Msg -> NextPid ! Msg, relay(NextPid)
45+
end.
46+
47+
-spec(parse_args([string()]) -> #opts{}).
48+
parse_args(Argv) ->
49+
lists:foldl(fun parse_args/2, #opts{}, Argv).
50+
51+
parse_args(("-r" ++ Val), Opts) ->
52+
Sz = check_positive(ring_size, list_to_integer(Val)),
53+
Opts#opts{ ring_size = Sz };
54+
parse_args(("-i" ++ Val), Opts) ->
55+
Iter = check_positive(iterations, list_to_integer(Val)),
56+
Opts#opts{ iterations = Iter }.
57+
58+
check_positive(K, N) when N < 1 ->
59+
io:format("~p must be >= 1~n", [K]),
60+
error({K, N});
61+
check_positive(_, N) ->
62+
N.

‎distributed-process.cabal

Lines changed: 23 additions & 0 deletions
Original file line numberDiff line numberDiff line change
@@ -37,6 +37,10 @@ flag benchmarks
3737
description: Build benchmarks
3838
default: False
3939

40+
flag prof
41+
description: Compiling with profiling enabled
42+
default: False
43+
4044
Library
4145
Build-Depends: base >= 4.4 && < 5,
4246
binary >= 0.5 && < 0.7,
@@ -201,3 +205,22 @@ Executable distributed-process-spawns
201205
Main-Is: benchmarks/Spawns.hs
202206
ghc-options: -Wall
203207
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+

0 commit comments

Comments
 (0)