Skip to content

HTTPS clone URL

Subversion checkout URL

You can clone with
or
.
Download ZIP
Newer
Older
100644 117 lines (101 sloc) 3.471 kB
30f2f25 @tibbe Added partial simple benchmark
tibbe authored
1 -- Flow:
2 --
3 -- 1. Create N pipes.
4 --
5 -- Modelled after:
6 -- http://levent.svn.sourceforge.net/viewvc/levent/trunk/libevent/test/bench.c
7
8 module Main where
9
0fedaac @bos Get benchmarking ever so very slightly working.
bos authored
10 import Args (ljust, parseArgs, positive, theLast)
6a3ed75 @bos Run the event manager in a separate thread.
bos authored
11 import Control.Concurrent (MVar, forkIO, takeMVar, newEmptyMVar, putMVar)
0fedaac @bos Get benchmarking ever so very slightly working.
bos authored
12 import Control.Monad (forM_, replicateM, when)
13 import Data.Array.Unboxed (UArray, listArray)
14 import Data.Function (on)
15 import Data.IORef (IORef, atomicModifyIORef, newIORef)
16 import Data.Int (Int32)
17 import Data.Monoid (Monoid(..), Last(..), getLast)
18 import Foreign.C.Error (throwErrnoIfMinus1Retry)
19 import Foreign.Marshal.Alloc (alloca)
20 import Foreign.Ptr (Ptr)
21 import Foreign.C.Types (CChar)
22 import System.Console.GetOpt (ArgDescr(ReqArg), OptDescr(..))
23 import System.Environment (getArgs)
a66af36 @bos Switch the public event type over to a monoidal set.
bos authored
24 import System.Event (Event(..), evtRead, evtWrite, loop, new, registerFd)
0fedaac @bos Get benchmarking ever so very slightly working.
bos authored
25 import System.Posix.IO (createPipe)
26 import System.Posix.Resource (ResourceLimit(..), ResourceLimits(..),
27 Resource(..), setResourceLimit)
28 import System.Posix.Internals (c_close, c_read, c_write)
29 import System.Posix.Types (Fd(..))
30f2f25 @tibbe Added partial simple benchmark
tibbe authored
30
0fedaac @bos Get benchmarking ever so very slightly working.
bos authored
31 data Config = Config {
32 cfgNumPipes :: Last Int
33 }
34
35 defaultConfig :: Config
36 defaultConfig = Config {
37 cfgNumPipes = ljust 1024
38 }
39
40 instance Monoid Config where
41 mempty = Config {
42 cfgNumPipes = mempty
43 }
44 mappend a b = Config {
45 cfgNumPipes = app cfgNumPipes a b
46 }
47 where app = on mappend
48
49 defaultOptions :: [OptDescr (IO Config)]
50 defaultOptions = [
51 Option ['n'] ["num-pipes"]
52 (ReqArg (positive "number of pipes" $ \n -> mempty { cfgNumPipes = n }) "N")
53 "number of pipes to use"
54 ]
55
a66af36 @bos Switch the public event type over to a monoidal set.
bos authored
56 readCallback :: MVar () -> IORef Int -> Fd -> Event -> IO ()
6a3ed75 @bos Run the event manager in a separate thread.
bos authored
57 readCallback done ref fd _ = do
0fedaac @bos Get benchmarking ever so very slightly working.
bos authored
58 a <- atomicModifyIORef ref (\a -> let !b = a+1 in (b,b))
09efa2d @bos Make it easier to see what's happening in a callback.
bos authored
59 print ("read",fd,a)
0fedaac @bos Get benchmarking ever so very slightly working.
bos authored
60 if a > 10
6a3ed75 @bos Run the event manager in a separate thread.
bos authored
61 then do
62 close fd
63 putMVar done ()
0fedaac @bos Get benchmarking ever so very slightly working.
bos authored
64 else do
65 readByte fd
66
a66af36 @bos Switch the public event type over to a monoidal set.
bos authored
67 writeCallback :: IORef Int -> Fd -> Event -> IO ()
0fedaac @bos Get benchmarking ever so very slightly working.
bos authored
68 writeCallback ref fd _ = do
69 a <- atomicModifyIORef ref (\a -> let !b = a+1 in (b,b))
09efa2d @bos Make it easier to see what's happening in a callback.
bos authored
70 print ("write",fd,a)
0fedaac @bos Get benchmarking ever so very slightly working.
bos authored
71 if a > 10
72 then close fd
73 else do
74 writeByte fd
30f2f25 @tibbe Added partial simple benchmark
tibbe authored
75
76 main :: IO ()
77 main = do
0fedaac @bos Get benchmarking ever so very slightly working.
bos authored
78 (cfg, args) <- parseArgs defaultConfig defaultOptions =<< getArgs
79 let numPipes = theLast cfgNumPipes cfg
80 lim = ResourceLimit $ fromIntegral numPipes * 2 + 50
30f2f25 @tibbe Added partial simple benchmark
tibbe authored
81 setResourceLimit ResourceOpenFiles
67fafda @bsl Miscellaneous cleanup
bsl authored
82 ResourceLimits { softLimit = lim, hardLimit = lim }
30f2f25 @tibbe Added partial simple benchmark
tibbe authored
83
0fedaac @bos Get benchmarking ever so very slightly working.
bos authored
84 pipePairs <- replicateM numPipes createPipe
85 print pipePairs
86 let pipes = concatMap (\(r,w) -> [r,w]) pipePairs
87
88 mgr <- new
6a3ed75 @bos Run the event manager in a separate thread.
bos authored
89 forkIO $ loop mgr
0fedaac @bos Get benchmarking ever so very slightly working.
bos authored
90 rref <- newIORef 0
91 wref <- newIORef 0
6a3ed75 @bos Run the event manager in a separate thread.
bos authored
92 done <- newEmptyMVar
0fedaac @bos Get benchmarking ever so very slightly working.
bos authored
93 forM_ pipePairs $ \(r,w) -> do
ac77966 @bos Add file descriptor to callback arguments.
bos authored
94 registerFd mgr (readCallback done rref) r evtRead
95 registerFd mgr (writeCallback wref) w evtWrite
0fedaac @bos Get benchmarking ever so very slightly working.
bos authored
96
97 let pipeArray :: UArray Int Int32
98 pipeArray = listArray (0, numPipes) . map fromIntegral $ pipes
6a3ed75 @bos Run the event manager in a separate thread.
bos authored
99 takeMVar done
0fedaac @bos Get benchmarking ever so very slightly working.
bos authored
100
101 readByte :: Fd -> IO ()
102 readByte (Fd fd) =
103 alloca $ \p -> do
104 n <- throwErrnoIfMinus1Retry "readByte" $ c_read fd p 1
105 when (n /= 1) . error $ "readByte returned " ++ show n
106
107 writeByte :: Fd -> IO ()
108 writeByte (Fd fd) =
109 alloca $ \p -> do
110 n <- throwErrnoIfMinus1Retry "writeByte" $ c_write fd p 1
111 when (n /= 1) . error $ "writeByte returned " ++ show n
112
113 close :: Fd -> IO ()
114 close (Fd fd) = do
115 c_close fd
116 return ()
Something went wrong with that request. Please try again.