git.iko.soy/distributed-process
on pr-327 help sign in
distributed-process/benchmarks/Throughput.hs
74 lines 2.0 kB history raw
1{-# LANGUAGE BangPatterns #-}
2{-# LANGUAGE DeriveDataTypeable #-}
4import System.Environment
5import Control.Monad
6import Control.Applicative
7import Control.Distributed.Process
8import Control.Distributed.Process.Node
9import Network.Transport.TCP (createTransport, defaultTCPParameters, defaultTCPAddr)
10import Data.Binary
11import qualified Data.ByteString.Lazy as BSL
12import Data.Typeable
14data SizedList a = SizedList { size :: Int , elems :: [a] }
15 deriving (Typeable)
17instance Binary a => Binary (SizedList a) where
18 put (SizedList sz xs) = put sz >> mapM_ put xs
19 get = do
20 sz <- get
21 xs <- getMany sz
22 return (SizedList sz xs)
24-- Copied from Data.Binary
25getMany :: Binary a => Int -> Get [a]
26getMany = go []
27 where
28 go xs 0 = return $! reverse xs
29 go xs i = do x <- get
30 x `seq` go (x:xs) (i-1)
31{-# INLINE getMany #-}
33nats :: Int -> SizedList Int
34nats = \n -> SizedList n (aux n)
35 where
36 aux 0 = []
37 aux n = n : aux (n - 1)
39counter :: Process ()
40counter = go 0
41 where
42 go :: Int -> Process ()
43 go !n =
44 receiveWait
45 [ match $ \xs -> go (n + size (xs :: SizedList Int))
46 , match $ \them -> send them n >> go 0
47 ]
49count :: (Int, Int) -> ProcessId -> Process ()
50count (packets, sz) them = do
51 us <- getSelfPid
52 replicateM_ packets $ send them (nats sz)
53 send them us
54 n' <- expect
55 liftIO $ print (packets * sz, n' == packets * sz)
57initialProcess :: String -> Process ()
58initialProcess "SERVER" = do
59 us <- getSelfPid
60 liftIO $ BSL.writeFile "counter.pid" (encode us)
61 counter
62initialProcess "CLIENT" = do
63 n <- liftIO getLine
64 them <- liftIO $ decode <$> BSL.readFile "counter.pid"
65 count (read n) them
67main :: IO ()
68main = do
69 [role, host, port] <- getArgs
70 trans <- createTransport (defaultTCPAddr host port) defaultTCPParameters
71 case trans of
72 Right transport -> do node <- newLocalNode transport initRemoteTable
73 runProcess node $ initialProcess role
74 Left other -> error $ show other