Slow mvar when compiled with threaded

7 Jan 2014

      I have test network client, something like apache bench tool.
It uses mvars to synchronize and everything is ok when
compiled without -threaded.
real    0m2.995s
user    0m0.601s
sys    0m2.391s

With -threaded compile option result is following:
real    0m18.196s
user    0m2.054s
sys    0m3.313s

Seems that program is sleeping most of the time for some
reason. I can't explain behavior as it seems that
program is ok. It starts `concurrency` threads which
wait on mvar to process next task.

Program follows:

{-# Language OverloadedStrings #-}
import System.CPUTime
import System.IO
--import System.IO.Error
import Network.Socket hiding(recv)
import Network.Socket.ByteString
import System.Environment
import Control.Concurrent
import Control.Exception

main = do
     n <- getArgs
     let (host,port,conc,reqs) = parse n
     putStrLn $ "Connecting to " ++ host ++ " " ++ port
     s <- getAddrInfo Nothing (Just host) (Just port)
     let servAddr = head s
     begin <- getCPUTime
     process servAddr conc reqs
     end <- getCPUTime
     let diff = (fromIntegral (end - begin))/(10^12) :: Double
     putStrLn $ show (round (fromIntegral reqs / diff)) ++ " r/s"

parse [h,p,conc,reqs] = (h,p,read conc::Int,read reqs::Int)
parse _ = error "usage client host port concurrency requests"

process servAddr conc reqs = do
     let niter = if reqs >= conc then conc else reqs
     putStrLn $ "loop " ++ show niter
     mvars <- initThreads niter []
     putStrLn $ "Initialized " ++ show niter
     let loop n (m:mvs) f | n>0  = do
             flag <- isEmptyMVar m
             if f > length mvars then putStrLn "busy" else return ()
             if flag || f > length mvars
                 then do
                     putMVar m ()
                     loop (n-1) mvs 0
                 else loop n mvs (f+1)
             | otherwise = return ()
         loop n [] f = if n>0 then loop n mvars f else return ()
     putStrLn $ "length " ++ show (length mvars)
     loop (reqs-niter) mvars 0
     where
         initThreads niter vars | niter > 0 =  do
             mvar <- newMVar ()
             forkIO $ process mvar
             initThreads (niter-1) (mvar:vars)
             | otherwise = return vars
         process mvar = do
             sock <- socket (addrFamily servAddr) Stream defaultProtocol
             connect sock (addrAddress servAddr)
             sendAll sock "Hello World!\n"
             buf <- recv sock 1024
             close sock
             takeMVar mvar
             process mvar

Branimir Maksimovic

Bob Ippolito

Branimir Maksimovic

Bob Ippolito

Branimir Maksimovic

Bob Ippolito

Bob Ippolito

Bob Ippolito

Branimir Maksimovic

tags

participants (2)