Permalink
Browse files

Resurect the simple ping/pong benchmark. This new network-transport-t…

…cp does better, but still twice as slow as raw Network.Socket
  • Loading branch information...
1 parent a5daa9a commit 92ac241444cf694af1be4398c5e9b83d5d44609a @rrnewton rrnewton committed Aug 7, 2012
Showing with 370 additions and 0 deletions.
  1. +76 −0 benchmarks/Makefile
  2. +124 −0 benchmarks/PingPongTCP.hs
  3. +146 −0 benchmarks/PingPongTCPTransport.hs
  4. +24 −0 benchmarks/results_notes.md
View
@@ -0,0 +1,76 @@
+
+# Makefile for building and running benchmarks.
+# Usage:
+# make all
+# make run
+
+#--------------------------------------------------------------------------------
+# Settings
+
+# By default, run 100K ping-pongs, for one trial:
+size = 100000
+trials = 1
+# Alternatively, you can run "make run1 size=1000 trials=100", for example.
+
+ifeq ($(GHC),)
+ GHC=ghc
+endif
+
+BENCHS= PingPongTCP.exe PingPongTCPTransport.exe
+# PingPongPipes.exe SendTransport.exe
+
+all: $(BENCHS)
+$(BENCHS): %.exe: %.hs
+ $(GHC) -O2 -rtsopts -threaded --make $(INCLUDES) $< -o $@
+
+#-------------------------------------------------------------------------------
+# Shorthands for running benchmarks:
+
+run: run1 run2
+# Disabled: run3 run4
+
+# Benchmark raw sockets without network-transport:
+run1: runBaseline
+runBaseline:
+ ./PingPongTCP.exe server 8080 &
+ sleep 1
+ time ./PingPongTCP.exe client 0.0.0.0 8080 $(size) $(trials)
+ # Kill the server:
+ killall PingPongTCP.exe
+
+run2: runTCP
+runTCP:
+ ./PingPongTCPTransport.exe server 0.0.0.0 8080 sourceAddr.txt &
+ sleep 1
+ # Run 100K ping-pongs, for one trial:
+ time ./PingPongTCPTransport.exe client 0.0.0.0 8081 sourceAddr.txt $(size) $(trials)
+ # Kill the server:
+# killall PingPongTCPTransport.exe
+
+run3: runPipes
+runPipes:
+ ./PingPongPipes.exe server sourceAddr &
+ sleep 1
+ time ./PingPongPipes.exe client sourceAddr $(size) $(trials)
+ # Kill the server:
+ killall PingPongPipes.exe
+
+# This benchmark measures throughput rather than latency
+# Here 'size' means message size rather than number of pings:
+run4: runTPT
+runTPT:
+ ./SendTransport.exe server 0.0.0.0 8080 sourceAddr &
+ sleep 1
+ ./SendTransport.exe client 0.0.0.0 8081 sourceAddr $(size)
+ killall SendTransport.exe
+
+# Run multiple sizes:
+runTPTs:
+ $(MAKE) runTPT size=1000
+ $(MAKE) runTPT size=5000
+ $(MAKE) runTPT size=10000
+ $(MAKE) runTPT size=50000
+ $(MAKE) runTPT size=100000
+
+clean:
+ rm -f *.hi *.o *.exe
View
@@ -0,0 +1,124 @@
+{-# LANGUAGE CPP #-}
+
+-- | This performs a ping benchmark on a TCP connection created by
+-- Network.Socket. To compile this file, you might use:
+--
+-- ghc --make -O2 benchmarks/PingTCP.hs
+--
+-- To use the compiled binary, first set up the server on the current machine:
+--
+-- ./benchmarks/PingTCP server 8080
+--
+-- Next, perform the benchmark on a client using the server address, where
+-- each 1000 pings and one trial:
+--
+-- ./benchmarks/PingTCP client 0.0.0.0 8080 1000 1
+--
+-- The server must be restarted between benchmarks.
+
+--------------------------------------------------------------------------------
+module Main where
+
+import Control.Monad
+import Criterion.Main (Benchmark, bench, defaultMainWith, nfIO)
+import Criterion.Config (defaultConfig, ljust, Config(cfgSamples))
+
+import Data.Int
+import qualified Data.Serialize as Ser
+import Data.Word (Word8)
+import Network.Socket
+ ( AddrInfoFlag (AI_PASSIVE), HostName, ServiceName, Socket
+ , SocketType (Stream), SocketOption (ReuseAddr)
+ , accept, addrAddress, addrFlags, addrFamily, bindSocket, defaultProtocol
+ , defaultHints
+ , getAddrInfo, listen, setSocketOption, socket, sClose, withSocketsDo )
+import System.Environment (getArgs, withArgs)
+
+import qualified Network.Socket as N
+
+import Debug.Trace
+
+#ifndef LAZY
+import Data.ByteString (ByteString)
+import qualified Network.Socket.ByteString as NBS
+encode = Ser.encode
+decode = Ser.decode
+#else
+import Data.ByteString.Lazy (ByteString)
+import qualified Network.Socket.ByteString.Lazy as NBS
+encode = Ser.encodeLazy
+decode = Ser.decodeLazy
+#endif
+{-# INLINE encode #-}
+{-# INLINE decode #-}
+encode :: Ser.Serialize a => a -> ByteString
+decode :: Ser.Serialize a => ByteString -> Either String a
+
+--------------------------------------------------------------------------------
+
+main :: IO ()
+main = do
+ args <- getArgs
+ case args of
+ "server" : service : [] -> withSocketsDo $ do
+ putStrLn "server: creating TCP connection"
+ serverAddrs <- getAddrInfo
+ (Just (defaultHints { addrFlags = [AI_PASSIVE] } ))
+ Nothing
+ (Just service)
+ let serverAddr = head serverAddrs
+ sock <- socket (addrFamily serverAddr) Stream defaultProtocol
+ setSocketOption sock ReuseAddr 1
+ bindSocket sock (addrAddress serverAddr)
+
+ putStrLn "server: awaiting client connection"
+ listen sock 1
+ (clientSock, clientAddr) <- accept sock
+
+ putStrLn "server: listening for pings"
+ forever (pong clientSock)
+
+ "client": host : service : pingsStr : reps : args' -> withSocketsDo $ do
+ let pings = read pingsStr
+ serverAddrs <- getAddrInfo
+ Nothing
+ (Just host)
+ (Just service)
+ let serverAddr = head serverAddrs
+ sock <- socket (addrFamily serverAddr) Stream defaultProtocol
+
+ N.connect sock (addrAddress serverAddr)
+
+ -- benchmark the pings
+ case (read reps) :: Int of
+ 0 -> error "What would zero reps mean?"
+ 1 -> do putStrLn "Because you're timing only one trial, skipping Criterion..."
+ replicateM_ pings (ping sock)
+ n -> withArgs args' $ defaultMainWith
+ (defaultConfig{ cfgSamples = ljust n })
+ (return ()) -- Init action.
+ [ benchPing sock (fromIntegral pings) ]
+ putStrLn "Done with all ping/pongs."
+
+-- withArgs args' $ defaultMain [ benchPing sock pings ]
+-- replicateM_ pings (ping sock)
+
+-- | Each `ping` sends a single byte, and expects to receive one
+-- back in return.
+ping :: Socket -> IO Int64
+ping sock = do
+ NBS.send sock $ encode (42 :: Int64)
+ bs <- NBS.recv sock 8
+ either error return $ decode bs
+
+pong :: Socket -> IO ()
+pong sock = do
+ bs <- NBS.recv sock 8
+ NBS.sendAll sock bs
+ return ()
+
+benchPing :: Socket -> Int64 -> Benchmark
+benchPing sock n =
+ bench "PingTCP" $
+ nfIO (replicateM_ (fromIntegral n) (ping sock))
+
@@ -0,0 +1,146 @@
+{-# LANGUAGE CPP #-}
+
+
+
+-- | This performs a ping benchmark on the TCP transport. If
+-- network-transport-tcp has been "cabal install"ed, then this
+-- benchmark can be compiled with:
+--
+-- ghc --make -O2 benchmarks/PingTransport.hs
+--
+-- To use the compiled binary, first set up a server:
+--
+-- ./benchmarks/PingTCPTransport server 0.0.0.0 8080 sourceAddr.dat
+--
+-- Once this is established, launch a client to perform the benchmark. The
+-- following command sends 1000 pings for 1 trial:
+--
+-- ./benchmarks/PingTCPTransport client 0.0.0.0 8081 sourceAddr.dat 1000 1
+--
+-- The server must be restarted between benchmarks.
+
+--------------------------------------------------------------------------------
+module Main where
+
+import Network.Transport (receive, connect, send, defaultConnectHints, Event(..),
+ Connection, EndPoint, EndPointAddress(EndPointAddress), Reliability(ReliableOrdered),
+ newEndPoint, address, endPointAddressToByteString)
+import Network.Transport.TCP (createTransport, defaultTCPParameters, decodeEndPointAddress)
+
+import Control.Monad (forever, replicateM_)
+import Criterion.Main (Benchmark, bench, defaultMainWith, nfIO)
+import Criterion.Config (defaultConfig, ljust, Config(cfgSamples))
+
+import qualified Data.Serialize as Ser
+import Data.Maybe (fromJust)
+import Data.Int
+import System.Environment (getArgs, withArgs)
+
+import System.Exit (exitSuccess)
+
+#ifndef LAZY
+import qualified Data.ByteString.Char8 as BS
+encode = Ser.encode
+decode = Ser.decode
+#else
+import qualified Data.ByteString.Lazy.Char8 as BS
+encode = Ser.encodeLazy
+decode = Ser.decodeLazy
+#endif
+{-# INLINE encode #-}
+{-# INLINE decode #-}
+encode :: Ser.Serialize a => a -> BS.ByteString
+decode :: Ser.Serialize a => BS.ByteString -> Either String a
+
+--------------------------------------------------------------------------------
+
+main :: IO ()
+main = do
+ args <- getArgs
+ case args of
+ "server" : host : port : sourceAddrFilePath : [] -> do
+ -- establish transport
+ Right transport <- createTransport host port defaultTCPParameters
+
+ -- create ping end
+ putStrLn "server: creating ping end"
+-- (sourceAddrPing, targetEndPing)
+ Right endpoint <- newEndPoint transport
+ BS.writeFile sourceAddrFilePath $ endPointAddressToByteString $ address endpoint
+
+ -- create pong end
+ putStrLn "server: creating pong end"
+ -- Establish the connection:
+ event <- receive endpoint
+ Right conn <- case event of
+ ConnectionOpened cid rel addr ->
+ -- Connect right back, and since this is a single-client
+ -- benchmark, block this thread to do it:
+ connect endpoint addr rel defaultConnectHints
+ oth -> do putStrLn$" server waiting for connection, unexpected event: "++show oth
+ exitSuccess
+
+ putStrLn "server: going into pong loop..."
+ forever $ pong endpoint conn
+ return ()
+
+ "client" : host : port : sourceAddrFilePath : numPings : reps : args' -> do
+ let pings = read numPings :: Int
+ -- establish transport
+ Right transport <- createTransport host port defaultTCPParameters
+ Right endpoint <- newEndPoint transport
+
+ -- create ping end
+ bs <- BS.readFile sourceAddrFilePath
+ Right conn <- connect endpoint (EndPointAddress bs) ReliableOrdered defaultConnectHints
+-- let Just (host,port,endptID) = decodeEndPointAddress (EndPointAddress bs)
+ -- create pong end
+-- send sourceEndPing [serialize sourceAddrPong]
+
+ -- benchmark the pings
+ case (read reps) :: Int of
+ 0 -> error "Error: What would zero trials mean?"
+ 1 -> do putStrLn "Because you're timing only one trial, skipping Criterion..."
+ replicateM_ pings (ping conn endpoint 42)
+ n -> withArgs args' $ defaultMainWith
+ (defaultConfig{ cfgSamples = ljust n })
+ (return ()) -- Init action.
+ [ benchPing conn endpoint (fromIntegral pings)]
+
+ putStrLn$"client: Done with all "++show pings++" ping/pongs."
+ return ()
+
+-- | This function takes an EndPoint to receieve pings, and a
+-- Connection to send back pongs. It doesn't bother decoding the
+-- message, rather it sends it right on back.
+pong :: EndPoint -> Connection -> IO ()
+pong endpoint conn = do
+ event <- receive endpoint
+ case event of
+ Received cid payloads -> do
+ Right _ <- send conn payloads
+ return ()
+ oth -> error$"while awaiting pings, server received unexpected event: \n"++show oth
+
+-- | The effect of `ping conn endpt n` is to send the number `n` on
+-- the connection and then receive another number from the endpoint,
+-- which is then returned.
+ping :: Connection -> EndPoint -> Int64 -> IO Int64
+ping conn endpt n = do
+ send conn [encode n]
+ loop
+ where
+ loop = do
+ event <- receive endpt
+ case event of
+ Received _cid [payload] -> do
+ let (Right n2) = decode payload
+ return $! n2
+ ConnectionOpened _ _ _ -> loop -- ignore this
+ other -> error$"Unexpected event on endpoint during ping process: "++show other
+
+-- | The effect of `benchPing conn endpt n` is to send
+-- `n` pings down `conn` using the `ping` function.
+benchPing :: Connection -> EndPoint -> Int64 -> Benchmark
+benchPing conn endpoint n = bench "PingTransport" $
+ nfIO (replicateM_ (fromIntegral n) (ping conn endpoint 42))
@@ -0,0 +1,24 @@
+
+
+[2012.08.07] {A new round of testing with the new API}
+============================================================
+
+Here's a run of the ping-pong benchmark on a 3.1 ghz Intel Westmere
+running RHEL 6.2.
+
+ 100K ping/pongs, 1 trial:
+ PingTCP: 4.987 >90%CPU
+ PingTCPTransport: 11.2s ~65%CPU
+
+That's with 3.9GB allocation and 99.2% productivity.
+
+For reference, here are some old results from the previous incarnation
+of network-transport back in February:
+
+ 100K ping/pongs, 1 trial:
+ PingTCP: 7.34s >80%CPU
+ PingTCPTransport: 19s ~60%CPU
+ PingPipes: 6.36s >=100%CPU
+
+ (Running a C benchmark on the same machine it takes 5.6 seconds to do
+ 200K ping pongs. => 28 us avg latency for C)

0 comments on commit 92ac241

Please sign in to comment.