git.iko.soy/distributed-process
on master help sign in
Minor modifications to improve profiling
commit94a1dd51443dc2c786b7fd39901bb427fa87ea12 authorEdsko de Vries <edsko@well-typed.com> dateWed 11 Apr 2012, 17:08 (15 years ago) parent90cb954
3 files changed+24−13
compare with master
unifiedsplit
benchmarks/Makefile+1−1 benchmarks/PingTCP.hs+12−4 benchmarks/PingTCPTransport.hs+11−8
benchmarks/Makefile+1−1
@@ -9,7 +9,7 @@ trials = 1
99INCLUDES= -i../network-transport/src -i../network-transport-pipes/src
1010
1111# Enable for profiling
12−PROFILING=-prof -fprof-auto
12+# PROFILING=-prof -fprof-auto
1313
1414ifeq ($(GHC),)
1515 GHC=ghc
benchmarks/PingTCP.hs+12−4
@@ -109,15 +109,23 @@ ping sock pings = go [] pings
109109 putStrLn $ "client did " ++ show pings ++ " pings"
110110 go rtl !i = do
111111 before <- getCurrentTime
112− NBS.send sock pingMessage
113− bs <- NBS.recv sock 8
112+ send sock pingMessage
113+ bs <- recv sock 8
114114 after <- getCurrentTime
115115 let latency = (1e6 :: Double) * realToFrac (diffUTCTime after before)
116116 latency `seq` go (latency : rtl) (i - 1)
117117
118118pong :: Socket -> IO ()
119119pong sock = do
120− bs <- NBS.recv sock 8
120+ bs <- recv sock 8
121121 when (BS.length bs > 0) $ do
122− NBS.sendAll sock bs
122+ send sock bs
123123 pong sock
124+
125+-- | Wrapper around NBS.recv (for profiling)
126+recv :: Socket -> Int -> IO ByteString
127+recv = NBS.recv
128+
129+-- | Wrapper around NBS.send (for profiling)
130+send :: Socket -> ByteString -> IO Int
131+send = NBS.send
benchmarks/PingTCPTransport.hs+11−8
@@ -53,7 +53,8 @@ decode :: Ser.Serialize a => BS.ByteString -> Either String a
5353main :: IO ()
5454main = do
5555 [pingsStr] <- getArgs
56− serverReady <- newEmptyMVar
56+ serverAddr <- newEmptyMVar
57+ clientAddr <- newEmptyMVar
5758
5859 -- Start the server
5960 forkIO $ do
@@ -63,19 +64,19 @@ main = do
6364 -- create ping end
6465 putStrLn "server: creating ping end"
6566 (sourceAddrPing, targetEndPing) <- newConnection transport
66− putMVar serverReady sourceAddrPing
67+ putMVar serverAddr sourceAddrPing
6768
6869 -- create pong end
6970 putStrLn "server: creating pong end"
70− [sourceAddrPongBS] <- receive targetEndPing
71− sourceEndPong <- connect . fromJust $ deserialize transport sourceAddrPongBS
71+ sourceAddrPong <- takeMVar clientAddr
72+ sourceEndPong <- connect sourceAddrPong
7273
7374 -- always respond to a ping with a pong
7475 putStrLn "server: awaiting pings"
7576 pong targetEndPing sourceEndPong
7677
7778 -- Client
78− sourceAddr <- takeMVar serverReady
79+ sourceAddr <- takeMVar serverAddr
7980 let pings = read pingsStr
8081 -- establish transport
8182 transport <- mkTransport $ TCPConfig defaultHints "127.0.0.1" "8081"
@@ -85,7 +86,7 @@ main = do
8586
8687 -- create pong end
8788 (sourceAddrPong, targetEndPong) <- newConnection transport
88− send sourceEndPing [serialize sourceAddrPong]
89+ putMVar clientAddr sourceAddrPong
8990
9091 ping sourceEndPing targetEndPong pings
9192 putStrLn "Done with all ping/pongs."
@@ -97,8 +98,9 @@ pingMessage = BS.pack "ping123"
9798-- | Keep replying to pings (send pongs)
9899pong :: TargetEnd -> SourceEnd -> IO ()
99100pong targetEndPing sourceEndPong = do
100− bs <- receive targetEndPing
101− send sourceEndPong bs
101+ [bs] <- receive targetEndPing
102+ -- putStrLn $ "server got " ++ BS.unpack bs
103+ send sourceEndPong [bs]
102104 pong targetEndPing sourceEndPong
103105
104106-- | Send a number of pings
@@ -113,6 +115,7 @@ ping sourceEndPing targetEndPong pings = go [] pings
113115 before <- getCurrentTime
114116 send sourceEndPing [pingMessage]
115117 [bs] <- receive targetEndPong
118+ -- putStrLn $ "client got " ++ BS.unpack bs
116119 after <- getCurrentTime
117120 let latency = (1e6 :: Double) * realToFrac (diffUTCTime after before)
118121 latency `seq` go (latency : rtl) (i - 1)